Data-Util-0.63/000755 000765 000024 00000000000 12305724300 013151 5ustar00gfxstaff000000 000000 Data-Util-0.63/.gitignore000755 000765 000024 00000000230 12040510404 015131 0ustar00gfxstaff000000 000000 .* !.gitignore !.shipit *.o *.obj *.bs Makefile* !Makefile.PL *blib META.yml MYMETA.* inc/ MANIFEST DataUtil.c *.bak ppport.h xshelper.h *.stackdump *~ Data-Util-0.63/.shipit000755 000765 000024 00000000323 12040510404 014445 0ustar00gfxstaff000000 000000 # auto-generated shipit config file. steps = FindVersion, ChangeAllVersions, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN git.tagpattern = %v git.push_to = origin CheckChangeLog.files = Changes Data-Util-0.63/benchmark/000755 000765 000024 00000000000 12305724300 015103 5ustar00gfxstaff000000 000000 Data-Util-0.63/Changes000644 000765 000024 00000013201 12305724111 014441 0ustar00gfxstaff000000 000000 Revision history for Data-Util 0.63 2014-03-06 07:42:05+0900 - Fix a crash on perl 5.19.x (tokuhirom) 0.62 2013-04-03 16:06:46 - Fix a crash on perl 5.17.x (tokuhirom) 0.61 2013-01-28 10:52:13 - Fix usage of get_code_ref() in SYNOPSIS (thanks to @toku_bass) 0.60 2012-10-20 20:54:58 - No feature changes. Just upgraded Module::Install. 0.59 2011-10-19 20:08:49 - Re-packaging with better dependencies and latest M::I 0.58 Mon Sep 13 19:40:34 2010 - Use GvCV_set() for newer perls 0.57 Sun Aug 1 17:33:44 2010 - Fix tests for newer perls 0.56 Fri Jan 1 12:24:20 2010 - Fix RT #53167 (thanks to Andreas Koenig) - Fix a configuration issue 0.55 Thu Dec 24 16:31:07 2009 - Shipped with Module::Install::XSUtil 0.19 0.54 Wed Oct 21 14:24:29 2009 - re-fix the method-modifiers issue (thanks @nekoya) - this issue seems related to RT #69939 0.53 Mon Oct 19 19:08:19 2009 - fix an issue which broke method modifiers in some cases (thanks @nekoya) 0.52 Mon Jul 13 12:20:03 2009 - fix t/06_subroutine.t for bleadperl - add repository information 0.51 Thu Jul 9 09:42:11 2009 - add rx() and is_rx() (alias regex_ref() and is_regex_ref()) - fix possible segv in modifiers (t/23_largeargs.t) - fix typos in pods 0.50 Tue Jan 20 12:32:14 2009 - fix negative subscriptive placeholders for curry() (t/23_curry_neg_ph.t) - remove wrap_subroutine() which was deprecated from 0.31 0.44 Sun Dec 21 13:06:36 2008 - add get_code_ref() for do{ no strict 'refs'; *{$pkg.'::'.$name}{CODE} } - change install/uninstall_subroutine() to accept single hash parameter (e.g. install_subroutine($pkg, { name => \&subr }) - optimize mkopt() when a HASH ref is supplied as the option list - fix possible memory leaks in mkopt() - fix documentation - fix "Insecure dependency while -T" with DATA_UTIL_PUREPERL=1 0.43 Sun Dec 14 13:37:43 2008 - fix modifer's order of modify_subroutine()/subroutine_modifier() to be compatible with Moose - fix some bugs on neat()/is_number()/install_subroutine() - remove "original" property from subroutine_modifier(), which seems a waste of memory - internal cleanup 0.42 Wed Dec 10 13:42:50 2008 - fix is_number()/is_integer() to refuse Infinity and NaN correctly - fix a possible segfault on install_subrouitne() - internal cleanup 0.41 Man Dec 8 11:36:38 2008 - change get_stash() to be able to take an object reference - change is_number()/is_integer() to refuse "0 but true" - fix some bugs 0.40 Sun Dec 7 13:42:17 2008 - add is_value()/is_string()/is_number()/is_integer() functions - change get_stash/invocant/is_invocant to refuse "" as a class name - change uninstall_subroutine() to be able to take the same arguments as install_subroutine() 0.32 Thu Dec 4 13:25:29 2008 - fix uninstall_subroutine() to work correctly (t/17_nsclean.t) 0.31 Wed Dec 3 11:56:29 2008 - rewrite mro_compat.[hc] using MRO::Compat - rename wrap_subroutine to modify_subroutine, (wrap_subroutine has been deprecated) - add benchmark/install_subr_bench.pl - internal cleanup 0.30 Sun Nov 30 17:18:46 2008 - fix wrapped subroutines to get correct arguments 0.29_02 Sun Nov 30 14:22:47 2008 - improve portability on VC++/ICC (RT#41204) - move MethodModifiers.pm from lib/ to example/lib/ - fix uninstall_subroutine() to delete subroutine stubs correctly - fix modifier calling order 0.29_01 Mon Nov 24 12:43:03 2008 - add curry() function for currying (argument binding) - add wrap_subroutine() and subroutine_modifier() - add Data::Util::MethodModifiers module - add DISCUSSIONS section in JA.pod - update ppport.h to 3.14_05 0.21 Mon Nov 17 13:15:52 2008 - allow install_subroutine() to accept multiple pairs of name and code - add uninstall_subroutine() - change get_code_info() to return the full qualified name in scalar context 0.20 Sun Nov 16 13:04:56 2008 - add more tests - fix some bugs - remove Data::OptList dependency - internal cleanup 0.19_01 Wed Nov 12 22:33:23 2008 - some imcompatible changes - remove -fast_isa subdirective, which is no longer useful - remove -fail_handler subdirective, use Data::Util::Error instead. - add Data::Util::Error module for error handling - add invocant() and is_invocant() - add mkopt() and mkopt_hash() which are compatible with Data::OptList - improve error handlers to be inheritable - fix install_subroutine() not to locate subroutines named by Sub::Name 0.11 Mon Nov 3 10:09:57 2008 - fix possible segfault in get_code_info() 0.10 Sat Nov 1 11:02:06 2008 - add get_code_info() - add lib/Data/Util/JA.pod - add pure-perl implementation - internal cleanup 0.05 Tue Oct 28 22:39:58 2008 - add install_subroutine() - internal cleanup 0.041 Mon Oct 27 08:27:11 2008 - fix C99 portability - fix is_instance() to return a bool - fix get_stash() to accept undef silently 0.04 Sun Oct 26 10:19:11 2008 - change messsages - improve neat() when HASH or ARRAY is supplied - add "-fail_handler" subdirective - add c99portability.h for C99 portability 0.03 Fri Oct 24 12:17:13 2008 - remove unused code - a bit of optimization (using 'inline' effectively) 0.02 Fri Oct 24 09:10:31 2008 - derived from Scalar::Util::Ref - add "-fast_isa" subdirective which makes UNIVERSAL::isa() faster - remove "instanceof" operator - many optimizations - fix some bugs 0.01 Sat Oct 4 11:32:36 2008 - original version; created by Module::Starter started as Scalar::Util::Ref Data-Util-0.63/data-util.h000644 000765 000024 00000002333 12040510404 015201 0ustar00gfxstaff000000 000000 /* Data-Util/data-util.h */ #include "xshelper.h" #include "mro_compat.h" #include "str_util.h" #ifndef SvRXOK #define SvRXOK(sv) ((SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG) && mg_find(SvRV(sv), PERL_MAGIC_qr)) ? TRUE : FALSE) #endif #define PUSHary(ary, start, len) STMT_START{ \ I32 i; \ I32 const length = (len); \ for(i = (start) ;i < length; i++){\ PUSHs(ary[i]); \ } \ } STMT_END #define XPUSHary(ary, start, len) STMT_START{ \ I32 i; \ I32 const length = (len); \ EXTEND(SP, length); \ for(i = (start) ;i < length; i++){\ PUSHs(ary[i]); \ } \ } STMT_END #define is_string(x) (SvOK(x) && !SvROK(x) && (SvPOKp(x) ? SvCUR(x) > 0 : TRUE)) #define neat(x) du_neat(aTHX_ x) const char* du_neat(pTHX_ SV* x); /* curry ingand modifiers */ /* modifier accessros */ enum{ M_BEFORE, M_AROUND, M_AFTER, M_CURRENT, M_LENGTH }; #define mg_find_by_vtbl(sv, vtbl) my_mg_find_by_vtbl(aTHX_ sv, vtbl) MAGIC* my_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl); XS(XS_Data__Util_curried); XS(XS_Data__Util_modified); Data-Util-0.63/DataUtil.xs000644 000765 000024 00000064347 12126752340 015260 0ustar00gfxstaff000000 000000 // vim: set noexpandtab: /* Data-Util/DataUtil.xs */ #define NEED_mro_get_linear_isa #include "data-util.h" #define MY_CXT_KEY "Data::Util::_guts" XS_VERSION #define NotReached assert(((void)"PANIC: NOT REACHED", 0)) #define is_special_nv(nv) (nv == NV_INF || nv == -NV_INF || Perl_isnan(nv)) typedef struct{ GV* universal_isa; GV* croak; } my_cxt_t; START_MY_CXT; /* null magic virtual table to identify magic functions */ extern MGVTBL curried_vtbl; extern MGVTBL modified_vtbl; MGVTBL subr_name_vtbl; typedef enum{ T_NOT_REF, T_SV, T_AV, T_HV, T_CV, T_GV, T_IO, T_FM, T_RX, T_OBJECT, T_VALUE, T_STR, T_NUM, T_INT } my_type_t; static const char* const ref_names[] = { NULL, /* NOT_REF */ "a SCALAR reference", "an ARRAY reference", "a HASH reference", "a CODE reference", "a GLOB reference", NULL, /* IO */ NULL, /* FM */ "a regular expression reference", /* RX */ NULL /* OBJECT */ }; static void my_croak(pTHX_ const char* const fmt, ...) __attribute__format__(__printf__, pTHX_1, pTHX_2); static void my_croak(pTHX_ const char* const fmt, ...){ dMY_CXT; dSP; SV* message; va_list args; ENTER; SAVETMPS; if(!MY_CXT.croak){ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("Data::Util::Error"), NULL, NULL); MY_CXT.croak = CvGV(get_cv("Data::Util::Error::croak", GV_ADD)); SvREFCNT_inc_simple_void_NN(MY_CXT.croak); } va_start(args, fmt); message = vnewSVpvf(fmt, &args); va_end(args); PUSHMARK(SP); mXPUSHs(message); PUTBACK; call_sv((SV*)MY_CXT.croak, G_VOID); NotReached; /* FREETMPS; LEAVE; */ } static void my_fail(pTHX_ const char* const name, SV* value){ my_croak(aTHX_ "Validation failed: you must supply %s, not %s", name, neat(value)); } static int S_nv_is_integer(pTHX_ NV const nv) { if(nv == (NV)(IV)nv){ return TRUE; } else { char buf[64]; /* Must fit sprintf/Gconvert of longest NV */ char* p; (void)Gconvert(nv, NV_DIG, 0, buf); p = &buf[0]; /* -?[0-9]+ */ if(*p == '-') p++; while(*p){ if(!isDIGIT(*p)){ return FALSE; } p++; } return TRUE; } } static int my_check_type_primitive(pTHX_ SV* const sv, const my_type_t t){ if(!SvOK(sv) || SvROK(sv) || isGV(sv)){ return FALSE; } switch(t){ case T_INT: /* check POK, NOK and IOK respectively */ if(SvPOKp(sv)){ int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL); if(num_type && !strEQ(SvPVX(sv), "0 but true")){ return !(num_type & IS_NUMBER_NOT_INT); } } else if(SvNOKp(sv)){ NV const nv = SvNVX(sv); return S_nv_is_integer(aTHX_ nv); } else if(SvIOKp(sv)){ return TRUE; } break; case T_NUM: if(SvPOKp(sv)){ int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL); if(num_type && !strEQ(SvPVX(sv), "0 but true")){ return !(num_type & (IS_NUMBER_INFINITY | IS_NUMBER_NAN)); } } else if(SvNOKp(sv)){ NV const nv = SvNVX(sv); return !is_special_nv(nv); } else if(SvIOKp(sv)){ return TRUE; } break; case T_STR: if(SvPOKp(sv)){ return SvCUR(sv) > 0; } /* fall throught */ default:/* T_VALUE */ return TRUE; } return FALSE; } static bool my_has_amagic_converter(pTHX_ SV* const sv, const my_type_t t){ const AMT* amt; const HV *stash; int o = 0; if ( (!SvAMAGIC(sv)) || (!(stash = SvSTASH(SvRV(sv)))) || (!Gv_AMG((HV*)stash)) ) { return FALSE; } amt = (AMT*)mg_find((SV*)stash, PERL_MAGIC_overload_table)->mg_ptr; assert(amt); assert(AMT_AMAGIC(amt)); switch(t){ case T_SV: o = to_sv_amg; break; case T_AV: o = to_av_amg; break; case T_HV: o = to_hv_amg; break; case T_CV: o = to_cv_amg; break; case T_GV: o = to_gv_amg; break; default: NotReached; } return amt->table[o] ? TRUE : FALSE; } #define check_type(sv, t) my_check_type(aTHX_ sv, t) static int my_check_type(pTHX_ SV* const sv, const my_type_t t){ if(!SvROK(sv)){ return FALSE; } if(SvOBJECT(SvRV(sv))){ if(t == T_RX){ /* regex? */ return SvRXOK(sv); } else{ SvGETMAGIC(sv); return my_has_amagic_converter(aTHX_ sv, t); } } switch(SvTYPE(SvRV(sv))){ case SVt_PVAV: return T_AV == t; case SVt_PVHV: return T_HV == t; case SVt_PVCV: return T_CV == t; case SVt_PVGV: return T_GV == t; case SVt_PVIO: return T_IO == t; case SVt_PVFM: return T_FM == t; default: NOOP; } return T_SV == t; } #define deref_av(sv) my_deref_av(aTHX_ sv) #define deref_hv(sv) my_deref_hv(aTHX_ sv) #define deref_cv(sv) my_deref_cv(aTHX_ sv) static AV* my_deref_av(pTHX_ SV* sv){ SvGETMAGIC(sv); if(my_has_amagic_converter(aTHX_ sv, T_AV)){ SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */ tryAMAGICunDEREF(to_av); } if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)){ my_fail(aTHX_ ref_names[T_AV], sv); } return (AV*)SvRV(sv); } static HV* my_deref_hv(pTHX_ SV* sv){ SvGETMAGIC(sv); if(my_has_amagic_converter(aTHX_ sv, T_HV)){ SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */ tryAMAGICunDEREF(to_hv); } if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)){ my_fail(aTHX_ ref_names[T_HV], sv); } return (HV*)SvRV(sv); } static CV* my_deref_cv(pTHX_ SV* sv){ SvGETMAGIC(sv); if(my_has_amagic_converter(aTHX_ sv, T_CV)){ SV* const* sp = &sv; /* used in tryAMAGICunDEREF macro */ tryAMAGICunDEREF(to_cv); } if(!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)){ my_fail(aTHX_ ref_names[T_CV], sv); } return (CV*)SvRV(sv); } #define validate(sv, t) my_validate(aTHX_ sv, t) static SV* my_validate(pTHX_ SV* const sv, my_type_t const ref_type){ SvGETMAGIC(sv); if(!check_type(sv, ref_type)){ my_fail(aTHX_ ref_names[ref_type], sv); } return sv; } static SV* my_string(pTHX_ SV* const sv, const char* const name){ SvGETMAGIC(sv); if(!is_string(sv)) my_fail(aTHX_ name, sv); return sv; } static const char* my_canon_pkg(pTHX_ const char* name){ /* "::Foo" -> "Foo" */ if(name[0] == ':' && name[1] == ':'){ name += 2; } /* "main::main::main::Foo" -> "Foo" */ while(strnEQ(name, "main::", sizeof("main::")-1)){ name += sizeof("main::")-1; } return name; } static int my_isa_lookup(pTHX_ HV* const stash, const char* klass_name){ const char* const stash_name = my_canon_pkg(aTHX_ HvNAME_get(stash)); klass_name = my_canon_pkg(aTHX_ klass_name); if(strEQ(stash_name, klass_name)){ return TRUE; } else if(strEQ(klass_name, "UNIVERSAL")){ return TRUE; } else{ AV* const linearized_isa = mro_get_linear_isa(stash); SV** svp = AvARRAY(linearized_isa) + 1; /* skip this class */ SV** const end = svp + AvFILLp(linearized_isa); /* start + 1 + last index */ while(svp != end){ if(strEQ(klass_name, my_canon_pkg(aTHX_ SvPVX(*svp)))){ return TRUE; } svp++; } } return FALSE; } static int my_instance_of(pTHX_ SV* const x, SV* const klass){ if( !is_string(klass) ){ my_fail(aTHX_ "a class name", klass); } if( SvROK(x) && SvOBJECT(SvRV(x)) ){ dMY_CXT; HV* const stash = SvSTASH(SvRV(x)); GV* const isa = gv_fetchmeth_autoload(stash, "isa", sizeof("isa")-1, 0 /* special zero, not flags nor bool */); /* common cases */ if(isa == NULL || GvCV(isa) == GvCV(MY_CXT.universal_isa)){ return my_isa_lookup(aTHX_ stash, SvPV_nolen_const(klass)); } /* special cases */ /* call their own ->isa() method */ { int retval; dSP; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(x); PUSHs(klass); PUTBACK; call_sv((SV*)isa, G_SCALAR | G_METHOD); SPAGAIN; retval = SvTRUE(TOPs); (void)POPs; PUTBACK; FREETMPS; LEAVE; return retval; } } return FALSE; } #define type_isa(sv, type) my_type_isa(aTHX_ sv, type) static bool my_type_isa(pTHX_ SV* const sv, SV* const type){ const char* const typestr = SvPV_nolen_const(type); switch(typestr[0]){ case 'S': if(strEQ(typestr, "SCALAR")){ return check_type(sv, T_SV); } break; case 'A': if(strEQ(typestr, "ARRAY")){ return check_type(sv, T_AV); } break; case 'H': if(strEQ(typestr, "HASH")){ return check_type(sv, T_HV); } break; case 'C': if(strEQ(typestr, "CODE")){ return check_type(sv, T_CV); } break; case 'G': if(strEQ(typestr, "GLOB")){ return check_type(sv, T_GV); } break; } return my_instance_of(aTHX_ sv, type); } static void my_opt_add(pTHX_ AV* const result_av, HV* const result_hv, SV* const moniker, SV* const name, SV* const value, bool const with_validation, SV* vsv, AV* vav, HV* const vhv ){ if(with_validation && SvOK(value)){ if(vhv){ HE* const he = hv_fetch_ent(vhv, name, FALSE, 0U); vav = NULL; if(he){ SV* const sv = hv_iterval(vhv, he); if(check_type(sv, T_AV)){ vav = deref_av(sv); } else if(SvOK(sv)){ vsv = sv; } else{ goto store_pair; } } else{ goto store_pair; } } if(vav){ I32 const len = av_len(vav)+1; I32 i; for(i = 0; i < len; i++){ if(type_isa(value, *av_fetch(vav, i, TRUE))){ break; } } if(i == len) goto validation_failed; } else{ if(!type_isa(value, vsv)){ validation_failed: my_croak(aTHX_ "%s-ref values are not valid for %"SVf" in %"SVf" opt list", sv_reftype(SvRV(value), TRUE), name, moniker); } } } store_pair: if(result_av){ /* push @result, [$name => $value] */ SV* pair[2]; pair[0] = name; pair[1] = value; av_push(result_av, newRV_noinc((SV*) av_make(2, pair))); } else{ /* $result{$name} = $value */ (void)hv_store_ent(result_hv, name, newSVsv(value), 0U); } } static SV* my_mkopt(pTHX_ SV* const opt_list, SV* const moniker, const bool require_unique, SV* must_be, const my_type_t result_type){ SV* ret; AV* result_av = NULL; HV* result_hv = NULL; HV* vhv = NULL; /* validator HV */ AV* vav = NULL; /* validator AV */ bool const with_validation = SvOK(must_be) ? TRUE : FALSE; if(with_validation){ if(check_type(must_be, T_HV)){ vhv = deref_hv(must_be); } else if(check_type(must_be, T_AV)){ vav = deref_av(must_be); } else if(!is_string(must_be)){ my_fail(aTHX_ "type constraints", must_be); } } if(result_type == T_AV){ result_av = newAV(); ret = (SV*)result_av; } else{ result_hv = newHV(); ret = (SV*)result_hv; } sv_2mortal(ret); if(check_type(opt_list, T_AV)){ HV* seen = NULL; AV* const opt_av = deref_av(opt_list); I32 const len = av_len(opt_av) + 1; I32 i; if(require_unique){ seen = newHV(); sv_2mortal((SV*)seen); } for(i = 0; i < len; i++){ SV* const name = my_string(aTHX_ *av_fetch(opt_av, i, TRUE), "an option name"); SV* value; if(require_unique){ HE* const he = hv_fetch_ent(seen, name, TRUE, 0U); SV* const count = hv_iterval(seen, he); if(SvTRUE(count)){ my_croak(aTHX_ "Multiple definitions provided for %"SVf" in %"SVf" opt list", name, moniker); } sv_inc(count); /* count++ */ } if( (i+1) == len ){ /* last */ value = &PL_sv_undef; } else{ value = *av_fetch(opt_av, i+1, TRUE); if(SvROK(value) || !SvOK(value)){ i++; } else{ value = &PL_sv_undef; } } my_opt_add(aTHX_ result_av, result_hv, moniker, name, value, with_validation, must_be, vav, vhv); } } else if(check_type(opt_list, T_HV)){ HV* const opt_hv = deref_hv(opt_list); I32 keylen; char* key; SV* value; SV* const name = sv_newmortal(); hv_iterinit(opt_hv); while((value = hv_iternextsv(opt_hv, &key, &keylen))){ sv_setpvn(name, key, keylen); /* copied in my_opt_add */ if(!SvROK(value) && SvOK(value)){ value = &PL_sv_undef; } my_opt_add(aTHX_ result_av, result_hv, moniker, name, value, with_validation, must_be, vav, vhv); } } else if(SvOK(opt_list)){ my_fail(aTHX_ "an ARRAY or HASH reference", opt_list); } return newRV_inc(ret); } /* $code = curry($_, (my $tmp = $code_ref), *_) for @around; */ static SV* my_build_around_code(pTHX_ SV* code_ref, AV* const around){ I32 i; for(i = av_len(around); i >= 0; i--){ CV* current; MAGIC* mg; SV* const sv = validate(*av_fetch(around, i, TRUE), T_CV); AV* const params = newAV(); AV* const placeholders = newAV(); av_store(params, 0, newSVsv(sv)); /* base proc */ av_store(params, 1, newSVsv(code_ref)); /* first argument (next proc) */ av_store(params, 2, &PL_sv_undef); /* placeholder hole */ av_store(placeholders, 2, (SV*)PL_defgv); // *_ SvREFCNT_inc_simple_void_NN(PL_defgv); current = newXS(NULL /* anonymous */, XS_Data__Util_curried, __FILE__); mg = sv_magicext((SV*)current, (SV*)params, PERL_MAGIC_ext, &curried_vtbl, (const char*)placeholders, HEf_SVKEY); SvREFCNT_dec(params); /* because: refcnt++ in sv_magicext() */ SvREFCNT_dec(placeholders); /* because: refcnt++ in sv_magicext() */ CvXSUBANY(current).any_ptr = (void*)mg; code_ref = newRV_noinc((SV*)current); sv_2mortal(code_ref); } return newSVsv(code_ref); } static void my_gv_setsv(pTHX_ GV* const gv, SV* const sv){ ENTER; SAVETMPS; sv_setsv_mg((SV*)gv, sv_2mortal(newRV_inc((sv)))); FREETMPS; LEAVE; } static void my_install_sub(pTHX_ HV* const stash, const char* const name, STRLEN const namelen, SV* code_ref){ CV* const code = deref_cv(code_ref); GV* const gv = (GV*)*hv_fetch(stash, name, namelen, TRUE); if(!isGV(gv)) gv_init(gv, stash, name, namelen, GV_ADDMULTI); my_gv_setsv(aTHX_ gv, (SV*)code); /* *foo = \&bar */ if(CvANON(code) && CvGV(code) /* under construction? */ && isGV(CvGV(code)) /* released? */){ /* rename cv with gv */ CvGV_set(code, gv); CvANON_off(code); } } static void my_uninstall_sub(pTHX_ HV* const stash, const char* const name, STRLEN const namelen, SV* const specified_code_ref){ GV** const gvp = (GV**)hv_fetch(stash, name, namelen, FALSE); if(gvp){ GV* const gv = *gvp; CV* const specified_code = SvOK(specified_code_ref) ? deref_cv(specified_code_ref) : NULL; GV* newgv; CV* code; if(!isGV(gv)){ /* a subroutine stub or special constant*/ if(SvROK((SV*)gv) && ckWARN(WARN_MISC)){ Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s uninstalled", name); } (void)hv_delete(stash, name, namelen, G_DISCARD); return; } if(!(code = GvCVu(gv))){ return; } /* when an uninstalled subroutine is supplied ... */ if( specified_code && specified_code != code ){ return; /* skip */ } if(CvCONST(code) && ckWARN(WARN_MISC)){ Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s uninstalled", name); } (void)hv_delete(stash, name, namelen, G_DISCARD); if(SvREFCNT(gv) == 0 || !( GvSV(gv) || GvAV(gv) || GvHV(gv) || GvIO(gv) || GvFORM(gv))){ return; /* no need to retrieve gv */ } newgv = (GV*)*hv_fetch(stash, name, namelen, TRUE); gv_init(newgv, stash, name, namelen, GV_ADDMULTI); /* vivify */ /* restore all slots other than GvCV */ if(GvSV(gv)) my_gv_setsv(aTHX_ newgv, GvSV(gv)); if(GvAV(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvAV(gv)); if(GvHV(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvHV(gv)); if(GvIO(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvIOp(gv)); if(GvFORM(gv)) my_gv_setsv(aTHX_ newgv, (SV*)GvFORM(gv)); } } static void initialize_my_cxt(pTHX_ my_cxt_t* const cxt){ cxt->universal_isa = CvGV(get_cv("UNIVERSAL::isa", GV_ADD)); SvREFCNT_inc_simple_void_NN(cxt->universal_isa); cxt->croak = NULL; } #define UNDEF &PL_sv_undef MODULE = Data::Util PACKAGE = Data::Util PROTOTYPES: DISABLE BOOT: { MY_CXT_INIT; initialize_my_cxt(aTHX_ &MY_CXT); } void CLONE(...) CODE: MY_CXT_CLONE; initialize_my_cxt(aTHX_ &MY_CXT); PERL_UNUSED_VAR(items); #define T_RX_deprecated T_RX void is_scalar_ref(x) SV* x ALIAS: is_scalar_ref = T_SV is_array_ref = T_AV is_hash_ref = T_HV is_code_ref = T_CV is_glob_ref = T_GV is_regex_ref = T_RX_deprecated is_rx = T_RX CODE: SvGETMAGIC(x); ST(0) = boolSV(check_type(x, (my_type_t)ix)); XSRETURN(1); void scalar_ref(x) SV* x ALIAS: scalar_ref = T_SV array_ref = T_AV hash_ref = T_HV code_ref = T_CV glob_ref = T_GV regex_ref = T_RX_deprecated rx = T_RX CODE: SvGETMAGIC(x); if(check_type(x, (my_type_t)ix)){ XSRETURN(1); /* return the first value */ } my_fail(aTHX_ ref_names[ix], x); void is_instance(x, klass) SV* x SV* klass CODE: SvGETMAGIC(x); SvGETMAGIC(klass); ST(0) = boolSV(my_instance_of(aTHX_ x, klass)); XSRETURN(1); void instance(x, klass) SV* x SV* klass CODE: SvGETMAGIC(x); SvGETMAGIC(klass); if( my_instance_of(aTHX_ x, klass) ){ XSRETURN(1); /* return $_[0] */ } my_croak(aTHX_ "Validation failed: you must supply an instance of %"SVf", not %s", klass, neat(x)); void invocant(x) SV* x ALIAS: is_invocant = 0 invocant = 1 PREINIT: bool result; CODE: SvGETMAGIC(x); if(SvROK(x)){ result = SvOBJECT(SvRV(x)) ? TRUE : FALSE; } else if(is_string(x)){ result = gv_stashsv(x, FALSE) ? TRUE : FALSE; } else{ result = FALSE; } if(ix == 0){ /* is_invocant() */ ST(0) = boolSV(result); XSRETURN(1); } else{ /* invocant() */ if(result){ /* XXX: do{ package ::Foo; ::Foo->something; } causes an fatal error */ if(!SvROK(x)){ dXSTARG; sv_setsv(TARG, x); /* copy the pv and flags */ sv_setpv(TARG, my_canon_pkg(aTHX_ SvPV_nolen_const(x))); ST(0) = TARG; } XSRETURN(1); } my_fail(aTHX_ "an invocant", x); } void is_value(x) SV* x ALIAS: is_value = T_VALUE is_string = T_STR is_number = T_NUM is_integer = T_INT CODE: SvGETMAGIC(x); ST(0) = boolSV(my_check_type_primitive(aTHX_ x, (my_type_t)ix)); XSRETURN(1); HV* get_stash(invocant) SV* invocant CODE: SvGETMAGIC(invocant); if(SvROK(invocant) && SvOBJECT(SvRV(invocant))){ RETVAL = SvSTASH(SvRV(invocant)); } else if(is_string(invocant)){ RETVAL = gv_stashsv(invocant, FALSE); } else{ RETVAL = NULL; } if(!RETVAL){ XSRETURN_UNDEF; } OUTPUT: RETVAL SV* anon_scalar(referent = undef) CODE: RETVAL = newRV_noinc(items == 0 ? newSV(0) : newSVsv(ST(0))); OUTPUT: RETVAL const char* neat(expr) SV* expr void install_subroutine(into, ...) SV* into PREINIT: HV* stash; int i; CODE: stash = gv_stashsv(my_string(aTHX_ into, "a package name"), TRUE); if(items == 2){ HV* const hv = deref_hv(ST(1)); I32 namelen; char* name; SV* code_ref; hv_iterinit(hv); while((code_ref = hv_iternextsv(hv, &name, &namelen))){ my_install_sub(aTHX_ stash, name, namelen, code_ref); } } else{ if( ((items-1) % 2) != 0 ){ my_croak(aTHX_ "Odd number of arguments for %s", GvNAME(CvGV(cv))); } for(i = 1; i < items; i += 2){ SV* const as = my_string(aTHX_ ST(i), "a subroutine name"); STRLEN namelen; const char* const name = SvPV_const(as, namelen); SV* const code_ref = ST(i+1); my_install_sub(aTHX_ stash, name, namelen, code_ref); } } void uninstall_subroutine(package, ...) SV* package PREINIT: HV* stash; int i; CODE: stash = gv_stashsv(my_string(aTHX_ package, "a package name"), FALSE); if(!stash) XSRETURN_EMPTY; if(items == 2 && SvROK(ST(1))){ HV* const hv = deref_hv(ST(1)); I32 namelen; char* name; SV* specified_code_ref; hv_iterinit(hv); while((specified_code_ref = hv_iternextsv(hv, &name, &namelen))){ my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref); } } else{ for(i = 1; i < items; i++){ SV* const namesv = my_string(aTHX_ ST(i), "a subroutine name"); STRLEN namelen; const char* const name = SvPV_const(namesv, namelen); SV* specified_code_ref; if( (i+1) < items && SvROK(ST(i+1)) ){ i++; specified_code_ref = ST(i); } else{ specified_code_ref = &PL_sv_undef; } my_uninstall_sub(aTHX_ stash, name, namelen, specified_code_ref); } } mro_method_changed_in(stash); void get_code_info(code) CV* code PREINIT: GV* gv; HV* stash; PPCODE: if( (gv = CvGV(code)) && isGV_with_GP(gv) && (stash = (GvSTASH(gv))) && HvNAME_get(stash) ){ if(GIMME_V == G_ARRAY){ EXTEND(SP, 2); mPUSHs(newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U)); mPUSHs(newSVpvn_share(GvNAME(gv), GvNAMELEN(gv), 0U)); } else{ SV* const sv = newSVpvf("%s::%s", HvNAME_get(stash), GvNAME(gv)); mXPUSHs(sv); } } SV* get_code_ref(package, name, ...) SV* package SV* name INIT: I32 flags = 0; RETVAL = &PL_sv_undef; CODE: (void)my_string(aTHX_ package, "a package name"); (void)my_string(aTHX_ name, "a subroutine name"); if(items > 2){ /* with flags */ I32 i; for(i = 2; i < items; i++){ SV* const sv = my_string(aTHX_ ST(i), "a flag"); if(strEQ(SvPV_nolen_const(sv), "-create")){ flags |= GV_ADD; } else{ my_fail(aTHX_ "a flag", sv); } } } { HV* const stash = gv_stashsv(package, flags); if(stash){ STRLEN len; const char* const pv = SvPV_const(name, len); GV** const gvp = (GV**)hv_fetch(stash, pv, len, flags); GV* const gv = gvp ? *gvp : NULL; if(gv){ if(!isGV(gv)) gv_init(gv, stash, pv, len, GV_ADDMULTI); if(GvCVu(gv)){ RETVAL = newRV_inc((SV*)GvCV(gv)); } else if(flags & GV_ADD){ SV* const sv = Perl_newSVpvf(aTHX_ "%"SVf"::%"SVf, package, name); /* from Perl_get_cvn_flags() in perl.c */ CV* const cv = newSUB( start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, sv), NULL, NULL); RETVAL = newRV_inc((SV*)cv); } } } } OUTPUT: RETVAL SV* curry(code, ...) SV* code PREINIT: CV* curried; AV* params; AV* placeholders; U16 is_method; I32 i; MAGIC* mg; CODE: SvGETMAGIC(code); is_method = check_type(code, T_CV) ? 0 : G_METHOD; params = newAV(); placeholders = newAV(); av_extend(params, items-1); av_extend(placeholders, items-1); for(i = 0; i < items; i++){ SV* const sv = ST(i); SvGETMAGIC(sv); if(SvROK(sv) && SvIOKp(SvRV(sv)) && !SvOBJECT(SvRV(sv))){ // \0, \1, ... av_store(params, i, &PL_sv_undef); av_store(placeholders, i, newSVsv(SvRV(sv))); } else if(sv == (SV*)PL_defgv){ // *_ (always *main::_) av_store(params, i, &PL_sv_undef); av_store(placeholders, i, sv); /* not copy */ SvREFCNT_inc_simple_void_NN(sv); } else{ av_store(params, i, sv); /* not copy */ av_store(placeholders, i, &PL_sv_undef); SvREFCNT_inc_simple_void_NN(sv); } } curried = newXS(NULL /* anonymous */, XS_Data__Util_curried, __FILE__); mg = sv_magicext((SV*)curried, (SV*)params, PERL_MAGIC_ext, &curried_vtbl, (const char*)placeholders, HEf_SVKEY); SvREFCNT_dec((SV*)params); /* refcnt++ in sv_magicext() */ SvREFCNT_dec((SV*)placeholders); /* refcnt++ in sv_magicext() */ mg->mg_private = is_method; CvXSUBANY(curried).any_ptr = mg; RETVAL = newRV_noinc((SV*)curried); OUTPUT: RETVAL SV* modify_subroutine(code, ...) SV* code PREINIT: CV* modified; AV* before; AV* around; AV* after; AV* modifiers; /* (before, around, after, original, current) */ I32 i; MAGIC* mg; CODE: validate(code, T_CV); if( ((items - 1) % 2) != 0 ){ my_croak(aTHX_ "Odd number of arguments for %s", GvNAME(CvGV(cv))); } before = newAV(); sv_2mortal((SV*)before); around = newAV(); sv_2mortal((SV*)around); after = newAV(); sv_2mortal((SV*)after ); for(i = 1; i < items; i += 2){ /* modifier_type => [subroutine(s)] */ SV* const mtsv = my_string(aTHX_ ST(i), "a modifier type"); const char* const modifier_type = SvPV_nolen_const(mtsv); AV* const subs = deref_av(ST(i+1)); I32 const subs_len = av_len(subs) + 1; AV* av = NULL; I32 j; if(strEQ(modifier_type, "before")){ av = before; } else if(strEQ(modifier_type, "around")){ av = around; } else if(strEQ(modifier_type, "after")){ av = after; } else{ my_fail(aTHX_ "a modifier type", mtsv); } av_extend(av, AvFILLp(av) + subs_len - 1); for(j = 0; j < subs_len; j++){ SV* const code_ref = newSVsv(validate(*av_fetch(subs, j, TRUE), T_CV)); av_push(av, code_ref); } } modifiers = newAV(); av_extend(modifiers, 3); av_store(modifiers, M_CURRENT, my_build_around_code(aTHX_ code, around)); av_store(modifiers, M_BEFORE, SvREFCNT_inc_simple_NN(before)); av_store(modifiers, M_AROUND, SvREFCNT_inc_simple_NN(around)); av_store(modifiers, M_AFTER, SvREFCNT_inc_simple_NN(after)); modified = newXS(NULL /* anonymous */, XS_Data__Util_modified, __FILE__); mg = sv_magicext((SV*)modified, (SV*)modifiers, PERL_MAGIC_ext, &modified_vtbl, NULL, 0); SvREFCNT_dec((SV*)modifiers); /* refcnt++ in sv_magicext() */ CvXSUBANY(modified).any_ptr = (void*)mg; RETVAL = newRV_noinc((SV*)modified); OUTPUT: RETVAL void subroutine_modifier(code, ...) CV* code PREINIT: /* Usage: subroutine_modifier(code) # check subroutine_modifier(code, property) # get subroutine_modifier(code, property, subs) # set */ MAGIC* mg; AV* modifiers; /* (before, around, after, original, current) */ SV* property; const char* property_pv; PPCODE: mg = mg_find_by_vtbl((SV*)code, &modified_vtbl); if(items == 1){ /* check only */ ST(0) = boolSV(mg); XSRETURN(1); } if(!mg){ my_fail(aTHX_ "a modified subroutine", ST(0) /* ref to code */); } modifiers = (AV*)mg->mg_obj; assert(modifiers); property = my_string(aTHX_ ST(1), "a modifier property"); property_pv = SvPV_nolen_const(property); if(strEQ(property_pv, "before") || strEQ(property_pv, "around") || strEQ(property_pv, "after")){ I32 const idx = strEQ(property_pv, "before") ? M_BEFORE : strEQ(property_pv, "around") ? M_AROUND : M_AFTER; AV* const av = (AV*)*av_fetch(modifiers, idx, FALSE); if(items != 2){ /* add */ I32 i; for(i = 2; i < items; i++){ SV* const code_ref = newSVsv(validate(ST(i), T_CV)); if(idx == M_AFTER){ av_push(av, code_ref); } else{ av_unshift(av, 1); av_store(av, 0, code_ref); } } if(idx == M_AROUND){ AV* const around = (AV*)sv_2mortal((SV*)av_make(items-2, &ST(2))); SV* const current = my_build_around_code(aTHX_ *av_fetch(modifiers, M_CURRENT, FALSE), around ); av_store(modifiers, M_CURRENT, current); } } XPUSHary(AvARRAY(av), 0, AvFILLp(av)+1); } else{ my_fail(aTHX_ "a modifier property", property); } #define mkopt(opt_list, moniker, require_unique, must_be) \ my_mkopt(aTHX_ opt_list, moniker, require_unique, must_be, T_AV) #define mkopt_hash(opt_list, moniker, must_be) \ my_mkopt(aTHX_ opt_list, moniker, TRUE, must_be, T_HV) SV* mkopt(opt_list = UNDEF, moniker = UNDEF, require_unique = FALSE, must_be = UNDEF) SV* opt_list SV* moniker bool require_unique SV* must_be SV* mkopt_hash(opt_list = UNDEF, moniker = UNDEF, must_be = UNDEF) SV* opt_list SV* moniker SV* must_be Data-Util-0.63/example/000755 000765 000024 00000000000 12305724300 014604 5ustar00gfxstaff000000 000000 Data-Util-0.63/inc/000755 000765 000024 00000000000 12305724300 013722 5ustar00gfxstaff000000 000000 Data-Util-0.63/lib/000755 000765 000024 00000000000 12305724277 013734 5ustar00gfxstaff000000 000000 Data-Util-0.63/Makefile.PL000644 000765 000024 00000001237 12040510451 015122 0ustar00gfxstaff000000 000000 use strict; use warnings; use inc::Module::Install 1.06; use Module::Install::XSUtil 0.41; all_from 'lib/Data/Util.pm'; requires 'MRO::Compat' => 0.09 if $] < 5.010_000; test_requires 'Test::More' => 0.62; test_requires 'Test::Exception' => 0.27; test_requires 'Scope::Guard'; test_requires 'Hash::Util::FieldHash::Compat'; author_tests 'xt', 'author/t'; if(want_xs()){ use_xshelper; cc_warnings; cc_define '-DINLINE_STR_EQ'; } else{ requires 'Hash::Util::FieldHash::Compat'; } auto_set_repository; clean_files q{ Data-Util-* *.stackdump *.gcov *.gcda *.gcno *.out nytprof cover_db }; WriteAll check_nmake => 0; Data-Util-0.63/MANIFEST000644 000765 000024 00000004012 12040510472 014276 0ustar00gfxstaff000000 000000 .gitignore .shipit benchmark/Common.pm benchmark/curry_bench.pl benchmark/export_bench.pl benchmark/gen_bench.pl benchmark/get_code_ref_bench.pl benchmark/get_stash_bench.pl benchmark/install_subr_bench.pl benchmark/instance_bench.pl benchmark/invocant_bench.pl benchmark/methext_bench.pl benchmark/mkopt_bench.pl benchmark/modifier_bench.pl benchmark/modify_bench.pl benchmark/number_bench.pl benchmark/ref_bench.pl Changes data-util.h DataUtil.xs example/curry.pl example/export_lexical.pl example/lib/Method/Modifiers.pm example/lib/Sub/Exporter/Lexical.pm example/modifier.pl example/neat.pl example/synopsis.pl inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Repository.pm inc/Module/Install/WriteAll.pm inc/Module/Install/XSUtil.pm lib/Data/Util.pm lib/Data/Util/Curry.pod lib/Data/Util/Error.pm lib/Data/Util/JA.pod lib/Data/Util/PurePerl.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml misc_scalar.c mro_compat.h README str_util.h subs.c t/00_load.t t/01_refs.t t/02_inst.t t/03_gen.t t/04_overloaded.t t/05_get_stash.t t/06_subroutine.t t/08_mgvars.t t/09_paranoia.t t/10_neat.t t/11_fail_handler.t t/12_in_attr_handler.t t/13_optlist.t t/14_uninst_subr.t t/15_curry.t t/16_modify.t t/17_nsclean.t t/18_is_value.t t/19_multiple_modifiers.t t/20_lexical_sub.t t/21_get_code_ref.t t/22_install2.t t/23_largeargs.t t/24_eval_in_modifiers.t t/lib/NSClean.pm t/pp00_load.t t/pp01_refs.t t/pp02_inst.t t/pp03_gen.t t/pp04_overloaded.t t/pp05_get_stash.t t/pp06_subroutine.t t/pp08_mgvars.t t/pp10_neat.t t/pp11_fail_handler.t t/pp12_in_attr_handler.t t/pp13_optlist.t t/pp14_uninst_subr.t t/pp15_curry.t t/pp16_modify.t t/pp17_nsclean.t t/pp18_is_value.t t/pp19_multiple_modifiers.t t/pp20_lexical_sub.t t/pp21_get_code_ref.t t/pp22_install2.t t/pp23_largeargs.t t/pp24_eval_in_modifiers.t typemap xshelper.h xt/01_pod.t xt/02_pod-coverage.t xt/03_synopsis.t xt/07_threads.t xt/pp07_threads.t Data-Util-0.63/MANIFEST.SKIP000644 000765 000024 00000002122 12040510404 015036 0ustar00gfxstaff000000 000000 #!start included /Users/fuji.goro/perl5/perlbrew/perls/perl-5.14.0/lib/site_perl/5.14.0/ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \b_darcs\b \B\.cvsignore$ # Avoid VMS specific MakeMaker generated files \bDescrip.MMS$ \bDESCRIP.MMS$ \bdescrip.mms$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid MYMETA files ^MYMETA\. #!end included /Users/fuji.goro/perl5/perlbrew/perls/perl-5.14.0/lib/site_perl/5.14.0/ExtUtils/MANIFEST.SKIP \bauthor\b \.git/ \bDataUtil\.c$ \.o(?:ut)?$ \.bs$ ^ppport\.h$ \.stadkcump$ Data-Util-0.63/META.yml000644 000765 000024 00000001476 12305724277 014447 0ustar00gfxstaff000000 000000 --- abstract: 'A selection of utilities for data and data types' author: - 'Goro Fuji(gfx) .' build_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.59 Hash::Util::FieldHash::Compat: 0 Scope::Guard: 0 Test::Exception: 0.27 Test::More: 0.62 configure_requires: Devel::PPPort: 3.19 ExtUtils::MakeMaker: 6.59 ExtUtils::ParseXS: 3.18 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: Data::Util name: Data-Util no_index: directory: - example - inc - t - xt requires: XSLoader: 0.02 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/gfx/Perl-Data-Util.git version: 0.63 Data-Util-0.63/misc_scalar.c000644 000765 000024 00000005036 12040510404 015573 0ustar00gfxstaff000000 000000 /* neat.c */ #include "data-util.h" #define PV_LIMIT 20 static int is_identifier_cstr(const char* pv, const STRLEN len){ if(isIDFIRST(*pv)){ const char* const end = pv + len - 1 /* '\0' */; while(pv != end){ ++pv; if(!isALNUM(*pv)){ return FALSE; } } return TRUE; } return FALSE; } static void du_neat_cat(pTHX_ SV* const dsv, SV* x, const int level){ if(level > 2){ sv_catpvs(dsv, "..."); return; } if(SvRXOK(x)){ /* regex */ Perl_sv_catpvf(aTHX_ dsv, "qr{%"SVf"}", x); return; } else if(SvROK(x)){ x = SvRV(x); if(SvOBJECT(x)){ Perl_sv_catpvf(aTHX_ dsv, "%s=%s(0x%p)", sv_reftype(x, TRUE), sv_reftype(x, FALSE), x); return; } else if(SvTYPE(x) == SVt_PVAV){ I32 const len = av_len((AV*)x); sv_catpvs(dsv, "["); if(len >= 0){ SV** const svp = av_fetch((AV*)x, 0, FALSE); if(*svp){ du_neat_cat(aTHX_ dsv, *svp, level+1); } else{ sv_catpvs(dsv, "undef"); } if(len > 0){ sv_catpvs(dsv, ", ..."); } } sv_catpvs(dsv, "]"); } else if(SvTYPE(x) == SVt_PVHV){ I32 klen; char* key; SV* val; hv_iterinit((HV*)x); val = hv_iternextsv((HV*)x, &key, &klen); sv_catpvs(dsv, "{"); if(val){ if(!is_identifier_cstr(key, klen)){ SV* const sv = sv_newmortal(); key = pv_display(sv, key, klen, klen, PV_LIMIT); } Perl_sv_catpvf(aTHX_ dsv, "%s => ", key); du_neat_cat(aTHX_ dsv, val, level+1); if(hv_iternext((HV*)x)){ sv_catpvs(dsv, ", ..."); } } sv_catpvs(dsv, "}"); } else if(SvTYPE(x) == SVt_PVCV){ GV* const gv = CvGV((CV*)x); Perl_sv_catpvf(aTHX_ dsv, "\\&%s::%s(0x%p)", HvNAME(GvSTASH(gv)), GvNAME(gv), x); } else{ sv_catpvs(dsv, "\\"); du_neat_cat(aTHX_ dsv, x, level+1); } } else if(isGV(x)){ sv_catsv(dsv, x); } else if(SvOK(x)){ if(SvPOKp(x)){ STRLEN cur; char* const pv = SvPV(x, cur); /* pv_sisplay requires char*, not const char* */ SV* const sv = sv_newmortal(); pv_display(sv, pv, cur, cur, PV_LIMIT); sv_catsv(dsv, sv); } else{ NV const nv = SvNV(x); if(nv == NV_INF){ sv_catpvs(dsv, "+Inf"); } else if(nv == -NV_INF){ sv_catpvs(dsv, "-Inf"); } else if(Perl_isnan(nv)){ sv_catpvs(dsv, "NaN"); } else{ Perl_sv_catpvf(aTHX_ dsv, "%"NVgf, nv); } } } else{ sv_catpvs(dsv, "undef"); } } const char* du_neat(pTHX_ SV* x){ SV* const dsv = newSV(100); sv_2mortal(dsv); sv_setpvs(dsv, ""); ENTER; SAVETMPS; SvGETMAGIC(x); du_neat_cat(aTHX_ dsv, x, 0); FREETMPS; LEAVE; return SvPVX(dsv); } Data-Util-0.63/mro_compat.h000644 000765 000024 00000006240 12040510404 015456 0ustar00gfxstaff000000 000000 /* ---------------------------------------------------------------------------- mro_compat.h - Provides mro functions for XS Automatically created by Devel::MRO/0.01, running under perl 5.10.0 Copyright (c) 2008, Goro Fuji . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. ---------------------------------------------------------------------------- Usage: #include "mro_compat.h" Functions: AV* mro_get_linear_isa(HV* stash) UV mro_get_pkg_gen(HV* stash) void mro_method_changed_in(HV* stash) See "perldoc mro" for details. */ #ifndef mro_get_linear_isa #define mro_get_linear_isa(stash) my_mro_get_linear_isa(aTHX_ stash) #define mro_method_changed_in(stash) ((void)stash, (void)PL_sub_generation++) #define mro_get_pkg_gen(stash) ((void)stash, PL_sub_generation) #if defined(NEED_mro_get_linear_isa) && !defined(NEED_mro_get_linear_isa_GLOBAL) static AV* my_mro_get_linear_isa(pTHX_ HV* const stash); static #else extern AV* my_mro_get_linear_isa(pTHX_ HV* const stash); #endif /* !NEED_mro_get_linear_isa */ #if defined(NEED_mro_get_linear_isa) || defined(NEED_mro_get_linear_isa_GLOBAL) #define ISA_CACHE "::LINEALIZED_ISA_CACHE::" AV* my_mro_get_linear_isa(pTHX_ HV* const stash){ GV* const cachegv = *(GV**)hv_fetchs(stash, ISA_CACHE, TRUE); AV* isa; SV* gen; CV* get_linear_isa; if(!isGV(cachegv)) gv_init(cachegv, stash, ISA_CACHE, sizeof(ISA_CACHE)-1, TRUE); isa = GvAVn(cachegv); #ifdef GvSVn gen = GvSVn(cachegv); #else gen = GvSV(cachegv); #endif if(SvIOK(gen) && SvIVX(gen) == (IV)mro_get_pkg_gen(stash)){ return isa; /* returns the cache if available */ } else{ SvREADONLY_off(isa); av_clear(isa); } get_linear_isa = get_cv("mro::get_linear_isa", FALSE); if(!get_linear_isa){ ENTER; SAVETMPS; Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("MRO::Compat"), NULL, NULL); get_linear_isa = get_cv("mro::get_linear_isa", TRUE); FREETMPS; LEAVE; } { SV* avref; dSP; ENTER; SAVETMPS; PUSHMARK(SP); mXPUSHp(HvNAME(stash), strlen(HvNAME(stash))); PUTBACK; call_sv((SV*)get_linear_isa, G_SCALAR); SPAGAIN; avref = POPs; PUTBACK; if(SvROK(avref) && SvTYPE(SvRV(avref)) == SVt_PVAV){ AV* const av = (AV*)SvRV(avref); I32 const len = AvFILLp(av) + 1; I32 i; for(i = 0; i < len; i++){ HV* const stash = gv_stashsv(AvARRAY(av)[i], FALSE); if(stash) av_push(isa, newSVpv(HvNAME(stash), 0)); } SvREADONLY_on(isa); } else{ Perl_croak(aTHX_ "mro::get_linear_isa() didn't return an ARRAY reference"); } FREETMPS; LEAVE; } sv_setiv(gen, (IV)mro_get_pkg_gen(stash)); return GvAV(cachegv); } #undef ISA_CACHE #endif /* !(defined(NEED_mro_get_linear_isa) || defined(NEED_mro_get_linear_isa_GLOBAL)) */ #else /* !mro_get_linear_isa */ /* NOTE: Because ActivePerl 5.10.0 does not provide Perl_mro_meta_init(), which is used in HvMROMETA() macro, this mro_get_pkg_gen() refers to xhv_mro_meta directly. */ #ifndef mro_get_pkg_gen #define mro_get_pkg_gen(stash) (HvAUX(stash)->xhv_mro_meta ? HvAUX(stash)->xhv_mro_meta->pkg_gen : (U32)0) #endif #endif /* mro_get_linear_isa */ Data-Util-0.63/README000644 000765 000024 00000001461 12040510404 014025 0ustar00gfxstaff000000 000000 NAME Data::Util - A selection of utilities for data and data types SYNOPSIS use Data::Util qw(:all); if(is_instance($obj, 'SomeClass')){ # ... } Or, try "perl -Mblib example/synopsis.pl" after "make test". DESCRIPTION This module provides utilities for data and data types. See "perldoc Data::Util" for the rest of the document. BENCHMARKS There are benchmarks in "benchmark/" directory, e.g. try "perl -Mblib example/inst_bench.pl" after "make test". DEPENDENCIES perl 5.8.1 or later. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install COPYRIGHT AND LICENCE Copyright (c) 2008 Goro Fuji, Some rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Data-Util-0.63/str_util.h000644 000765 000024 00000001106 12040510404 015157 0ustar00gfxstaff000000 000000 #ifndef SCALAR_UTIL_REF_STR_UTIL_H #define SCALAR_UTIL_REF_STR_UTIL_H #ifdef INLINE_STR_EQ #undef strnEQ STATIC_INLINE int strnEQ(const char* const x, const char* const y, size_t const n){ size_t i; for(i = 0; i < n; i++){ if(x[i] != y[i]){ return FALSE; } } return TRUE; } #undef strEQ STATIC_INLINE int strEQ(const char* const x, const char* const y){ size_t i; for(i = 0; ; i++){ if(x[i] != y[i]){ return FALSE; } else if(x[i] == '\0'){ return TRUE; /* y[i] is also '\0' */ } } return TRUE; /* not reached */ } #endif /* !INLINE_STR_EQ */ #endif Data-Util-0.63/subs.c000644 000765 000024 00000014427 12305724031 014302 0ustar00gfxstaff000000 000000 /* Data-Util/subs.c XS code templates for curry() and modify_subroutine() */ #include "data-util.h" MGVTBL curried_vtbl; MGVTBL modified_vtbl; MAGIC* my_mg_find_by_vtbl(pTHX_ SV* const sv, const MGVTBL* const vtbl){ MAGIC* mg; for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){ if(mg->mg_virtual == vtbl){ break; } } return mg; } XS(XS_Data__Util_curried){ dVAR; dXSARGS; MAGIC* const mg = (MAGIC*)XSANY.any_ptr; // mg_find_by_vtbl((SV*)cv, &curried_vtbl); assert(mg); SP -= items; /* NOTE: Curried subroutines have two properties, "params" and "phs"(placeholders). Geven a curried subr created by "curry(\&f, $x, *_, $y, \0)": params: [ $x, undef, $y, undef] phs: [undef, *_, undef, 0] Here the curried subr is called with arguments. Firstly, the arguments are set to params, expanding subscriptive placeholders, but the placeholder "*_" is set to the end of params. params: [ $x, undef, $y, $_[0], @_ ] Then, params are pushed into SP, expanding "*_". SP: [ $x, @_[1..$#_], $y, $_[0] ] Finally, params are cleand up. params: [ $x, undef, $y, undef ] */ { AV* const params = (AV*)mg->mg_obj; SV** params_ary = AvARRAY(params); I32 const len = AvFILLp(params) + 1; AV* const phs = (AV*)mg->mg_ptr; /* placeholders */ SV**const phs_ary = AvARRAY(phs); I32 max_ph = -1; /* max placeholder index */ I32 min_ph = items; /* min placeholder index */ SV** sph = NULL; // indicates *_ U16 const is_method = mg->mg_private; /* G_METHOD */ I32 push_size = len - 1; /* -1: proc */ register I32 i; SV* proc; /* fill in params */ for(i = 0; i < len; i++){ SV* const ph = phs_ary[i]; if (!ph){ continue; } if(isGV(ph)){ /* symbolic placeholder *_ */ if(!sph){ I32 j; if(AvMAX(params) < (len + items)){ av_extend(params, len + items); params_ary = AvARRAY(params); /* maybe realloc()-ed */ } /* All the arguments @_ is pushed into the end of params, not calling SvREFCNT_inc(). */ sph = ¶ms_ary[len]; for(j = 0; j < items; j++){ /* NOTE: no need to SvREFCNT_inc(ST(j)), * bacause AvFILLp(params) remains len-1. * That's okey. */ sph[j] = ST(j); } } push_size += items; } else if(SvIOKp(ph)){ /* subscriptive placeholders */ IV p = SvIVX(ph); if(p >= 0){ if(p > max_ph) max_ph = p; } else{ /* negative index */ p += items; if(p < 0){ Perl_croak(aTHX_ PL_no_aelem, (int)p); } if(p < min_ph) min_ph = p; } if(p <= items){ /* NOTE: no need to SvREFCNT_inc(params_ary[i]), * because it removed from params_ary before call_sv() */ params_ary[i] = ST(p); } } } PUSHMARK(SP); EXTEND(SP, push_size); if(is_method){ PUSHs( params_ary[0] ); /* invocant */ proc = params_ary[1]; /* method */ i = 2; } else{ proc = params_ary[0]; /* code ref */ i = 1; } for(/* i is initialized above */; i < len; i++){ if(phs_ary[i] && isGV(phs_ary[i])){ /* warn("#sph %d - %d", (int)max_ph+1, (int)min_ph); //*/ PUSHary(sph, max_ph + 1, min_ph); } else{ PUSHs(params_ary[i]); } } PUTBACK; /* NOTE: need to clean up params before call_sv(), because call_sv() might die */ for(i = 0; i < len; i++){ if(phs_ary[i] && SvIOKp(phs_ary[i])){ /* NOTE: no need to SvREFCNT_dec(params_ary[i]) */ params_ary[i] = &PL_sv_undef; } } /* G_EVAL to workaround RT #69939 */ call_sv(proc, GIMME_V | is_method | G_EVAL); if(SvTRUEx(ERRSV)){ croak(NULL); /* rethrow */ } } } /* call an av of cv with args_ary */ static void my_call_av(pTHX_ AV* const subs, SV** const args_ary, I32 const args_len){ I32 const subs_len = AvFILLp(subs) + 1; I32 i; for(i = 0; i < subs_len; i++){ dSP; PUSHMARK(SP); XPUSHary(args_ary, 0, args_len); PUTBACK; /* G_EVAL to workaround RT #69939 */ call_sv(AvARRAY(subs)[i], G_VOID | G_DISCARD | G_EVAL); if(SvTRUEx(ERRSV)){ croak(NULL); } } } XS(XS_Data__Util_modified){ dVAR; dXSARGS; MAGIC* const mg = (MAGIC*)XSANY.any_ptr; // mg_find_by_vtbl((SV*)cv, &modified_vtbl); assert(mg); SP -= items; { AV* const subs_av = (AV*)mg->mg_obj; AV* const before = (AV*)AvARRAY(subs_av)[M_BEFORE]; SV* const current = (SV*)AvARRAY(subs_av)[M_CURRENT]; AV* const after = (AV*)AvARRAY(subs_av)[M_AFTER]; I32 i; dXSTARG; AV* const args = (AV*)TARG; SV** args_ary; (void)SvUPGRADE(TARG, SVt_PVAV); if(AvMAX(args) < items){ av_extend(args, items); } args_ary = AvARRAY(args); for(i = 0; i < items; i++){ args_ary[i] = ST(i); /* no need to SvREFCNT_inc() */ } PUTBACK; my_call_av(aTHX_ before, args_ary, items); SPAGAIN; PUSHMARK(SP); XPUSHary(args_ary, 0, items); PUTBACK; call_sv(current, GIMME_V); my_call_av(aTHX_ after, args_ary, items); } /* no need to XSRETURN(n) */ } Data-Util-0.63/t/000755 000765 000024 00000000000 12305724300 013414 5ustar00gfxstaff000000 000000 Data-Util-0.63/typemap000644 000765 000024 00000000231 12040510404 014541 0ustar00gfxstaff000000 000000 ### AV* T_AVREF HV* T_HVREF CV* T_CVREF ### INPUT T_AVREF $var = deref_av($arg); T_HVREF $var = deref_hv($arg); T_CVREF $var = deref_cv($arg); Data-Util-0.63/xshelper.h000644 000765 000024 00000004532 12305724277 015175 0ustar00gfxstaff000000 000000 /* THIS FILE IS AUTOMATICALLY GENERATED BY Module::Install::XSUtil 0.45. */ /* =head1 NAME xshelper.h - Helper C header file for XS modules =head1 DESCRIPTION // This includes all the perl header files and ppport.h #include "xshelper.h" =head1 SEE ALSO L, where this file is distributed as a part of =head1 AUTHOR Fuji, Goro (gfx) Egfuji at cpan.orgE =head1 LISENCE Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut */ #ifdef __cplusplus extern "C" { #endif #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include #include #define NO_XSLOCKS /* for exceptions */ #include #ifdef __cplusplus } /* extern "C" */ #endif #include "ppport.h" /* portability stuff not supported by ppport.h yet */ #ifndef STATIC_INLINE /* from 5.13.4 */ # if defined(__GNUC__) || defined(__cplusplus) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) # define STATIC_INLINE static inline # else # define STATIC_INLINE static # endif #endif /* STATIC_INLINE */ #ifndef __attribute__format__ #define __attribute__format__(a,b,c) /* nothing */ #endif #ifndef LIKELY /* they are just a compiler's hint */ #define LIKELY(x) (!!(x)) #define UNLIKELY(x) (!!(x)) #endif #ifndef newSVpvs_share #define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) #endif #ifndef get_cvs #define get_cvs(name, flags) get_cv(name, flags) #endif #ifndef GvNAME_get #define GvNAME_get GvNAME #endif #ifndef GvNAMELEN_get #define GvNAMELEN_get GvNAMELEN #endif #ifndef CvGV_set #define CvGV_set(cv, gv) (CvGV(cv) = (gv)) #endif /* general utility */ #if PERL_BCDVERSION >= 0x5008005 #define LooksLikeNumber(x) looks_like_number(x) #else #define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) #endif #define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) #define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) #define newRV_inc_mortal(sv) sv_2mortal(newRV_inc(sv)) #define newRV_noinc_mortal(sv) sv_2mortal(newRV_noinc(sv)) #define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) #define CALL_BOOT(name) STMT_START { \ PUSHMARK(SP); \ CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ } STMT_END Data-Util-0.63/xt/000755 000765 000024 00000000000 12305724300 013604 5ustar00gfxstaff000000 000000 Data-Util-0.63/xt/01_pod.t000644 000765 000024 00000000214 12040510404 015042 0ustar00gfxstaff000000 000000 #!perl -w use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Data-Util-0.63/xt/02_pod-coverage.t000644 000765 000024 00000000464 12040510404 016643 0ustar00gfxstaff000000 000000 #!perl -w use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; local $SIG{__WARN__} = sub{ 1 }; # not to concern about 'redefine' warnings all_pod_coverage_ok({ also_private => [qw(unimport regex_ref is_regex_ref)], }); Data-Util-0.63/xt/03_synopsis.t000644 000765 000024 00000000223 12040510404 016151 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More; eval q{use Test::Synopsis}; plan skip_all => 'Test::Synopsis required for testing' if $@; all_synopsis_ok(); Data-Util-0.63/xt/07_threads.t000644 000765 000024 00000002606 12040510404 015727 0ustar00gfxstaff000000 000000 #!perl -w use strict; use constant HAS_THREADS => eval{ require threads }; use Test::More; BEGIN{ if($INC{'Devel/Cover.pm'}){ plan skip_all => '(under -d:Cover)'; } if(HAS_THREADS){ plan tests => 17; } else{ plan skip_all => 'requires threads'; } } use threads; use threads 'yield'; use threads::shared; use Data::Util qw(:all); BEGIN{ package Foo; sub new{ bless {} => shift; } package Bar; our @ISA = qw(Foo); package Baz; sub new{ bless [] => shift; } } { ok is_instance(Foo->new, 'Foo'), 'in the main thread'; ok is_instance(Bar->new, 'Foo'); ok !is_instance(Baz->new, 'Foo'); } my $thr1 = async{ yield; ok is_instance(Foo->new, 'Foo'), 'in a thread (1)'; yield; ok is_instance(Bar->new, 'Foo'); yield; ok !is_instance(Baz->new, 'Foo'); eval{ instance(Foo->new, 'Bar'); }; like $@, qr/Validation failed/; return 1; }; my $thr2 = async{ yield; ok is_instance(Foo->new, 'Foo'), 'in a thread (2)'; yield; ok is_instance(Bar->new, 'Foo'); yield; ok !is_instance(Baz->new, 'Foo'); eval{ instance(Foo->new, 'Bar'); }; like $@, qr/Validation failed/; return 1; }; { ok is_instance(Foo->new, 'Foo'), 'in the main thread'; ok is_instance(Bar->new, 'Foo'); ok !is_instance(Baz->new, 'Foo'); eval { instance(Foo->new, 'Bar'); }; like $@, qr/Validation failed/; } ok $thr2->join(), 'join a thread (2)'; ok $thr1->join(), 'join a thread (1)'; Data-Util-0.63/xt/pp07_threads.t000644 000765 000024 00000000226 12040510404 016263 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/00_load.t000644 000765 000024 00000000314 12040510404 015007 0ustar00gfxstaff000000 000000 #!perl -wT use Test::More tests => 1; BEGIN { use_ok( 'Data::Util' ); } my $backend = $Data::Util::TESTING_PERL_ONLY ? 'PurePerl' : 'XS'; diag( "Testing Data::Util $Data::Util::VERSION ($backend)" ); Data-Util-0.63/t/01_refs.t000644 000765 000024 00000004574 12040510404 015044 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 47; use Test::Exception; use Data::Util qw(:check :validate); use Symbol qw(gensym); use constant PP_ONLY => exists $INC{'Data/Util/PurePerl.pm'}; diag "Testing ", PP_ONLY ? "PurePerl" : "XS"; sub lval_f :lvalue{ my $f; } ok is_scalar_ref(\''), 'is_scalar_ref'; ok is_scalar_ref(\lval_f()), 'is_scalar_ref (lvalue)'; ok is_scalar_ref(\\''), 'is_scalar_ref (ref)'; ok!is_scalar_ref(bless \do{my$o}), 'is_scalar_ref'; ok!is_scalar_ref({}), 'is_scalar_ref'; ok!is_scalar_ref(undef), 'is_scalar_ref'; ok!is_scalar_ref(*STDOUT{IO}), 'is_scalar_ref'; ok is_array_ref([]), 'is_array_ref'; ok!is_array_ref(bless []), 'is_array_ref'; ok!is_array_ref({}), 'is_array_ref'; ok!is_array_ref(undef), 'is_array_ref'; ok is_hash_ref({}), 'is_hash_ref'; ok!is_hash_ref(bless {}), 'is_hash_ref'; ok!is_hash_ref([]), 'is_hash_ref'; ok!is_hash_ref(undef), 'is_hash_ref'; ok is_code_ref(sub{}), 'is_code_ref'; ok!is_code_ref(bless sub{}), 'is_code_ref'; ok!is_code_ref({}), 'is_code_ref'; ok!is_code_ref(undef), 'is_code_ref'; ok is_glob_ref(gensym()), 'is_glob_ref'; ok!is_glob_ref(bless gensym()), 'is_glob_ref'; ok!is_glob_ref({}), 'is_glob_ref'; ok!is_glob_ref(undef), 'is_glob_ref'; ok is_regex_ref(qr/foo/), 'is_regex_ref'; ok!is_regex_ref({}), 'is_regex_ref'; ok is_rx(qr/foo/), 'is_rx'; ok!is_rx({}), 'is_rx'; SKIP:{ skip 'in testing perl only', 1 if PP_ONLY; ok!is_regex_ref(bless [], 'Regexp'), 'fake regexp'; } ok scalar_ref(\42), 'scalar_ref'; ok scalar_ref(\\42); throws_ok{ scalar_ref([]); } qr/Validation failed: you must supply a SCALAR reference/; throws_ok{ scalar_ref(undef); } qr/Validation failed/; throws_ok{ scalar_ref(42); } qr/Validation failed/; throws_ok{ scalar_ref('SCALAR'); } qr/Validation failed/; throws_ok{ scalar_ref(\*ok); } qr/Validation failed/; ok array_ref([]), 'array_ref'; throws_ok{ array_ref({foo => "bar"}); } qr/Validation failed/; ok hash_ref({}), 'hash_ref'; throws_ok{ hash_ref([]); } qr/Validation failed/; ok code_ref(sub{}), 'code_ref'; throws_ok{ code_ref([]); } qr/Validation failed/; ok glob_ref(gensym()), 'glob_ref'; throws_ok{ glob_ref('*glob'); } qr/Validation failed/; ok rx(qr/foo/), 'rx'; throws_ok{ rx([]); } qr/Validation failed/; SKIP:{ skip 'in testing perl only', 2 if PP_ONLY; dies_ok{ is_scalar_ref(); } 'not enough arguments'; dies_ok{ scalar_ref(); } 'not enought arguments'; } Data-Util-0.63/t/02_inst.t000644 000765 000024 00000004225 12040510404 015054 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 33; use Test::Exception; use Data::Util qw(is_instance instance); BEGIN{ package Foo; sub new{ bless {}, shift } package Bar; our @ISA = qw(Foo); package Foo_or_Bar; our @ISA = qw(Foo); package Baz; sub new{ bless {}, shift } sub isa{ my($x, $y) = @_; return $y eq 'Foo'; } package Broken; sub isa; # pre-declaration only package AL; sub new{ bless {}, shift } sub DESTROY{} sub isa; sub AUTOLOAD{ #our $AUTOLOAD; ::diag "$AUTOLOAD(@_)"; 1; } package AL_stubonly; sub new{ bless{}, shift; } sub DESTROY{}; sub isa; sub AUTOLOAD; } ok is_instance(Foo->new, 'Foo'), 'is_instance'; ok !is_instance(Foo->new, 'Bar'); ok is_instance(Foo->new, 'UNIVERSAL'), 'is_instance of UNIVERSAL'; ok is_instance(Bar->new, 'Foo'); ok is_instance(Bar->new, 'Bar'); ok is_instance(Baz->new, 'Foo'); ok !is_instance(Baz->new, 'Bar'); ok !is_instance(Baz->new, 'Baz'); ok is_instance(Foo_or_Bar->new, 'Foo'); ok!is_instance(Foo_or_Bar->new, 'Bar'); @Foo_or_Bar::ISA = qw(Bar); ok is_instance(Foo_or_Bar->new, 'Bar'), 'ISA changed dynamically'; # no object reference ok !is_instance('Foo', 'Foo'); ok !is_instance({}, 'Foo'); ok !is_instance({}, 'HASH'); dies_ok{ is_instance(Broken->new(), 'Broken') }; ok is_instance(AL->new, 'AL'); ok is_instance(AL->new, 'Foo'); dies_ok { is_instance(AL_stubonly->new, 'AL') }; isa_ok instance(Foo->new, 'Foo'), 'Foo', 'instance'; isa_ok instance(Bar->new, 'Foo'), 'Foo'; dies_ok{ instance(undef, 'Foo') }; dies_ok{ instance(1, 'Foo') }; dies_ok{ instance('', 'Foo') }; dies_ok{ instance({}, 'Foo') }; dies_ok{ instance(Foo->new, 'Bar') }; # error dies_ok{ is_instance('Foo', Foo->new()) } 'illigal argument order'; dies_ok{ is_instance([], []) } 'illigal use'; dies_ok{ is_instance() } 'not enough argument'; dies_ok{ is_instance([], undef) } 'uninitialized class'; dies_ok{ instance('Foo', Foo->new()) } 'illigal argument order'; dies_ok{ instance([], []) } 'illigal use'; dies_ok{ instance() } 'not enough argument'; dies_ok{ instance([], undef) } 'uninitialized class'; Data-Util-0.63/t/03_gen.t000644 000765 000024 00000000767 12040510404 014660 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests =>7; use Data::Util qw(anon_scalar); my $sref = \do{ my $anon }; is_deeply anon_scalar(), $sref, 'anon_scalar'; is_deeply anon_scalar(undef), $sref, 'anon_scalar'; is_deeply anon_scalar(10), \10; is_deeply anon_scalar('foo'), \'foo'; ok !Internals::SvREADONLY(${ anon_scalar(10) }), 'not readonly'; my $foo; # equivalent to "$foo = \do{ my $tmp = $foo }" $foo = anon_scalar $foo; is_deeply $foo, $sref; ok eval{ ${anon_scalar()} = 10; }, 'writable'; Data-Util-0.63/t/04_overloaded.t000644 000765 000024 00000003252 12040510404 016224 0ustar00gfxstaff000000 000000 #!perl-w use strict; use Test::More tests => 36; use Test::Exception; use Data::Util qw(:all); BEGIN{ package Foo; use overload fallback => 1; sub new{ bless {} => shift; } package MyArray; use overload '@{}' => 'as_array', fallback => 1; sub new{ bless {array => []} => shift; } sub as_array{ shift()->{array}; } package AnyRef; use overload '@{}' => 'as_array', '%{}' => 'as_hash', '${}' => 'as_scalar', '*{}' => 'as_glob', '&{}' => 'as_code', fallback => 1; my $s; my @a; my %h; my $gref; select select $gref; sub c{1} sub new{ bless {} => shift; } sub as_scalar{ \$s; } sub as_array{ \@a; } sub as_hash{ \%h; } sub as_glob{ $gref; } sub as_code{ \&c; } package DerivedAnyRef; our @ISA = qw(AnyRef); } # :check my $foo = Foo->new(); ok !is_array_ref($foo), 'check with overloaded'; ok !is_hash_ref($foo); my $ma = MyArray->new(); ok is_array_ref($ma); ok !is_hash_ref($ma); ok !is_scalar_ref($ma); ok !is_code_ref($ma); ok !is_glob_ref($ma); ok !is_regex_ref($ma); for my $ref(AnyRef->new(), DerivedAnyRef->new()){ ok is_array_ref($ref); ok is_hash_ref($ref); ok is_scalar_ref($ref); ok is_code_ref($ref); ok is_glob_ref($ref); } # :validate $foo = Foo->new(); dies_ok{ array_ref($foo); } 'validate with overloaded'; dies_ok{ hash_ref($foo); }; $ma = MyArray->new(); lives_and{ ok array_ref($ma); }; dies_ok{ hash_ref($ma) }; dies_ok{ scalar_ref($ma) }; dies_ok{ code_ref($ma) }; dies_ok{ glob_ref($ma) }; dies_ok{ regex_ref($ma) }; for my $ref(AnyRef->new(), DerivedAnyRef->new()){ lives_and{ ok array_ref($ref); ok hash_ref($ref); ok scalar_ref($ref); ok code_ref($ref); ok glob_ref($ref); }; } Data-Util-0.63/t/05_get_stash.t000644 000765 000024 00000002400 12040510404 016054 0ustar00gfxstaff000000 000000 #!perl -w # get_stash(), is_invocant(), invocant() use strict; use warnings FATAL => 'all'; use Test::More tests => 40; use Test::Exception; use Tie::Scalar; use Scalar::Util qw(blessed); use Data::Util qw(:all); #diag 'Testing ', $INC{'Data/Util/PurePerl.pm'} ? 'PurePerl' : 'XS'; sub get_stash_pp{ my($pkg) = @_; no strict 'refs'; if(blessed $pkg){ $pkg = ref $pkg; } return \%{$pkg . '::'}; } foreach my $pkg( qw(main strict Data::Util ::main::Data::Util), bless{}, 'Foo'){ is get_stash($pkg), get_stash_pp($pkg), sprintf 'get_stash(%s)', neat $pkg; ok is_invocant($pkg), 'is_invocant()'; ok invocant($pkg)->isa('UNIVERSAL'), 'invocant()'; } foreach my $pkg('not_exists', '', 1, undef, [], *ok){ ok !defined(get_stash $pkg), 'get_stash for ' . neat($pkg) . '(invalid value)'; ok !is_invocant($pkg), '!is_invocant()'; throws_ok{ invocant($pkg); } qr/Validation failed/, 'invocant() throws fatal error'; } my $x = tie my($ts), 'Tie::StdScalar', 'main'; is get_stash($ts), get_stash_pp('main'), 'for magic variable'; ok is_invocant($ts); ok invocant($ts); ok is_invocant($x), 'is_invocant() for an object'; is invocant($x), $x, 'invocant() for an object'; is invocant('::Data::Util'), 'Data::Util'; is invocant('main::Data::Util'), 'Data::Util'; Data-Util-0.63/t/06_subroutine.t000644 000765 000024 00000006133 12040510404 016302 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests =>32; use Test::Exception; use Data::Util qw(:all); use constant PP_ONLY => $INC{'Data/Util/PurePerl.pm'}; sub get_subname{ return scalar get_code_info(@_); } sub foo{ 42; } sub bar{ 52; } { package Base; sub foo{ 'Base::foo'; } package Foo; our @ISA = qw(Base); use Data::Util qw(install_subroutine); sub baz{} package Callable; use overload '&{}' => 'codify', ; sub new{ my $class = shift; bless {@_} => $class; } sub codify{ my $self = shift; $self->{code}; } } is_deeply get_subname(\&foo), 'main::foo', 'get_code_info()'; is_deeply [get_code_info(\&foo)], [qw(main foo)]; is_deeply get_subname(\&Foo::baz), 'Foo::baz', 'get_code_info()'; is_deeply [get_code_info(\&Foo::baz)], [qw(Foo baz)]; is_deeply get_subname(\&undefined_subr), 'main::undefined_subr'; is_deeply [get_code_info(\&undefined_subr)], [qw(main undefined_subr)]; no warnings 'redefine'; Foo->foo(); # touch the chache Foo->install_subroutine(foo => \&foo); is Foo::foo(), foo(), 'as function'; is(Foo->foo(), foo(), 'as method'); Foo->install_subroutine(foo => \&bar); is Foo::foo(), bar(), 'redefined'; Foo->install_subroutine(foo => sub{ 314 }); is Foo::foo(), 314, 'install anonymous subr'; SKIP:{ skip 'in testing perl only', 1 if PP_ONLY; is get_subname(\&Foo::foo), 'Foo::foo', '...named'; } Foo->install_subroutine(foo => \&foo); is Foo::foo(), foo(); SKIP:{ skip 'in testing perl only', 1 if PP_ONLY; is get_subname(\&Foo::foo), 'main::foo'; } { my $count = 0; Foo->install_subroutine(foo => sub{ ++$count }); } is Foo::foo(), 1, 'install closure'; is Foo::foo(), 2; SKIP:{ skip 'in testing perl only', 2 if PP_ONLY; Foo->install_subroutine(foo => sub{}); is get_subname(\&Foo::foo), 'Foo::foo', 'name an anonymous subr'; Foo->install_subroutine(bar => \&Foo::foo); is get_subname(\&Foo::bar), 'Foo::foo', 'does not name a named subr'; } # exception Foo->install_subroutine(foo => \&undefined_subr); dies_ok{ Foo->foo(); } 'install undefined subroutine'; Foo->install_subroutine(ov1 => Callable->new(code => sub{ 'overloaded' })); is Foo::ov1(), 'overloaded', 'overload'; Foo->install_subroutine(ov2 => Callable->new(code => sub{ die 'dies in codify' })); throws_ok{ Foo::ov2(); } qr/dies in codify/; dies_ok{ Foo->install_subroutine(ov3 => Callable->new(code => [])); }; dies_ok{ Foo->install_subroutine(ov4 => Callable->new(code => undef)); }; use warnings FATAL => 'redefine'; throws_ok{ get_code_info(undef); } qr/CODE reference/; throws_ok{ install_subroutine(); } qr/^Usage: /; dies_ok{ Foo->install_subroutine('foo'); }; throws_ok{ Data::Util::install_subroutine(undef, foo => \&foo); } qr/package name/; throws_ok{ Foo->install_subroutine(PI => 3.14); } qr/CODE reference/; throws_ok{ Foo->install_subroutine(undef, sub{}); } qr/\b name\b /xms; throws_ok{ Foo->install_subroutine([], sub{}); } qr/\b name\b /xms; # multiple installation install_subroutine(__PACKAGE__, f1 => sub{ 1 }, f2 => sub{ 2 }, f3 => sub{ 3 }); is f1(), 1, 'multiple installation(1)'; is f2(), 2, 'multiple installation(2)'; is f3(), 3, 'multiple installation(3)';; Data-Util-0.63/t/08_mgvars.t000644 000765 000024 00000001305 12040510404 015400 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 12; use Tie::Scalar; use Tie::Array; use Tie::Hash; use Data::Util qw(:check); BEGIN{ package Foo; sub new{ bless {} => shift; } } tie my($x), 'Tie::StdScalar', []; $x = []; ok is_array_ref($x); ok!is_hash_ref($x); $x = ''; ok is_scalar_ref(\$x); ok!is_array_ref($x); $x = Foo->new(); tie my($class), 'Tie::StdScalar', 'Foo'; ok!is_hash_ref($x); ok is_instance($x, $class); $class = 'Bar'; ok!is_instance($x, $class); $x = undef; ok!is_instance($x, $class); $x = {}; ok!is_instance($x, $class); $x = ''; ok!is_instance($x, $class); tie my(@arr), 'Tie::StdArray'; ok is_array_ref(\@arr); tie my(%hash), 'Tie::StdHash'; ok is_hash_ref(\%hash); Data-Util-0.63/t/09_paranoia.t000644 000765 000024 00000003006 12040510404 015674 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More; use Data::Util qw(is_instance); BEGIN{ if(exists $INC{'Data/Util/PurePerl.pm'}){ plan skip_all => 'For XS only'; } else{ plan tests => 26; } } local $SIG{__WARN__} = sub{}; # ignore BEGIN{ no warnings; sub UNIVERSAL::new{ bless {} => shift; } package Foo; our @ISA = (undef, 1, [], \&new, 'Base'); sub new{ bless {} => shift; } package X; our @ISA = qw(A); package Y; package Z; package Bar; our @ISA = qw(::X main::Y ::main::main::Z); my $instance = bless {} => '::main::main::Bar'; sub instance{ $instance } package main::Ax; package ::Bx; our @ISA = qw(Ax); package ::main::main::Cx; our @ISA = qw(Bx); } my $o = Foo->new(); ok is_instance($o, 'Foo'); ok is_instance($o, 'Base'); ok is_instance($o, 'UNIVERSAL'); @Foo::ISA = (); ok is_instance($o, 'Foo'); ok!(is_instance($o, 'Base')); ok is_instance($o, 'UNIVERSAL'); ok is_instance($o, '::Foo'); ok is_instance($o, 'main::Foo'); ok is_instance($o, 'main::main::Foo'); ok is_instance($o, '::main::main::UNIVERSAL'); ok!is_instance($o, '::::Foo'); ok!is_instance($o, 'Fooo'); ok!is_instance($o, 'FoO'); ok!is_instance($o, 'foo'); ok!is_instance($o, 'mai'); ok!is_instance($o, 'UNIVERSA'); $o = Bar->instance; ok is_instance($o, 'Bar'); ok is_instance($o, 'X'); ok is_instance($o, 'Y'); ok is_instance($o, 'Z'); ok is_instance($o, '::Z'); ok!is_instance($o, 'main'); ok!is_instance($o, 'main::'); ok is_instance(Cx->new, 'Ax'); ok is_instance(Cx->new, 'Bx'); ok is_instance(Cx->new, 'Cx'); Data-Util-0.63/t/10_neat.t000644 000765 000024 00000002267 12040510404 015031 0ustar00gfxstaff000000 000000 #!perl -w use warnings 'FATAL'; use strict; use Test::More tests => 18; use Tie::Scalar; use Tie::Array; use Tie::Hash; sub foo{} { package Foo; use overload '""' => sub{ 'Foo!' }, fallback => 1; sub new{ bless {}, shift } } use Data::Util qw(neat); is neat(42), 42, 'neat()'; is neat(3.14), 3.14; is neat("foo"), q{"foo"}; is neat(undef), 'undef'; is neat(*ok), '*main::ok'; ok neat({'!foo' => '!bar'}); unlike neat({foo => 'bar', baz => 'bax'}), qr/undef/; like neat(\&foo), qr/^\\&main::foo\(.*\)$/; like neat(Foo->new(42)), qr/^Foo=HASH\(.+\)$/, 'for an overloaded object'; like neat(qr/foo/), qr/foo/, 'neat(qr/foo/) includes "foo"'; ok neat(+9**9**9), '+Inf'; ok neat(-9**9**9), '-Inf'; ok neat(9**9**9 - 9**9**9), 'NaN'; tie my $s, 'Tie::StdScalar', "foo"; is neat($s), q{"foo"}, 'for magical scalar'; my $x; $x = tie my @a, 'Tie::StdArray'; $x->[0] = 42; is neat($a[0]), 42, 'for magical scalar (aelem)'; $x = tie my %h, 'Tie::StdHash'; $x->{foo} = 'bar'; is neat($h{foo}), '"bar"', 'for magical scalar (helem)'; # recursive my @rec; push @rec, \@rec; ok neat(\@rec), 'neat(recursive array) is safe'; my %rec; $rec{self} = \%rec; ok neat(\%rec), 'neat(recursive hash) is safe'; Data-Util-0.63/t/11_fail_handler.t000644 000765 000024 00000001547 12040510404 016513 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 8; use Test::Exception; BEGIN{ use_ok 'Data::Util::Error'; } { package Foo; use Data::Util::Error \&fail; use Data::Util qw(:validate); sub f{ array_ref(@_); } sub fail{ 'FooError' } } { package Bar; use Data::Util::Error \&fail; use Data::Util qw(:validate); sub f{ array_ref(@_); } sub fail{ 'BarError' } } { package Baz; use base qw(Foo Bar); use Data::Util qw(:validate); sub g{ array_ref(@_); } } is( Data::Util::Error->fail_handler('Foo'), \&Foo::fail ); is( Data::Util::Error->fail_handler('Bar'), \&Bar::fail ); is( Data::Util::Error->fail_handler('Baz'), \&Foo::fail ); throws_ok{ Foo::f({}); } qr/FooError/; throws_ok{ Bar::f({}); } qr/BarError/; throws_ok{ Baz::g({}); } qr/FooError/; throws_ok{ Data::Util::Error->fail_handler(Foo => 'throw'); } qr/Validation failed/; Data-Util-0.63/t/12_in_attr_handler.t000644 000765 000024 00000001006 12040510404 017227 0ustar00gfxstaff000000 000000 #!perl -w use strict; use if ($] >= 5.011), 'Test::More', 'skip_all' => 'This test is for old perls'; use Test::More tests => 4; use Test::Exception; use Data::Util qw(get_code_info install_subroutine); use Attribute::Handlers; sub UNIVERSAL::Foo :ATTR(CODE, BEGIN){ my($pkg, $sym, $subr) = @_; lives_ok{ scalar get_code_info($subr); } 'get_code_info()'; lives_ok{ no warnings 'redefine'; install_subroutine 'main', 'foo', $subr; } 'install_subroutine()'; } sub f :Foo; my $anon = sub :Foo {}; Data-Util-0.63/t/13_optlist.t000644 000765 000024 00000010624 12040510404 015577 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 48; use Test::Exception; use Data::Util qw(:all); use constant PP_ONLY => $INC{'Data/Util/PurePerl.pm'}; BEGIN{ package Foo; sub new{ bless {}, shift; } package MyArray; our @ISA = qw(Foo); use overload bool => sub{ 1 }, '@{}' => sub{ ['ARRAY'] }, ; package MyHash; our @ISA = qw(Foo); use overload bool => sub{ 1 }, '%{}' => sub{ +{ foo => 'ARRAY' } }, ; package BadHash; our @ISA = qw(Foo); use overload bool => sub{ 1 }, '%{}' => sub{ ['ARRAY'] }, ; } use constant true => 1; use constant false => 0; # mkopt is_deeply mkopt(undef), [], 'mkopt()'; is_deeply mkopt([]), []; is_deeply mkopt(['foo']), [ [foo => undef] ]; is_deeply mkopt([foo => undef]), [ [foo => undef] ]; is_deeply mkopt([foo => [42]]), [ [foo => [42]] ]; is_deeply mkopt([qw(foo bar baz)]), [ [foo => undef], [bar => undef], [baz => undef]]; is_deeply mkopt({foo => undef}), [ [foo => undef] ]; is_deeply mkopt({foo => [42]}), [ [foo => [42]] ]; is_deeply mkopt([qw(foo bar baz)], undef, true), [[foo => undef], [bar => undef], [baz => undef]], 'unique'; is_deeply mkopt([foo => [], qw(bar)], undef, false, 'ARRAY'), [[foo => []], [bar => undef]], 'validation'; is_deeply mkopt([foo => [], qw(bar)], undef, false, ['CODE', 'ARRAY']), [[foo => []], [bar => undef]]; is_deeply mkopt([foo => anon_scalar], undef, false, 'SCALAR'), [[foo => anon_scalar]]; is_deeply mkopt([foo => \&ok], undef, false, 'CODE'), [[foo => \&ok]]; is_deeply mkopt([foo => Foo->new], undef, false, 'Foo'), [[foo => Foo->new]]; is_deeply mkopt(MyArray->new()), [ [ARRAY => undef] ], 'overloaded data (ARRAY)'; is_deeply mkopt([foo => [], qw(bar)], undef, false, {foo => 'ARRAY'}), [[foo => []], [bar => undef]]; is_deeply mkopt([foo => [], bar => {}], undef, false, {foo => ['CODE', 'ARRAY'], bar => 'HASH'}), [[foo => []], [bar => {}]]; is_deeply mkopt([foo => [42]], undef, false, MyArray->new()), [[foo => [42]]], 'overloaded validator (ARRAY)'; is_deeply mkopt([foo => [42]], 'test', false, MyHash->new()), [[foo => [42]]], 'overloaded validator (HASH)'; dies_ok{ mkopt([foo => {}], 'test', false, MyHash->new()); }; # mkopt_hash is_deeply mkopt_hash(undef), {}, 'mkopt_hash()'; is_deeply mkopt_hash([]), {}; is_deeply mkopt_hash(['foo']), { foo => undef }; is_deeply mkopt_hash([foo => undef]), { foo => undef }; is_deeply mkopt_hash([foo => [42]]), { foo => [42] }; is_deeply mkopt_hash([qw(foo bar baz)]), { foo => undef, bar => undef, baz => undef }; is_deeply mkopt_hash({foo => undef}), { foo => undef }; is_deeply mkopt_hash({foo => [42]}), { foo => [42] }; is_deeply mkopt_hash([foo => [], qw(bar)], undef, 'ARRAY'), {foo => [], bar => undef}, 'validation'; is_deeply mkopt_hash([foo => [], qw(bar)], undef, ['CODE', 'ARRAY']), {foo => [], bar => undef}; is_deeply mkopt_hash([foo => Foo->new], undef, 'Foo'), {foo => Foo->new}; is_deeply mkopt_hash([foo => [], qw(bar)], undef, {foo => 'ARRAY'}), {foo => [], bar => undef}; is_deeply mkopt_hash([foo => [], bar => {}], undef, {foo => ['CODE', 'ARRAY'], bar => 'HASH'}), {foo => [], bar => {}}; # XS specific misc. check my $key = 'foo'; my $ref = mkopt([$key]); $ref->[0][0] .= 'bar'; is $key, 'foo'; $ref = mkopt_hash([$key]); $key .= 'bar'; is_deeply $ref, {foo => undef}; sub f{ return mkopt(@_); } { my $a = mkopt(my $foo = ['foo']); push @$foo, 42; my $b = mkopt(my $bar = ['bar']); push @$bar, 42; is_deeply $a, [[foo => undef]], '(use TARG)'; is_deeply $b, [[bar => undef]], '(use TARG)'; } # unique throws_ok{ mkopt [qw(foo foo)], "mkopt", 1; } qr/multiple definitions/i, 'unique-mkopt'; throws_ok{ mkopt_hash [qw(foo foo)], "mkopt", 1; } qr/multiple definitions/i, 'unique-mkopt_hash'; # validation throws_ok{ mkopt [foo => []], "test", 0, 'HASH'; } qr/ARRAY-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => []], "test", 0, [qw(SCALAR CODE HASH GLOB)]; } qr/ARRAY-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => []], "test", 0, 'Bar'; } qr/ARRAY-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => Foo->new], "test", 0, 'Bar'; } qr/Foo-ref values are not valid.* in test opt list/; throws_ok{ mkopt [foo => Foo->new], "test", 0, ['CODE', 'Bar']; } qr/Foo-ref values are not valid.* in test opt list/; # bad uses dies_ok{ mkopt [], 'test', 0, anon_scalar(); }; dies_ok{ mkopt anon_scalar(); }; dies_ok{ mkopt_hash anon_scalar(); }; dies_ok{ mkopt(BadHash->new(), 'test'); }; Data-Util-0.63/t/14_uninst_subr.t000644 000765 000024 00000004051 12040510404 016452 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 23; use Test::Exception; use constant HAS_SCOPE_GUARD => eval{ require Scope::Guard }; use Data::Util qw(:all); { package Base; sub f{42}; package Derived; our @ISA = qw(Base); sub f; } sub foo(){ (42, 43) } my $before = \*foo; our $foo = 10; our @foo = (1, 2, 3); ok defined(&foo), 'before uninstalled'; ok __PACKAGE__->can('foo'), 'can'; uninstall_subroutine(__PACKAGE__, 'foo'); ok !__PACKAGE__->can('foo'), 'cannot'; is $foo, 10, 'remains other slots'; is_deeply \@foo, [1, 2, 3]; my $after = do{ no strict 'refs'; \*{'foo'} }; is *{$before}, *{$after}, 'compare globs directly'; uninstall_subroutine(__PACKAGE__, 'foo'); # ok uninstall_subroutine('Derived' => 'f'); is scalar(get_code_info(Derived->can('f'))), 'Base::f', 'uninstall subroutine stubs'; is(Derived->f(), 42); sub f1{} # f2 does not exist sub f3{} sub f4{} uninstall_subroutine(__PACKAGE__, qw(f1 f2), f3 => \&f3, f4 => \&f1, ); ok !__PACKAGE__->can('f1'); ok !__PACKAGE__->can('f2'); ok !__PACKAGE__->can('f3'), 'specify a matched subr (uninstalled)'; ok __PACKAGE__->can('f4'), 'specify an unmatched subr (not uninstalled)'; SKIP:{ skip 'requires Scope::Guard', 2 unless HAS_SCOPE_GUARD; my $i = 1; { my $s = Scope::Guard->new(sub{ $i--; pass 'closure released' }); install_subroutine(__PACKAGE__, closure => sub{ $s }); } uninstall_subroutine(__PACKAGE__, 'closure'); is $i, 0, 'closed values released'; } our $BAX = 42; { no warnings 'misc'; use constant BAR => 3.14; use constant BAZ => BAR * 2; is(BAR(), 3.14); uninstall_subroutine(__PACKAGE__, 'BAR', 'BAZ', 'BAX'); } is $BAX, 42; ok !__PACKAGE__->can('BAR'); ok !__PACKAGE__->can('BAZ'); lives_ok{ uninstall_subroutine('UndefinedPackage','foo'); }; throws_ok{ use constant FOO => 42; use warnings FATAL => 'misc'; uninstall_subroutine(__PACKAGE__, 'FOO'); } qr/Constant subroutine FOO uninstalled/; dies_ok{ uninstall_subroutine(undef, 'foo'); }; dies_ok{ uninstall_subroutine(__PACKAGE__, undef); }; throws_ok{ uninstall_subroutine(); } qr/^Usage: /; Data-Util-0.63/t/15_curry.t000644 000765 000024 00000005030 12040510404 015242 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 32; use Test::Exception; use constant HAS_SCOPE_GUARD => eval{ require Scope::Guard }; use Data::Util qw(:all); sub foo{ @_ } ok is_code_ref(curry(\&foo, 42)), 'curry()'; is_deeply [curry(\&foo, 42)->()], [42], 'without placeholders, in list context'; is_deeply [curry(\&foo, 42)->(38)], [42]; is_deeply [curry(\&foo, \0, 2)->(3)], [3, 2], 'with subscriptive placeholders'; is_deeply [curry(\&foo, \1, \0)->(2, 3)], [3, 2]; is_deeply [curry(\&foo, \0, 2, \1)->(1, 3)], [1, 2, 3]; is_deeply [curry(\&foo, \0, \0, \0)->(42)], [42, 42, 42]; is_deeply [scalar curry(\&foo, \(0 .. 2))->(1, 2, 3)], [3], 'in scalar context'; is_deeply [curry(\&foo, *_)->(1 .. 10)], [1 .. 10], 'with *_'; is_deeply [curry(\&foo, *_, 3)->(1, 2)], [1, 2, 3], '*_, x'; is_deeply [curry(\&foo, 1, *_)->(2, 3)], [1, 2, 3], 'x, *_'; is_deeply [curry(\&foo, *_, 1, *_)->(2, 3)], [2, 3, 1, 2, 3], '*_, x, *_'; is_deeply [curry(\&foo, *_, \0, \1)->(1, 2, 3, 4)], [3, 4, 1, 2], '*_, \\0, \\1'; is_deeply [curry(\&foo, \1, \0, *_)->(1, 2, 3, 4)], [2, 1, 3, 4], '\\0, \\1, *_'; { package Foo; sub new{ bless {}, shift } sub foo{ @_ } } my $o = Foo->new; is_deeply [curry($o, foo => 42)->()], [$o, 42], 'method curry'; is_deeply [curry($o, foo => \0)->(38)], [$o, 38]; is_deeply [curry($o, foo => *_)->(1, 2, 3)], [$o, 1, 2, 3]; is_deeply [curry(\0, foo => 1, 2, 3)->($o)], [$o, 1, 2, 3]; is_deeply [curry(\0, \1, *_)->($o, foo => 1, 2, 3)], [$o, 1, 2, 3]; is_deeply [curry(\1, \0, *_)->(foo => $o, 1, 2, 3)], [$o, 1, 2, 3]; # has normal argument semantics sub incr{ $_++ for @_; } { my $i = 0; curry(\&incr, $i)->(); is $i, 1, 'argument semantics (alias)'; curry(\&incr, \0)->($i); is $i, 2; curry(\&incr, *_)->($i); is $i, 3; } SKIP:{ skip 'requires Scope::Gurard for testing GC', 5 unless HAS_SCOPE_GUARD; my $i = 0; curry(\&foo, Scope::Guard->new(sub{ $i++ }))->() for 1 .. 3; is $i, 3, 'GC'; curry(\&foo, \0)->(Scope::Guard->new(sub{ $i++ })) for 1 .. 3; is $i, 6; curry(\&foo, *_)->(Scope::Guard->new(sub{ $i++ })) for 1 .. 3; is $i, 9; curry(Foo->new, 'foo', Scope::Guard->new(sub{ $i++ }))->() for 1 .. 3; is $i, 12; for(1 .. 3){ curry( Scope::Guard->new(sub{ $i++ }) ); } is $i, 15; } is_deeply [curry(\&foo, \undef)->(42)], [\undef], 'not a placeholder'; throws_ok { curry(\&undefined_function)->(); } qr/Undefined subroutine/; throws_ok { curry($o, 'undefined_method')->(); } qr/Can't locate object method/; dies_ok{ no warnings 'uninitialized'; curry(undef, undef)->(); } 'bad arguments'; Data-Util-0.63/t/16_modify.t000644 000765 000024 00000017651 12040510404 015402 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 55; use Test::Exception; use constant HAS_SCOPE_GUARD => eval{ require Scope::Guard }; use Data::Util qw(:all); sub foo{ @_ } my @tags; sub before{ push @tags, 'before'; } sub around{ push @tags, 'around'; my $next = shift; $next->(@_) } sub after { push @tags, 'after'; } ok is_code_ref(modify_subroutine(\&foo)), 'modify_subroutine()'; my $w = modify_subroutine \&foo, before => [\&before], around => [\&around], after => [\&after]; lives_ok{ ok subroutine_modifier($w); ok !subroutine_modifier(\&foo); }; is_deeply [subroutine_modifier $w, 'before'], [\&before], 'getter:before'; is_deeply [subroutine_modifier $w, 'around'], [\&around], 'getter:around'; is_deeply [subroutine_modifier $w, 'after'], [\&after], 'getter:after'; is_deeply [scalar $w->(1 .. 10)], [10], 'call with scalar context'; is_deeply \@tags, [qw(before around after)]; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10], 'call with list context'; is_deeply \@tags, [qw(before around after)]; $w = modify_subroutine \&foo; subroutine_modifier $w, before => \&before; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(before)], 'add :before modifiers'; $w = modify_subroutine \&foo; subroutine_modifier $w, around => \&around; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(around)], 'add :around modifiers'; $w = modify_subroutine \&foo; subroutine_modifier $w, after => \&after; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(after)], 'add :after modifiers'; $w = modify_subroutine \&foo, before => [(\&before) x 10], around => [(\&around) x 10], after => [(\&after) x 10]; @tags = (); is_deeply [$w->(42)], [42]; is_deeply \@tags, [('before') x 10, ('around') x 10, ('after') x 10], 'with multiple modifiers'; subroutine_modifier $w, before => \&before, \&before; subroutine_modifier $w, around => \&around, \&around; subroutine_modifier $w, after => \&after, \&after; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [('before') x 12, ('around') x 12, ('after') x 12], 'add modifiers'; # calling order and copying sub f1{ push @tags, 'f1'; my $next = shift; $next->(@_); } sub f2{ push @tags, 'f2'; my $next = shift; $next->(@_); } sub f3{ push @tags, 'f3'; my $next = shift; $next->(@_); } sub before2{ push @tags, 'before2' } sub before3{ push @tags, 'before3' } sub after2 { push @tags, 'after2' } sub after3 { push @tags, 'after3' } # the order of around modifier $w = modify_subroutine \&foo, around => [ \&f1, \&f2, \&f3 ]; @tags = (); $w->(); is_deeply \@tags, [qw(f1 f2 f3)], ":around order (modify_subroutine)(@tags)"; $w = modify_subroutine \&foo; subroutine_modifier $w, around => \&f3, \&f2, \&f1; @tags = (); $w->(); is_deeply \@tags, [qw(f3 f2 f1)], ":around order (subroutine_modifier) (@tags)"; $w = modify_subroutine \&foo; subroutine_modifier $w, around => $_ for \&f1, \&f2, \&f3; @tags = (); $w->(); is_deeply \@tags, [qw(f3 f2 f1)], ":around order (subroutine_modifier) (@tags)"; # the order of before modifier $w = modify_subroutine \&foo, before => [\&before, \&before2, \&before3]; @tags = (); $w->(); is_deeply \@tags, [qw(before before2 before3)], ':before order (modify_subroutine)'; $w = modify_subroutine \&foo; subroutine_modifier $w, before => \&before, \&before2, \&before3; @tags = (); $w->(); is_deeply \@tags, [qw(before3 before2 before)], ':before order (subroutine_modifier)'; $w = modify_subroutine \&foo; subroutine_modifier $w, before => $_ for \&before, \&before2, \&before3; @tags = (); $w->(); is_deeply \@tags, [qw(before3 before2 before)], ":before order (subroutine_modifier) (@tags)"; # the order of after modifier $w = modify_subroutine \&foo, after => [\&after, \&after2, \&after3]; @tags = (); $w->(); is_deeply \@tags, [qw(after after2 after3)], ':after order (modify_subroutine)'; $w = modify_subroutine \&foo; subroutine_modifier $w, after => \&after, \&after2, \&after3; @tags = (); $w->(); is_deeply \@tags, [qw(after after2 after3)], ':after order (subroutine_modifier)'; $w = modify_subroutine \&foo; subroutine_modifier $w, after => $_ for \&after, \&after2, \&after3; @tags = (); $w->(); is_deeply \@tags, [qw(after after2 after3)], ":after order (subroutine_modifier) (@tags)"; # Moose compatibility $w = modify_subroutine \&foo; subroutine_modifier $w, before => $_ for \&before1, \&before2, \&before3; subroutine_modifier $w, around => $_ for \&around1, \&around2, \&around3; subroutine_modifier $w, after => $_ for \&after1, \&after2, \&after3; is_deeply [subroutine_modifier $w, 'before'], [\&before3, \&before2, \&before1], 'get before modifiers'; is_deeply [subroutine_modifier $w, 'around'], [\&around3, \&around2, \&around1], 'get around modifiers'; is_deeply [subroutine_modifier $w, 'after' ], [\&after1, \&after2, \&after3 ], 'get after modifiers'; # Copying possilbility $w = modify_subroutine \&foo, before => [subroutine_modifier $w, 'before'], around => [subroutine_modifier $w, 'around'], after => [subroutine_modifier $w, 'after' ]; is_deeply [subroutine_modifier $w, 'before'], [\&before3, \&before2, \&before1], 'copy before modifiers'; is_deeply [subroutine_modifier $w, 'around'], [\&around3, \&around2, \&around1], 'copy around modifiers'; is_deeply [subroutine_modifier $w, 'after' ], [\&after1, \&after2, \&after3 ], 'copy after modifiers'; # Contexts sub get_context{ push @tags, wantarray ? 'list' : defined(wantarray) ? 'scalar' : 'void'; } $w = modify_subroutine(\&foo, around => [\&get_context]); @tags = (); () = $w->(); is_deeply \@tags, [qw(list)], 'list context in around'; @tags = (); scalar $w->(); is_deeply \@tags, [qw(scalar)], 'scalar context in around'; @tags = (); $w->(); is_deeply \@tags, [qw(void)], 'void context in around'; # Modifier's args sub mutator{ $_[0]++; } $w = modify_subroutine(\&foo, before => [\&mutator]); my $n = 42; is_deeply [ $w->($n) ], [43]; # $n++ is $n, 43; # GC SKIP:{ skip 'requires Scope::Gurard for testing GC', 3 unless HAS_SCOPE_GUARD; skip 'Pure Perl version in 5.8.x has a problem', 3 if $] < 5.010; @tags = (); for(1 .. 10){ my $gbefore = Scope::Guard->new(sub{ push @tags, 'before' }); my $garound = Scope::Guard->new(sub{ push @tags, 'around' }); my $gafter = Scope::Guard->new(sub{ push @tags, 'after' }); my $w = modify_subroutine \&foo, before => [sub{ $gbefore }], # encloses guard objects around => [sub{ $gafter }], after => [sub{ $gafter }]; } is_deeply [sort @tags], [sort((qw(after around before)) x 10)], 'closed values are released'; @tags = (); my $i = 0; for(1 .. 10){ my $gbefore = Scope::Guard->new(sub{ push @tags, 'before' }); my $garound = Scope::Guard->new(sub{ push @tags, 'around' }); my $gafter = Scope::Guard->new(sub{ push @tags, 'after' }); my $w = modify_subroutine \&foo, before => [sub{ $gbefore }], # encloses guard objects around => [sub{ $gafter }], after => [sub{ $gafter }]; $w->(Scope::Guard->new( sub{ $i++ } )); } is_deeply [sort @tags], [sort((qw(after around before)) x 10)], '... called and released'; is $i, 10, '... and the argument is also released'; } # FATAL dies_ok{ modify_subroutine(undef); }; dies_ok{ modify_subroutine(\&foo, []); }; dies_ok{ modify_subroutine(\&foo, before => [1]); }; dies_ok{ modify_subroutine(\&foo, around => [1]); }; dies_ok{ modify_subroutine(\&foo, after => [1]); }; $w = modify_subroutine(\&foo); throws_ok{ subroutine_modifier($w, 'foo'); } qr/Validation failed:.* a modifier property/; throws_ok{ subroutine_modifier($w, undef); } qr/Validation failed:.* a modifier property/; throws_ok{ subroutine_modifier($w, before => 'foo'); } qr/Validation failed:.* a CODE reference/; throws_ok{ subroutine_modifier($w, foo => sub{}); } qr/Validation failed:.* a modifier property/; throws_ok{ subroutine_modifier(\&foo, 'before'); } qr/Validation failed:.* a modified subroutine/; throws_ok{ subroutine_modifier(\&foo, before => sub{}); } qr/Validation failed:.* a modified subroutine/; Data-Util-0.63/t/17_nsclean.t000644 000765 000024 00000001011 12040510404 015516 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 10; use Test::Exception; use FindBin qw($Bin); use lib "$Bin/lib"; { package Foo; use NSClean; ::ok foo(), 'foo'; ::ok bar(), 'bar'; ::ok baz(), 'baz'; our $foo = 'a'; our @foo = 'b'; our %foo = (c => 'd'); } ok exists $Foo::{foo}, '*Foo::foo exists'; is_deeply eval q{\\$Foo::foo}, \'a'; is_deeply eval q{\\@Foo::foo}, ['b']; is_deeply eval q{\\%Foo::foo}, {c => 'd'}; is(Foo->can('foo'), undef); is(Foo->can('bar'), undef); is(Foo->can('baz'), \&Foo::baz); Data-Util-0.63/t/18_is_value.t000644 000765 000024 00000003346 12040510404 015720 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 100; use Test::Exception; use Data::Util qw(:all); use Tie::Scalar; use constant INF => 9**9**9; use constant NAN => sin(INF()); my $s; tie $s, 'Tie::StdScalar', 'magic'; foreach my $x('foo', '', 0, -100, 3.14, $s){ ok is_value($x), sprintf 'is_value(%s)', neat($x); } tie $s, 'Tie::StdScalar', \'magic'; foreach my $x(undef, [], *STDIN{IO}, *ok, $s){ ok !is_value($x), sprintf '!is_value(%s)', neat($x); } tie $s, 'Tie::StdScalar', 'magic'; foreach my $x('foo', 0, -100, 3.14, $s){ ok is_string($x), sprintf 'is_string(%s)', neat($x); } tie $s, 'Tie::StdScalar', \'magic'; foreach my $x('', undef, [], *STDIN{IO}, *ok, $s){ ok !is_string($x), sprintf '!is_string(%s)', neat($x); } tie $s, 'Tie::StdScalar', 1234; foreach my $x(0, 42, -42, 3.00, '0', '+0', '-0', ' -42', '+42 ', 2**30, $s){ ok is_integer($x), sprintf 'is_integer(%s)', neat($x); my $w; local $SIG{__WARN__} = sub{ $w = "@_" }; my $i = 0+$x; is $w, undef, 'numify-safe'; } tie $s, 'Tie::StdScalar', 'magic'; foreach my $x( undef, 3.14, '0.0', 'foo', (9**9**9), -(9**9**9), 'NaN', INF(), -INF(), NAN(), -NAN(), 1 != 1, *ok, [42], *STDIN{IO}, '0 but true', $s){ ok !is_integer($x), sprintf '!is_integer(%s)', neat($x); } tie $s, 'Tie::StdScalar', 123.456; foreach my $x(0, 1, -1, 3.14, '0', '+0', '-0', '0E0', ' 0.0', '1e-1', 2**32+0.1, $s){ ok is_number($x), sprintf 'is_number(%s)', neat($x); my $w; local $SIG{__WARN__} = sub{ $w = "@_" }; my $n = 0+$x; is $w, undef, 'numify-safe'; } tie $s, 'Tie::StdScalar', 'magic'; foreach my $x(undef, 'foo', 'Inf', '-Infinity', 'NaN', INF(), -INF(), NAN(), -NAN(), 1 != 1, '0 but true', *ok, [42], *STDIN{IO}, $s){ ok !is_number($x), sprintf '!is_number(%s)', neat($x); } Data-Util-0.63/t/19_multiple_modifiers.t000644 000765 000024 00000003143 12040510404 020001 0ustar00gfxstaff000000 000000 #!perl # this test comes from Class::Method::Modifiers use strict; use warnings; use Test::More tests => 2; use FindBin qw($Bin); use lib "$Bin/../example/lib"; my @seen; my @expected = qw/ before around-before orig around-after after /; my $child = Child->new(); $child->orig(); is_deeply(\@seen, \@expected, "multiple modifiers in one class"); @seen = (); @expected = qw/ beforer around-beforer before around-before orig around-after after around-afterer afterer /; my $childer = Childer->new(); $childer->orig(); is_deeply(\@seen, \@expected, "multiple modifiers subclassed with multiple modifiers"); BEGIN { package Parent; sub new { bless {}, shift } sub orig { push @seen, 'orig'; } } BEGIN { package Child; our @ISA = 'Parent'; use Method::Modifiers; after 'orig' => sub { push @seen, 'after'; }; around 'orig' => sub { my $orig = shift; push @seen, 'around-before'; $orig->(); push @seen, 'around-after'; }; before 'orig' => sub { push @seen, 'before'; }; } BEGIN { package Childer; our @ISA = 'Child'; use Method::Modifiers; after 'orig' => sub { push @seen, 'afterer'; }; around 'orig' => sub { my $orig = shift; push @seen, 'around-beforer'; $orig->(); push @seen, 'around-afterer'; }; before 'orig' => sub { push @seen, 'beforer'; }; } Data-Util-0.63/t/20_lexical_sub.t000644 000765 000024 00000001302 12040510404 016362 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 9; use Test::Exception; use FindBin qw($Bin); use lib "$Bin/../example/lib"; BEGIN{ package Foo; use Sub::Exporter::Lexical exports => [ qw(foo), bar => \&bar, baz => \&bar, ], ; sub foo{ 'foo' } sub bar{ 'bar' } $INC{'Foo.pm'} = __FILE__; } { use Foo; lives_ok{ is foo(), 'foo'; } 'call lexical sub'; lives_ok{ is bar(), 'bar'; } 'call lexical sub'; lives_ok{ is baz(), 'bar'; } 'call lexical sub'; } throws_ok{ isnt foo(), 'foo'; } qr/Undefined subroutine \&main::foo/; throws_ok{ isnt bar(), 'bar'; } qr/Undefined subroutine \&main::bar/; throws_ok{ isnt baz(), 'bar'; } qr/Undefined subroutine \&main::baz/;; Data-Util-0.63/t/21_get_code_ref.t000644 000765 000024 00000003007 12040510404 016502 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 26; use Test::Exception; use Data::Util qw(:all); sub stub; sub stub2; sub stub_with_attr :method; sub stub_with_proto (); use constant CONST => 42; is get_code_ref(__PACKAGE__, 'ok'), \&ok, 'get_code_ref'; is get_code_ref(__PACKAGE__, 'foobar'), undef; is ref(get_code_ref __PACKAGE__, 'stub'), 'CODE'; is ref(get_code_ref __PACKAGE__, 'stub_with_attr'), 'CODE'; is ref(get_code_ref __PACKAGE__, 'stub_with_proto'), 'CODE'; is ref(get_code_ref __PACKAGE__, 'CONST'), 'CODE'; is eval q{CONST}, 42; uninstall_subroutine __PACKAGE__, qw(stub stub2 stub_with_attr stub_with_proto); is get_code_ref(__PACKAGE__, 'stub'), undef; is get_code_ref(__PACKAGE__, 'stub2'), undef; is get_code_ref(__PACKAGE__, 'stub_with_attr'), undef; is get_code_ref(__PACKAGE__, 'stub_with_proto'), undef; is get_code_ref('FooBar', 'foo'), undef; is get_code_ref(42, 'foo'), undef; ok !exists $main::{"Nowhere::"}; ok !get_code_ref("Nowhere", "foo"); ok !exists $main::{"Nowhere::"}, 'not vivify a package'; ok !exists $main::{"nothing"}; ok !get_code_ref("main", "nothing"); ok !exists $main::{"nothing"}, 'not vivify a symbol'; ok !get_code_ref('FooBar', 'foo'); ok get_code_ref('FooBar', 'foo', -create), '-create'; ok get_code_ref('FooBar', 'foo'), '... created'; eval q{FooBar::foo()}; like $@, qr/Undefined subroutine \&FooBar::foo/, 'call a created stub'; dies_ok{ get_code_ref(); }; dies_ok{ get_code_ref undef, 'foo'; }; dies_ok{ get_code_ref __PACKAGE__, undef; }; Data-Util-0.63/t/22_install2.t000644 000765 000024 00000001276 12040510404 015634 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 8; use Test::Exception; use Data::Util qw(:all); install_subroutine(__PACKAGE__, { foo => sub{ 42 } }); lives_ok{ is __PACKAGE__->foo(), 42; }; uninstall_subroutine(__PACKAGE__, { foo => \&ok }); lives_ok{ is __PACKAGE__->foo(), 42; }; uninstall_subroutine(__PACKAGE__, { foo => undef }); throws_ok{ __PACKAGE__->foo(); } qr/Can't locate object method "foo" via package "main"/; install_subroutine(__PACKAGE__, { foo => sub{ 3.14 } }); lives_ok{ is __PACKAGE__->foo(), 3.14; }; uninstall_subroutine(__PACKAGE__, { foo => __PACKAGE__->can('foo') }); throws_ok{ __PACKAGE__->foo(); } qr/Can't locate object method "foo" via package "main"/; Data-Util-0.63/t/23_largeargs.t000644 000765 000024 00000001326 12040510404 016050 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Test::More tests => 6; use Data::Util qw(:all); sub foo{ @_ } my @tags; sub before{ push @tags, 'before' . scalar @_; } sub around{ push @tags, 'around' . scalar @_; my $next = shift; $next->(@_) } sub after { push @tags, 'after' . scalar @_; } my $w = modify_subroutine \&foo, before => [\&before], around => [\&around], after => [\&after], ; @tags = (); is_deeply [$w->(1 .. 10)], [1 .. 10]; is_deeply \@tags, [qw(before10 around11 after10)] or diag "[@tags]"; @tags = (); is_deeply [$w->(1 .. 1000)], [1 .. 1000]; is_deeply \@tags, [qw(before1000 around1001 after1000)]; @tags = (); is_deeply [$w->(1 .. 5000)], [1 .. 5000]; is_deeply \@tags, [qw(before5000 around5001 after5000)]; Data-Util-0.63/t/24_eval_in_modifiers.t000644 000765 000024 00000002333 12040510404 017557 0ustar00gfxstaff000000 000000 #!perl -w # reported by nekoya package Person; use Data::Util qw/:all/; { no warnings 'redefine'; my $before = modify_subroutine( get_code_ref(__PACKAGE__, 'before_chk'), before => [ sub { eval "use Hoge" } ] ); my $after = modify_subroutine( get_code_ref(__PACKAGE__, 'after_chk'), after => [ sub { eval "use Hoge" } ] ); my $around = modify_subroutine( get_code_ref(__PACKAGE__, 'around_chk'), around => [ sub { my $orig = shift; my $self = shift; eval "use Hoge"; $self->$orig(@_); } ] ); install_subroutine(__PACKAGE__, 'before_chk' => $before); install_subroutine(__PACKAGE__, 'after_chk' => $after); install_subroutine(__PACKAGE__, 'around_chk' => $around); } sub new { bless {}, shift } sub before_chk { 'before checked' } sub after_chk { 'after checked' } sub around_chk { 'around checked' } package main; use strict; use warnings; use Test::More tests => 4; my $pp = Person->new; is $pp->before_chk, 'before checked', 'before check done'; is $pp->after_chk, 'after checked', 'after check done'; is $pp->around_chk, 'around checked', 'around check done'; ok 1, 'all tests finished'; Data-Util-0.63/t/lib/000755 000765 000024 00000000000 12305724300 014162 5ustar00gfxstaff000000 000000 Data-Util-0.63/t/pp00_load.t000644 000765 000024 00000000315 12040510404 015350 0ustar00gfxstaff000000 000000 #!perl -wT use Test::More tests => 2; BEGIN { $Data::Util::TESTING_PERL_ONLY = 1; use_ok( 'Data::Util' ); } my $backend = $Data::Util::TESTING_PERL_ONLY ? 'PurePerl' : 'XS'; is $backend, 'PurePerl'; Data-Util-0.63/t/pp01_refs.t000644 000765 000024 00000000226 12040510404 015372 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp02_inst.t000644 000765 000024 00000000226 12040510404 015411 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp03_gen.t000644 000765 000024 00000000226 12040510404 015206 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp04_overloaded.t000644 000765 000024 00000000226 12040510404 016562 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp05_get_stash.t000644 000765 000024 00000000226 12040510404 016420 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp06_subroutine.t000644 000765 000024 00000000226 12040510404 016637 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp08_mgvars.t000644 000765 000024 00000000226 12040510404 015741 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp10_neat.t000644 000765 000024 00000000226 12040510404 015362 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp11_fail_handler.t000644 000765 000024 00000000226 12040510404 017044 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp12_in_attr_handler.t000644 000765 000024 00000000226 12040510404 017572 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp13_optlist.t000644 000765 000024 00000000226 12040510404 016134 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp14_uninst_subr.t000644 000765 000024 00000000226 12040510404 017012 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp15_curry.t000644 000765 000024 00000000226 12040510404 015604 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp16_modify.t000644 000765 000024 00000000226 12040510404 015730 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp17_nsclean.t000644 000765 000024 00000000226 12040510404 016065 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp18_is_value.t000644 000765 000024 00000000226 12040510404 016252 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp19_multiple_modifiers.t000644 000765 000024 00000000226 12040510404 020340 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp20_lexical_sub.t000644 000765 000024 00000000226 12040510404 016726 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp21_get_code_ref.t000644 000765 000024 00000000226 12040510404 017042 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp22_install2.t000644 000765 000024 00000000226 12040510404 016166 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp23_largeargs.t000644 000765 000024 00000000226 12040510404 016406 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/pp24_eval_in_modifiers.t000644 000765 000024 00000000226 12040510404 020116 0ustar00gfxstaff000000 000000 #!perl -w use strict; $Data::Util::TESTING_PERL_ONLY = $Data::Util::TESTING_PERL_ONLY = 1; my $file = $0; $file =~ s/pp//; do $file; die $@ if $@; Data-Util-0.63/t/lib/NSClean.pm000644 000765 000024 00000000705 12040510404 015777 0ustar00gfxstaff000000 000000 package NSClean; use strict; use warnings; use Data::Util; sub import{ my $into = caller; Data::Util::install_subroutine($into, foo => sub{ 'foo' }, bar => sub{ 'bar' }, baz => sub{ 'baz' }, ); $^H = 0x020000; # HINT_LOCALIZE_HH $^H{(__PACKAGE__)} = __PACKAGE__->new(into => $into); } sub new{ my $class = shift; bless {@_}, $class; } sub DESTROY{ my($self) = @_; Data::Util::uninstall_subroutine($self->{into}, qw(foo bar)); } 1;Data-Util-0.63/lib/Data/000755 000765 000024 00000000000 12305724300 014570 5ustar00gfxstaff000000 000000 Data-Util-0.63/lib/Data/Util/000755 000765 000024 00000000000 12305724300 015505 5ustar00gfxstaff000000 000000 Data-Util-0.63/lib/Data/Util.pm000644 000765 000024 00000026670 12305724254 016066 0ustar00gfxstaff000000 000000 package Data::Util; use 5.008_001; use strict; #use warnings; our $VERSION = '0.63'; use Exporter; our @ISA = qw(Exporter); our $TESTING_PERL_ONLY; $TESTING_PERL_ONLY = $ENV{DATA_UTIL_PUREPERL} ? 1 : 0 unless defined $TESTING_PERL_ONLY; unless($TESTING_PERL_ONLY){ local $@; $TESTING_PERL_ONLY = !eval{ require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); }; # if($@ && $ENV{DATA_UTIL_DEBUG}){ # warn $@; # } } require 'Data/Util/PurePerl.pm' # not to create the namespace if $TESTING_PERL_ONLY; our @EXPORT_OK = qw( is_scalar_ref is_array_ref is_hash_ref is_code_ref is_glob_ref is_rx is_regex_ref is_instance is_invocant is_value is_string is_number is_integer scalar_ref array_ref hash_ref code_ref glob_ref rx regex_ref instance invocant anon_scalar neat get_stash install_subroutine uninstall_subroutine get_code_info get_code_ref curry modify_subroutine subroutine_modifier mkopt mkopt_hash ); our %EXPORT_TAGS = ( all => \@EXPORT_OK, check => [qw( is_scalar_ref is_array_ref is_hash_ref is_code_ref is_glob_ref is_rx is_instance is_invocant is_value is_string is_number is_integer is_regex_ref )], validate => [qw( scalar_ref array_ref hash_ref code_ref glob_ref rx instance invocant regex_ref )], ); 1; __END__ =head1 NAME Data::Util - A selection of utilities for data and data types =head1 VERSION This document describes Data::Util version 0.63 =head1 SYNOPSIS use Data::Util qw(:validate); sub foo{ # they will die if invalid values are supplied my $sref = scalar_ref(shift); my $aref = array_ref(shift); my $href = hash_ref(shift); my $cref = code_ref(shift); my $gref = glob_ref(shift); my $rx = rx(shift); # regular expression my $obj = instance(shift, 'Foo'); # ... } use Data::Util qw(:check); sub bar{ my $x = shift; if(is_scalar_ref $x){ # $x is an array reference } # ... elsif(is_instance $x, 'Foo'){ # $x is an instance of Foo } # ... } # miscelaneous use Data::Util qw(:all); my $x = anon_scalar(); $x = anon_scalar($x); # OK my $stash = get_stash('Foo'); install_subroutine('Foo', hello => sub{ "Hello!\n" }, goodby => sub{ "Goodby!\n" }, ); print Foo::hello(); # Hello! my($pkg, $name) = get_code_info(\&Foo::hello); # => ('Foo', 'hello') my $fqn = get_code_info(\&Foo::hello); # => 'Foo::hello' my $code = get_code_ref('Foo', 'hello'); # => \&Foo::hello uninstall_subroutine('Foo', qw(hello goodby)); # simple format for errro messages (not the same as Data::Dumper) print neat("Hello!\n"); # => "Hello!\n" print neat(3.14); # => 3.14 print neat(undef); # => undef =head1 DESCRIPTION This module provides utility functions for data and data types, including functions for subroutines and symbol table hashes (stashes). The implementation of this module is both Pure Perl and XS, so if you have a C compiler, all the functions this module provides are really faster. There are many benchmarks in the F directory. =head1 INTERFACE =head2 Check functions Check functions are introduced by the C<:check> import tag, which check the argument type and return a bool. These functions also checks overloading magic, e.g. C<${}> for a SCALAR reference. =over 4 =item is_scalar_ref(value) For a SCALAR reference. =item is_array_ref(value) For an ARRAY reference. =item is_hash_ref(value) For a HASH reference. =item is_code_ref(value) For a CODE reference. =item is_glob_ref(value) For a GLOB reference. =item is_rx(value) For a regular expression reference generated by the C operator. =item is_instance(value, class) For an instance of I. It is equivalent to something like C<< Scalar::Util::blessed($value) && $value->isa($class) >>. =item is_invocant(value) For an invocant, i.e. a blessed reference or existent package name. If I is a valid class name but does not exist, it will return false. =item is_value(value) Checks whether I is a primitive value, i.e. a defined, non-ref, and non-type-glob value. This function has no counterpart for validation. =item is_string(value) Checks whether I is a string with non-zero-length contents, equivalent to C<< is_value($value) && length($value) > 0 >>. This function has no counterpart for validation. =item is_number(value) Checks whether I is a number. Here, a B means that the perl parser can understand it and that the perl numeric converter (e.g. invoked by C<< sprintf '%g', $value >>) doesn't complain about it. It is similar to C but refuses C, C and C<"0 but true">. Note that C<9**9**9> makes C and C<9**9**9 - 9**9**9> makes C. This function has no counterpart for validation. =item is_integer(value) Checks whether I is an integer. An B is also a B, so this function refuses C and C. See also C. This function has no counterpart for validation. =back =head2 Validating functions Validating functions are introduced by the C<:validate> tag which check the argument and returns the first argument. These are like the C<:check> functions but dies if the argument type is invalid. These functions also checks overloading magic, e.g. C<${}> for a SCALAR reference. =over 4 =item scalar_ref(value) For a SCALAR reference. =item array_ref(value) For an ARRAY reference. =item hash_ref(value) For a HASH reference. =item code_ref(value) For a CODE reference. =item glob_ref(value) For a GLOB reference. =item rx(value) For a regular expression reference. =item instance(value, class) For an instance of I. =item invocant(value) For an invocant, i.e. a blessed reference or existent package name. If I is a valid class name and the class exists, then it returns the canonical class name, which is logically cleaned up. That is, it does C<< $value =~ s/^::(?:main::)*//; >> before returns it. NOTE: The canonization is because some versions of perl has an inconsistency on package names: package ::Foo; # OK my $x = bless {}, '::Foo'; # OK ref($x)->isa('Foo'); # Fatal The last sentence causes a fatal error: C. However, C<< invocant(ref $x)->isa('Foo') >> is always OK. =back =head2 Miscellaneous utilities There are some other utility functions you can import from this module. =over 4 =item anon_scalar() Generates an anonymous scalar reference to C. =item anon_scalar(value) Generates an anonymous scalar reference to the copy of I. It is equivalent to C<< do{ my $tmp = $value; \$tmp; } >>. =item neat(value) Returns a neat string that is suitable to display. This is a smart version of C<>. =item get_stash(invocant) Returns the symbol table hash (also known as B) of I if the stash exists. =item install_subroutine(package, name => subr [, ...]) Installs I into I as I. It is similar to C<< do{ no strict 'refs'; *{$package.'::'.$name} = \&subr; } >>. In addition, if I is an anonymous subroutine, it is located into I as a named subroutine I<&package::name>. For example: install_subroutine($pkg, say => sub{ print @_, "\n" }); install_subroutine($pkg, one => \&_one, two => \&_two, ); # accepts a HASH reference install_subroutine($pkg, { say => sub{ print @_, "\n" }); # To re-install I, use C<< no warnings 'redefine' >> directive: no warnings 'redefine'; install_subroutine($package, $name => $subr); =item uninstall_subroutine(package, names...) Uninstalls I from I. It is similar to C, but uninstall multiple subroutines at a time. If you want to specify deleted subroutines, you can supply C<< name => \&subr >> pairs. For example: uninstall_subroutine('Foo', 'hello'); uninstall_subroutine('Foo', hello => \&Bar::hello); uninstall_subroutine($pkg, one => \&_one, two => \&_two, ); # accepts a HASH reference uninstall_subroutine(\$pkg, { hello => \&Bar::hello }); =item get_code_info(subr) Returns a pair of elements, the package name and the subroutine name of I. It is similar to C, but it returns the fully qualified name in scalar context. =item get_code_ref(package, name, flag?) Returns I<&package::name> if it exists, not touching the symbol in the stash. if I is a string C<-create>, it returns I<&package::name> regardless of its existence. That is, it is equivalent to C<< do{ no strict 'refs'; \&{package . '::' . $name} } >>. For example: $code = get_code_ref($pkg, $name); # like *{$pkg.'::'.$name}{CODE} $code = get_code_ref($pkg, $name, -create); # like \&{$pkg.'::'.$name} =item curry(subr, args and/or placeholders) Makes I curried and returns the curried subroutine. This is also considered as lightweight closures. See also L. =item modify_subroutine(subr, ...) Modifies I with subroutine modifiers and returns the modified subroutine. This is also considered as lightweight closures. I must be a code reference or callable object. Optional arguments: C<< before => [subroutine(s)] >> called before I. C<< around => [subroutine(s)] >> called around I. C<< after => [subroutine(s)] >> called after I. This seems a constructor of modified subroutines and C is property accessors, but it does not bless the modified subroutines. =item subroutine_modifier(subr) Returns whether I is a modified subroutine. =item subroutine_modifier(modified_subr, property) Gets I from I. Valid properties are: C, C, C. =item subroutine_modifier(modified_subr, modifier => [subroutine(s)]) Adds subroutine I to I. Valid modifiers are: C, C, C. =item mkopt(input, moniker, require_unique, must_be) Produces an array of an array reference from I. It is compatible with C. In addition to it, I can be a HASH reference with C<< name => type >> pairs. For example: my $optlist = mkopt(['foo', bar => [42]], $moniker, $uniq, { bar => 'ARRAY' }); # $optlist == [[foo => undef], [bar => [42]] =item mkopt_hash(input, moniker, must_be) Produces a hash reference from I. It is compatible with C. In addition to it, I can be a HASH reference with C<< name => type >> pairs. For example: my $optlist = mkopt(['foo', bar => [42]], $moniker, { bar => 'ARRAY' }); # $optlist == {foo => undef, bar => [42]} =back =head1 ENVIRONMENT VARIABLES =head2 DATA_UTIL_PUREPERL If true, C uses the Pure Perl implementation. =head1 DEPENDENCIES Perl 5.8.1 or later. If you have a C compiler, you can use the XS backend, but the Pure Perl backend is also available if you have no C compilers. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to the author. =head1 SEE ALSO L. L. L. L. L. L. L. L. L. L. L =head1 AUTHOR Goro Fuji(gfx) Egfuji(at)cpan.orgE. =head1 LICENSE AND COPYRIGHT Copyright (c) 2008-2010, Goro Fuji Egfuji(at)cpan.orgE. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-Util-0.63/lib/Data/Util/Curry.pod000644 000765 000024 00000002452 12040510404 017312 0ustar00gfxstaff000000 000000 =head1 NAME Data::Util::Curry - Curries functions and methods =head1 SYNOPSIS use feature 'say'; use Data::Util qw(curry); sub sum{ my $total = 0; for my $x(@_){ $total += $x; } return $total; } # placeholder "\0" indicates a subscript of the arguments say curry(\&add, \0, 42)->(10); # 52 # placeholder "*_" indicates all the arguments say curry(\&add, *_)->(1 .. 10); # 55 # two subscripts and the rest of the arguments say curry(\&add, *_, \1, \0)->(1 .. 5); # 3 + 4 + 5 + 1 + 2 =head1 DESCRIPTION (todo) =head1 EXAMPLES =head2 Currying Functions curry(\&f, \0, 2)->(1); # f(1, 2) curry(\&f, 3, \0)->(4); # f(3, 4) curry(\&f, *_)->(5, 6); # f(5, 6) curry(\&f, \0, \1, *_)->(1, 2, 3, 4); # f(1, 2, 3, 4) curry(\&f, *_, \0, \1)->(1, 2, 3, 4); # f(3, 4, 1, 2) =head2 Currying Methods curry($obj, 'something', *_)->(1, 2); # $obj->something(1, 2) curry($obj, 'something', foo => \0, bar => \1)->(1, 2); # $obj->something(foo => 1, bar => 2) curry(\0, 'something', \1)->($obj, 42); # $obj->something(42) curry($obj, \0, *_)->('something', 1, 2); # $obj->something(1, 2) =head2 Argument Semantics sub incr{ $_[0]++ } my $i = 0; curry(\&incr, \0)->($i); # $i++ curry(\&incr, *_)->($i); # $i++ curry(\&incr, $i)->(); # $i++ =head1 SEE ALSO L. =cut Data-Util-0.63/lib/Data/Util/Error.pm000644 000765 000024 00000002641 12040510404 017131 0ustar00gfxstaff000000 000000 package Data::Util::Error; use strict; use warnings; use Data::Util (); sub import{ my $class = shift; $class->fail_handler(scalar(caller) => @_) if @_; } my %FailHandler; sub fail_handler :method{ shift; # this class my $pkg = shift; my $h = $FailHandler{$pkg}; # old handler if(@_){ # set $FailHandler{$pkg} = Data::Util::code_ref(shift); } else{ # get require MRO::Compat if $] < 5.010_000; require mro if $] >= 5.011_000; foreach my $p(@{mro::get_linear_isa($pkg)}){ if(defined( $h = $FailHandler{$p} )){ last; } } } return $h; } sub croak{ require Carp; my $caller_pkg; my $i = 0; while( defined( $caller_pkg = caller $i) ){ if($caller_pkg ne 'Data::Util'){ last; } $i++; } my $fail_handler = __PACKAGE__->fail_handler($caller_pkg); local $Carp::CarpLevel = $Carp::CarpLevel + $i; die $fail_handler ? &{$fail_handler} : &Carp::longmess; } 1; __END__ =head1 NAME Data::Util::Error - Deals with class-specific error handlers in Data::Util =head1 SYNOPSIS package Foo; use Data::Util::Error sub{ Foo::InvalidArgument->throw_error(@_) }; use Data::Util qw(:validate); sub f{ my $x_ref = array_ref shift; # Foo::InvalidArgument is thrown if invalid # ... } =head1 Functions =over 4 =item Data::Util::Error->fail_handler() =item Data::Util::Error->fail_handler($handler) =item Data::Util::Error::croak(@args) =back =head1 SEE ALSO L. =cut Data-Util-0.63/lib/Data/Util/JA.pod000644 000765 000024 00000055323 12305724254 016523 0ustar00gfxstaff000000 000000 =encoding utf-8 =head1 NAME Data::Util::JA - データとデータ型のためのユーティリティ集 =head1 VERSION This document describes Data::Util version 0.63 =for test_synopsis no warnings 'redefine'; =head1 SYNOPSIS use Data::Util qw(:validate); sub foo{ # they will die if invalid values are supplied my $sref = scalar_ref(shift); my $aref = array_ref(shift); my $href = hash_ref(shift); my $cref = code_ref(shift); my $gref = glob_ref(shift); my $rref = regex_ref(shift); my $obj = instance(shift, 'Foo'); # ... } use Data::Util qw(:check); sub bar{ my $x = shift; if(is_scalar_ref $x){ # $x is an array reference } # ... elsif(is_instance $x, 'Foo'){ # $x is an instance of Foo } # ... } # miscelaneous use Data::Util qw(:all); my $x = anon_scalar(); $x = anon_scalar($x); # OK my $stash = get_stash('Foo'); install_subroutine('Foo', hello => sub{ "Hello!\n" }, goodby => sub{ "Goodby!\n" }, ); print Foo::hello(); # Hello! my($pkg, $name) = get_code_info(\&Foo::hello); # => ('Foo', 'hello') my $fqn = get_code_info(\&Foo::hello); # => 'Foo::Hello' my $code = get_code_ref($fqn); # => \&Foo::hello uninstall_subroutine('Foo', qw(hello goodby)); print neat("Hello!\n"); # => "Hello!\n" print neat(3.14); # => 3.14 print neat(undef); # => undef =head1 DESCRIPTION このモジュールはデータとデータ型のためのユーティリティ関数を提供します。 ユーティリティはチェック関数群と検証関数群とその他の関数群があります。 チェック関数群は値の型を調べ，真偽値を返す機能を提供します。 検証関数群は値の型を調べ，真であればその値自身を返し， 偽であれば致命的エラーとなる機能を提供します。 その他の関数群は，無名スカラーリファレンスの生成やシンボルテーブルの操作， コードリファレンスの操作などの機能を提供します。 これらユーティリティはいずれもコードの繰り返しを避けるために設計されました。 このモジュールはXSとPure Perl双方で実装されており，Cコンパイラのある 環境ではXSバックエンドが，ない環境ではPure Perlバックエンドが使用されます。 なお，環境変数Cを真に設定することで，強制的にPure Perl バックエンドを使用することができます。 XSバックエンドは注意深く実装されており， Pure Perlバックエンドより2倍から10倍程度高速に動作します。 実際，XSバックエンドが提供するほぼ全ての関数は，等価のPure Perlコードを インラインで展開したコードよりも更に高速です。 ディストリビューションのFディレクトリにベンチマークがあります。 =head1 INTERFACE =head2 Check functions チェック関数群はC<:check>インポートタグによって導入できます。これらはある値 の型が目的の型であれば真を，そうでなければ偽を返します。 また，これらの関数はオーバーロードマジックも調べます。たとえば，C<${}>が オーバーロードされているオブジェクトは，スカラーリファレンスとして扱われます。 リファレンスの型チェックをする関数は，オブジェクトリファレンスに対しては， オーバーロードされていない限り常に偽を返します。 これは，オブジェクトの実装に依存するコードを書かないようにするためです。 =over 4 =item is_scalar_ref(value) スカラーリファレンスかどうかのチェックを行います。 =item is_array_ref(value) 配列リファレンスかどうかのチェックを行います。 =item is_hash_ref(value) ハッシュリファレンスかどうかのチェックを行います。 =item is_code_ref(value) コードリファレンスかどうかのチェックを行います。 =item is_glob_ref(value) グロブリファレンスかどうかのチェックを行います。 =item is_regex_ref(value) Cによって作られる正規表現かどうかのチェックを行います。 =item is_instance(value, class) Iのインスタンスかどうかのチェックを行います。 C<< Scalar::Util::blessed($value) && $value->isa($class) >>というコードと ほぼ等価です。 Iが未定義値またはリファレンスであれば致命的エラーとなります。 =item is_invocant(value) Iに対してメソッドを起動できるかどうかをチェックします。 =item is_value(value) Iがプリミティブ値かどうかをチェックします。すなわち，定義済みであり， リファレンスではなく，型グロブでもなければ真を返します。 この関数(およびC/C/C)は， オブジェクトリファレンスに対しては常に偽を返します。 たとえIが文字列化/数値化/真偽値化オーバーロードメソッドを 持っていたとしても，それはプリミティブ値としては判断しません。 この関数には検証を行う対応関数がありません。 =item is_string(value) Iがプリミティブ値であり， かつ文字列化したときに1文字以上の内容を持つ値かどうかをチェックします。 C<< do{ is_value($value) && length($value) > 0 } >>と同じです。 この関数には検証を行う対応関数がありません。 =item is_number(value) Iが数値かどうかをチェックします。 ここでB<数値>とは，数値コンテキスト(たとえばC<< sprintf '%g', $value >>） で警告を出さずに数値に変換可能であり， かつPerlプログラム中にリテラルとしておくことができる値という意味です。 すなわち，この関数はCと異なり， CやCはリテラルとしてプログラム中に置くことはできないため， 数値として扱いません。また，数値化したときに警告を出さない例外である C<"0 but true">も同じ理由で数値として扱いません。 この関数には検証を行う対応関数がありません。 =item is_integer(value) Iが整数かどうかをチェックします。これはCの判定に加えて， 整数値かどうかをチェックします。 この関数には検証を行う対応関数がありません。 =back =head2 Validating functions 検証関数はC<:validate>タグによって導入できます。これらはチェック関数と 同じ方法でチェックを行います。 ただし，その結果が真であれば第一引数をそのまま返し， 偽であれば致命的エラーとなります。 これらの関数もオーバーロードマジックを考慮します。 =over 4 =item scalar_ref(value) スカラーリファレンスかどうかの検証を行います。 =item array_ref(value) 配列リファレンスかどうかの検証を行います。 =item hash_ref(value) ハッシュリファレンスかどうかの検証を行います。 =item code_ref(value) コードリファレンスかどうかの検証を行います。 =item glob_ref(value) グロブリファレンスかどうかの検証を行います。 =item regex_ref(value) Cによって作られる正規表現かどうかの検証を行います。 =item instance(value, class) Iのインスタンスかどうかの検証を行います。 Iが未定義値またはリファレンスであれば致命的エラーとなります。 =item invocant(value) Iに対してメソッドを起動できるかどうかの検証を行います。 Iがクラス名である場合，そのクラス名を正規化した文字列を返します。 すなわち，C<"::Foo">やC<"main::Foo">を与えるとC<"Foo">を返します。 =back =head2 Micellaneous utilities その他，個別にインポートできるいくつかのユーティリティ関数があります。 =over 4 =item anon_scalar() Cを参照する匿名スカラーリファレンスを生成します。 =item anon_scalar(value) Iのコピーを参照する匿名スカラーリファレンスを生成します。 これはC<< do{ my $tmp = $value; \$value; } >>というコードと等価です。 =item neat(value) Iを表示に適するよう整形した文字列を返します。 C<< do{ defined($value) ? qq{"$value"} : 'undef' } >>を置き換える機能 として提供されますが，より高機能です。 =item get_stash(invocant) Iのスタッシュ B，つまりシンボルテーブルハッシュが 存在すれば，そのスタッシュを返します。 Iがオブジェクトリファレンスであれば，そのオブジェクトのパッケージの スタッシュを返します。 Iがパッケージ名であり，そのパッケージが既に存在すれば， そのパッケージのスタッシュを返します。 =item install_subroutine(package, name => subr [, ...]) サブルーチンIをIにIとしてインストールします。 C<< do{ no strict 'refs'; *{$package.'::'.$name} = \&subr; } >>というコードと ほぼ等価です。さらに，Iが匿名サブルーチンであれば，Iに 名前付きサブルーチンI<&package::name>として命名します(ただし，Pure Perl版のコードでは匿名サブルーチンの命名は行いません)。 サブルーチンを再インストールするときは，C<< no warnings 'redefine' >> ディレクティブを使ってください。 no warnings 'redefine'; install_subrouitne($package, $name => $subr); IかIが未定義値またはリファレンスであれば致命的エラーとなります。 Iがコードリファレンスでないときも致命的エラーとなりますが， オーバーロードマジックは考慮されます。 この関数はC<< no strict 'refs' >>を必要としないため，Bを犯す危険性がありません。strict無効化の誤謬とは，以下のような状況を指します。 my $property = ...; # ... no strict 'refs'; # simple read-only accessor *{$pkg . '::' . $sub_name} = sub{ my($self) = @_; return $self->{$property}; } これはオブジェクトのプロパティを参照するアクセサを生成するコードです。このアクセサは，正しく使う限りでは問題はありません。 しかし，このアクセサをクラスメソッドとして呼び出すと，問題が顕在化します。 つまりそのときC<$self>に入っているのはクラスを表す文字列であり， C<< $self->{$property} >>というコードはシンボリックリファレンスと解釈され， このアクセサが定義されたパッケージのグローバル変数としてデリファレンスされます。 これは多くの場合，単にCを返すだけでしょう。 C<>はまさにこのような誤ったシンボリックリファレンスの デリファレンスを検出するために用意されている機能なのですが，ここではその恩恵を 得ることができず，デバッグの難しいコードを生成してしまいます。 このケースでstrictの恩恵を得るためには，以下のように無名関数内で再度 Cを有効にする必要があります。 no strict 'refs'; *{$pkg . '::' . $sub_name} = sub{ use strict 'refs'; my($self) = @_; return $self->{$property}; } そこで，Cを使うともCを使用する必要がなくなります。 install_subroutine $pkg => ( $sub_name => sub{ my($self) = @_; return $self->{$property}; }, ); このstrict無効化の誤謬については，L<"Perlベストプラクティス"/18.10> I<「制約の無効化 - 制約または警告を無効にする場合は，明示的に，段階的に，最も狭いスコープで行う」> に解説があります。 =item uninstall_subroutine(package, name [=> code], ...) サブルーチンIをパッケージIから削除します。 C<< undef &subr >>がC<&subr>を未定義にして型グロブのコードスロットを そのままにするのに対して，Cは型グロブを シンボルテーブルから削除し，コードスロットを以外の値をシンボルテーブルに 戻します。 この挙動はCやCを実現するためのものです。 Iに対してIが与えられている場合は，C<&package::name>がIである 場合のみ削除します。すなわち，以下の二つのコードは等価です。 uninstall_subroutine($pkg, $name) if \&{$pkg . '::' . $name} == $code; uninstall_subroutine($pkg, $name => $code); この関数はCと同じアルゴリズムに基づいていますが， 複数のサブルーチンを一度に削除できます。 =item get_code_info(subr) サブルーチンIのパッケージと名前のペアを返します。 これはCとほぼ同じ機能です。 ただし，スカラーコンテキストでは完全修飾名を返します。 Iの名前が不明なときは，リストコンテキストでは空リストを， スカラーコンテキストではCを返します。 =item get_code_ref(package, name) I<\&package::name>が存在すれば，それを返します。 これはC<< do{ no strict 'refs'; *{$package . '::' . $name}{CODE} } >> に似ていますが，I<\&package::name>が存在しない場合でも I<*package::name>を生成しません。 第三引数としてC<"-create">を与えると，I<\&package::name>が存在しなくても スタブを生成してそれを返します。 これはC<< do{ no strict 'refs'; \&{$package . '::' . $name} } >>と同じです。 =item curry(subr, args and/or placeholders) サブルーチンIのカリー化を行います。 つまり特定の引数を固定したクロージャを生成します。 Iには，固定する引数か，カリー化サブルーチンの引数に 置き換えられるプレースホルダを渡します。プレースホルダには，添え字Iを参照 するC<\x>と，C<\x>で参照した最大の添え字の以降の引数リストを参照する C<*_>があります。 たとえば，以下のC<$closure>とC<$curried>は同じ機能を持つサブルーチンとなります。 my $class = 'Foo'; $closure = sub{ is_instance($_[0], $class) }; $curried = curry \&is_instance, \0, $class; $closure = sub{ install_subroutine($class, @_) }; $curried = curry \&install_subroutine, $class, *_; なお，C<*_>はC<\x>で参照しなかった引数リストではないので注意してください。 たとえば，C<< curry(\&subr, *_, \1)->(0, 1, 2, 3) >>というカリー化では， Cが呼び出され，カリー化されたサブルーチンに与えられた C<$_[0]>(つまり0)が無視されます。 カリー化はクロージャよりも生成・呼び出しが高速です。 より詳しいサンプルコードがLにあります。 =item modify_subroutine(subr, modifier_type => [subroutines], ...) サブルーチンIをIにしたがってIで修飾し， 無名関数Iとして返します。 IにはC, C, Cがあり，Cは Iの呼び出し前に，CはIの呼出し後に，Iに 与えられた引数で呼び出されます。CとCの戻り値は捨てられます。 CはIの入出力をフィルタリングするための修飾子です。 その際，呼び出順は，CとCは後で定義されたものが先に呼び出され (last-defined-first-called)，Cは先に定義されたものが先に呼び出されます(first-defined-first-called)。この呼び出し順はCでも同じ です。 たとえば： $modified = modify_subroutine(\&foo, around => [sub{ my $next = shift; do_something(); goto &{$next}; # continuation }]); $modified->(); $modified = modify_subroutine(\&foo, before => \@befores, around => \@arounds, after => \@afters, ); $modified->(); XSによる実装では，サブルーチン修飾子のコストが非常に安くなっています。 このディストリビューションに付属しているF (C/Cのデモ)のベンチマーク Fによれば，メソッド修飾のコストはほぼ次のようになります： with before modifier: 100% slower with after modifier: 100% slower with around modifier: 200% slower 特に，CとCはC疑似クラスによってメソッドを拡張するよりも高速です。 各修飾子については，Lに 詳しい解説があります。Lにも解説があります。 このモジュールが提供するAPIはこれらのモジュールより低水準ですが， 機能には互換性があります。 =item subroutine_modifier(modified, modifier_type => subroutines, ...) Cで生成したIを操作します。 引数をIのみ渡した場合は，そのIがCで 生成されたものかどうかを示す真偽値を返します。 if(subroutine_modifier $subr){ # $subrは修飾子つきサブルーチン } IとI(C, C, C) を渡すと，そのIに応じた修飾関数を返します。 @befores = subroutine_modifier $modified, 'before'; このほか，更に関数のリストを渡した場合には，IのIに その関数を追加します。 subroutine_modifier $modified, before => @befores; =item mkopt(input, moniker, require_unique, must_be) Iを元に名前と値のペア配列からなる配列リファレンスを作成します。 これはCに似ています。それに加えて，Iは 名前と型のペアからなるハッシュリファレンスでもかまいません。 For example: $array_ref = mkopt([qw(foo bar), baz => [42]], 'moniker'); # $array_ref == [ [foo => undef], [bar => undef], baz => [42] ] =item mkopt_hash(input, moniker, must_be) Iを元にハッシュリファレンスを作成します。 これはCに似ています。それに加えて，Iは 名前と型のペアからなるハッシュリファレンスでもかまいません。 For example: $hash_ref = mkopt([qw(foo bar), baz => [42]], 'moniker'); # $hash_ref == { foo => undef, bar => undef, baz => [42] } =back =head2 Error handling 検証関数によって放出される致命的エラーは，Cモジュールによって変更することができます。 package Foo; use Data::Util::Error sub{ Foo::InvalidArgument->throw(@_) }; use Data::Util qw(:validate); # ... このエラーハンドラはパッケージ毎に設定され，そのパッケージ内でCが発生させるエラーにはそのエラーハンドラが使われます。 =head1 DISCUSSIONS =head1 What is a X-reference? 「Xのリファレンス」とは何を指すのでしょうか。ここではハッシュリファレンスを例にとって考えます。 まず，判断要素は以下の3つを想定します。 =over 4 =item 1 C =item 2 C =item 3 C =back Cは非常に高速なので，実用上はこれで事足りることが多いと思われます。しかし，これはオーバーロードマジックを考慮しません。 Cを使うべきではありません。$xがオブジェクトである場合，オブジェクトの実装型を参照し，カプセル化を壊してしまうことになるからです。 そしてCが捕捉するのは，オブジェクトをある型のリファレンスとみなしてよい特殊なケースです。 なお，直接$xをハッシュリファレンスとみなして参照すること(C<< $x->{$key} >>)は避けるべきです。これは$xがハッシュリファレンスでない場合に正しく致命的エラーを発生させますが，ブレスされたハッシュリファレンスのときにはアクセスが成功します。しかし，そのアクセスの成功はオブジェクトの実装に依存しています。 さて，それではCは何を調べればいいのでしょうか。回答の一つはCが示しています。Version 0.35の時点では，Cは(1)を，Cは(2)と(3)をチェックします。しかし先に述べたように，(1)は高速ですがオーバーロードマジックを考慮しないので不完全であり，(2)はオブジェクトのカプセル化を壊すため使うべきではありません。このように考えると，Cは(1)と(3)によるチェックを行うのが正しい実装ということになります。 したがって，CではCとCを使ってリファレンスの型を調べます。C，C，C，Cも同様です。 =head1 ENVIRONMENT VARIABLES =head2 DATA_UTIL_PUREPERL 真であれば，Pure Perl版のバックエンドが使われます。 =head1 DEPENDENCIES Perl 5.8.1 or later. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to the author. =head1 SEE ALSO L. L. L. このモジュールのいくつかの機能は以下のモジュールの機能をXSに移植して 最適化したものであり，またいくつかはそれに加えて更に拡張を施したものです。 L. L. L. L. L. L. L. =head1 AUTHOR Goro Fuji (gfx) Egfuji(at)cpan.orgE =head1 LICENSE AND COPYRIGHT Copyright (c) 2008-2009, Goro Fuji (gfx) Egfuji(at)cpan.orgE. Some rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Data-Util-0.63/lib/Data/Util/PurePerl.pm000644 000765 000024 00000030576 12040510404 017606 0ustar00gfxstaff000000 000000 package Data::Util::PurePerl; die qq{Don't use Data::Util::PurePerl directly, use Data::Util instead.\n} # ' for poor editors if caller() ne 'Data::Util'; package Data::Util; use strict; use warnings; #use warnings::unused; use Scalar::Util (); use overload (); sub _croak{ require Data::Util::Error; goto &Data::Util::Error::croak; } sub _fail{ my($name, $value) = @_; _croak(sprintf 'Validation failed: you must supply %s, not %s', $name, neat($value)); } sub _overloaded{ return Scalar::Util::blessed($_[0]) && overload::Method($_[0], $_[1]); } sub is_scalar_ref{ return ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' || _overloaded($_[0], '${}'); } sub is_array_ref{ return ref($_[0]) eq 'ARRAY' || _overloaded($_[0], '@{}'); } sub is_hash_ref{ return ref($_[0]) eq 'HASH' || _overloaded($_[0], '%{}'); } sub is_code_ref{ return ref($_[0]) eq 'CODE' || _overloaded($_[0], '&{}'); } sub is_glob_ref{ return ref($_[0]) eq 'GLOB' || _overloaded($_[0], '*{}'); } sub is_regex_ref{ return ref($_[0]) eq 'Regexp'; } sub is_rx{ return ref($_[0]) eq 'Regexp'; } sub is_instance{ my($obj, $class) = @_; _fail('a class name', $class) unless is_string($class); return Scalar::Util::blessed($obj) && $obj->isa($class); } sub is_invocant{ my($x) = @_; if(ref $x){ return !!Scalar::Util::blessed($x); } else{ return !!get_stash($x); } } sub scalar_ref{ return ref($_[0]) eq 'SCALAR' || ref($_[0]) eq 'REF' || _overloaded($_[0], '${}') ? $_[0] : _fail('a SCALAR reference', $_[0]); } sub array_ref{ return ref($_[0]) eq 'ARRAY' || _overloaded($_[0], '@{}') ? $_[0] : _fail('an ARRAY reference', $_[0]); } sub hash_ref{ return ref($_[0]) eq 'HASH' || _overloaded($_[0], '%{}') ? $_[0] : _fail('a HASH reference', $_[0]); } sub code_ref{ return ref($_[0]) eq 'CODE' || _overloaded($_[0], '&{}') ? $_[0] : _fail('a CODE reference', $_[0]); } sub glob_ref{ return ref($_[0]) eq 'GLOB' || _overloaded($_[0], '*{}') ? $_[0] : _fail('a GLOB reference', $_[0]); } sub regex_ref{ return ref($_[0]) eq 'Regexp' ? $_[0] : _fail('a regular expression reference', $_[0]); } sub rx{ return ref($_[0]) eq 'Regexp' ? $_[0] : _fail('a regular expression reference', $_[0]); } sub instance{ my($obj, $class) = @_; _fail('a class name', $class) unless is_string($class); return Scalar::Util::blessed($obj) && $obj->isa($class) ? $obj : _fail("an instance of $class", $obj); } sub invocant{ my($x) = @_; if(ref $x){ if(Scalar::Util::blessed($x)){ return $x; } } elsif(is_string($x)){ if(get_stash($x)){ $x =~ s/^:://; $x =~ s/(?:main::)+//; return $x; } } _fail('an invocant', $x); } sub is_value{ return defined($_[0]) && !ref($_[0]) && ref(\$_[0]) ne 'GLOB'; } sub is_string{ no warnings 'uninitialized'; return !ref($_[0]) && ref(\$_[0]) ne 'GLOB' && length($_[0]) > 0; } sub is_number{ return 0 if !defined($_[0]) || ref($_[0]); return $_[0] =~ m{ \A \s* [+-]? (?= \d | \.\d) \d* (\.\d*)? (?: [Ee] (?: [+-]? \d+) )? \s* \z }xms; } sub is_integer{ return 0 if !defined($_[0]) || ref($_[0]); return $_[0] =~ m{ \A \s* [+-]? \d+ \s* \z }xms; } sub get_stash{ my($invocant) = @_; if(Scalar::Util::blessed($invocant)){ no strict 'refs'; return \%{ref($invocant) . '::'}; } elsif(!is_string($invocant)){ return undef; } $invocant =~ s/^:://; my $pack = *main::; foreach my $part(split /::/, $invocant){ return undef unless $pack = $pack->{$part . '::'}; } return *{$pack}{HASH}; } sub anon_scalar{ my($s) = @_; return \$s; # not \$_[0] } sub neat{ my($s) = @_; if(ref $s){ if(ref($s) eq 'CODE'){ return sprintf '\\&%s(0x%x)', scalar(get_code_info($s)), Scalar::Util::refaddr($s); } elsif(ref($s) eq 'Regexp'){ return qq{qr{$s}}; } return overload::StrVal($s); } elsif(defined $s){ return "$s" if is_number($s); return "$s" if is_glob_ref(\$s); require B; return B::perlstring($s); } else{ return 'undef'; } } sub install_subroutine{ _croak('Usage: install_subroutine(package, name => code, ...)') unless @_; my $into = shift; is_string($into) or _fail('a package name', $into); my $param = mkopt_hash(@_ == 1 ? shift : \@_, 'install_subroutine', 'CODE'); while(my($as, $code) = each %{$param}){ defined($code) or _fail('a CODE reference', $code); my $slot = do{ no strict 'refs'; \*{ $into . '::' . $as } }; if(defined &{$slot}){ warnings::warnif(redefine => "Subroutine $as redefined"); } no warnings 'redefine'; *{$slot} = \&{$code}; } return; } sub uninstall_subroutine { _croak('Usage: uninstall_subroutine(package, name, ...)') unless @_; my $package = shift; is_string($package) or _fail('a package name', $package); my $stash = get_stash($package) or return 0; my $param = mkopt_hash(@_ == 1 && is_hash_ref($_[0]) ? shift : \@_, 'install_subroutine', 'CODE'); require B; while(my($name, $specified_code) = each %{$param}){ my $glob = $stash->{$name}; if(ref(\$glob) ne 'GLOB'){ if(ref $glob){ warnings::warnif(misc => "Constant subroutine $name uninstalled"); } delete $stash->{$name}; next; } my $code = *{$glob}{CODE}; if(not defined $code){ next; } if(defined $specified_code && $specified_code != $code){ next; } if(B::svref_2object($code)->CONST){ warnings::warnif(misc => "Constant subroutine $name uninstalled"); } delete $stash->{$name}; my $newglob = do{ no strict 'refs'; \*{$package . '::' . $name} }; # vivify # copy all the slot except for CODE foreach my $slot( qw(SCALAR ARRAY HASH IO FORMAT) ){ *{$newglob} = *{$glob}{$slot} if defined *{$glob}{$slot}; } } return; } sub get_code_info{ my($code) = @_; is_code_ref($code) or _fail('a CODE reference', $code); require B; my $gv = B::svref_2object(\&{$code})->GV; return unless $gv->isa('B::GV'); return wantarray ? ($gv->STASH->NAME, $gv->NAME) : join('::', $gv->STASH->NAME, $gv->NAME); } sub get_code_ref{ my($package, $name, @flags) = @_; is_string($package) or _fail('a package name', $package); is_string($name) or _fail('a subroutine name', $name); if(@flags){ if(grep{ $_ eq '-create' } @flags){ no strict 'refs'; return \&{$package . '::' . $name}; } else{ _fail('a flag', @flags); } } my $stash = get_stash($package) or return undef; if(defined(my $glob = $stash->{$name})){ if(ref(\$glob) eq 'GLOB'){ return *{$glob}{CODE}; } else{ # a stub or special constant no strict 'refs'; return *{$package . '::' . $name}{CODE}; } } return undef; } sub curry{ my $is_method = !is_code_ref($_[0]); my $proc; $proc = shift if !$is_method; my $args = \@_; my @tmpl; my $i = 0; my $max_ph = -1; my $min_ph = 0; foreach my $arg(@_){ if(is_scalar_ref($arg) && is_integer($$arg)){ push @tmpl, sprintf '$_[%d]', $$arg; if($$arg >= 0){ $max_ph = $$arg if $$arg > $max_ph; } else{ $min_ph = $$arg if $$arg < $min_ph; } } elsif(defined($arg) && (\$arg) == \*_){ push @tmpl, '@_[$max_ph .. $#_ + $min_ph]'; } else{ push @tmpl, sprintf '$args->[%d]', $i; } $i++; } $max_ph++; my($pkg, $file, $line, $hints, $bitmask) = (caller 0 )[0, 1, 2, 8, 9]; my $body = sprintf <<'END_CXT', $pkg, $line, $file; BEGIN{ $^H = $hints; ${^WARNING_BITS} = $bitmask; } package %s; #line %s %s END_CXT if($is_method){ my $selfp = shift @tmpl; $proc = shift @tmpl; $body .= sprintf q{ sub { my $self = %s; my $method = %s; $self->$method(%s); } }, $selfp, defined($proc) ? $proc : 'undef', join(q{,}, @tmpl); } else{ $body .= sprintf q{ sub { $proc->(%s) } }, join q{,}, @tmpl; } eval $body or die $@; } BEGIN{ our %modifiers; my $initializer; $initializer = sub{ require Hash::Util::FieldHash::Compat; Hash::Util::FieldHash::Compat::fieldhash(\%modifiers); undef $initializer; }; sub modify_subroutine{ my $code = code_ref shift; if((@_ % 2) != 0){ _croak('Odd number of arguments for modify_subroutine()'); } my %args = @_; my(@before, @around, @after); @before = map{ code_ref $_ } @{array_ref delete $args{before}} if exists $args{before}; @around = map{ code_ref $_ } @{array_ref delete $args{around}} if exists $args{around}; @after = map{ code_ref $_ } @{array_ref delete $args{after}} if exists $args{after}; if(%args){ _fail('a modifier property', join ', ', keys %args); } my %props = ( before => \@before, around => \@around, after => \@after, current_ref => \$code, ); #$code = curry($_, (my $tmp = $code), *_) for @around; for my $ar_code(reverse @around){ my $next = $code; $code = sub{ $ar_code->($next, @_) }; } my($pkg, $file, $line, $hints, $bitmask) = (caller 0)[0, 1, 2, 8, 9]; my $context = sprintf <<'END_CXT', $pkg, $line, $file; BEGIN{ $^H = $hints; ${^WARNING_BITS} = $bitmask; } package %s; #line %s %s(modify_subroutine) END_CXT my $modified = eval $context . q{sub{ $_->(@_) for @before; if(wantarray){ # list context my @ret = $code->(@_); $_->(@_) for @after; return @ret; } elsif(defined wantarray){ # scalar context my $ret = $code->(@_); $_->(@_) for @after; return $ret; } else{ # void context $code->(@_); $_->(@_) for @after; return; } }} or die $@; $initializer->() if $initializer; $modifiers{$modified} = \%props; return $modified; } my %valid_modifiers = map{ $_ => undef } qw(before around after); sub subroutine_modifier{ my $modified = code_ref shift; my $props_ref = $modifiers{$modified}; unless(@_){ # subroutine_modifier($subr) - only checking return defined $props_ref; } unless($props_ref){ # otherwise, it should be modified subroutines _fail('a modified subroutine', $modified); } my($name, @subs) = @_; (is_string($name) && exists $valid_modifiers{$name}) or _fail('a modifier property', $name); my $property = $props_ref->{$name}; if(@subs){ if($name eq 'after'){ push @{$property}, map{ code_ref $_ } @subs; } else{ unshift @{$property}, reverse map{ code_ref $_ } @subs; } if($name eq 'around'){ my $current_ref = $props_ref->{current_ref}; for my $ar(reverse @subs){ my $base = $$current_ref; $$current_ref = sub{ $ar->($base, @_) }; } } } return @{$property} if defined wantarray; return; } } # # mkopt() and mkopt_hash() are originated from Data::OptList # my %test_for = ( CODE => \&is_code_ref, HASH => \&is_hash_ref, ARRAY => \&is_array_ref, SCALAR => \&is_scalar_ref, GLOB => \&is_glob_ref, ); sub __is_a { my ($got, $expected) = @_; return scalar grep{ __is_a($got, $_) } @{$expected} if ref $expected; my $t = $test_for{$expected}; return defined($t) ? $t->($got) : is_instance($got, $expected); } sub mkopt{ my($opt_list, $moniker, $require_unique, $must_be) = @_; return [] unless defined $opt_list; $opt_list = [ map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list ] if is_hash_ref($opt_list); is_array_ref($opt_list) or _fail('an ARRAY or HASH reference', $opt_list); my @return; my %seen; my $vh = is_hash_ref($must_be); my $validator = $must_be; if(defined($validator) && (!$vh && !is_array_ref($validator) && !is_string($validator))){ _fail('a type name, or ARRAY or HASH reference', $validator); } for(my $i = 0; $i < @$opt_list; $i++) { my $name = $opt_list->[$i]; my $value; is_string($name) or _fail("a name in $moniker opt list", $name); if($require_unique && $seen{$name}++) { _croak("Validation failed: Multiple definitions provided for $name in $moniker opt list") } if ($i == $#$opt_list) { $value = undef; } elsif(not defined $opt_list->[$i+1]) { $value = undef; $i++ } elsif(ref $opt_list->[$i+1]) { $value = $opt_list->[++$i] } else { $value = undef; } if (defined $value and defined( $vh ? ($validator = $must_be->{$name}) : $validator )){ unless(__is_a($value, $validator)) { _croak("Validation failed: ".ref($value)."-ref values are not valid for $name in $moniker opt list"); } } push @return, [ $name => $value ]; } return \@return; } sub mkopt_hash { my($opt_list, $moniker, $must_be) = @_; return {} unless $opt_list; my %hash = map { $_->[0] => $_->[1] } @{ mkopt($opt_list, $moniker, 1, $must_be) }; return \%hash; } 1; __END__ =head1 NAME Data::Util::PurePerl - The Pure Perl backend for Data::Util =head1 DESCRIPTION This module is a backend for C. Don't use this module directly; C instead. =cut Data-Util-0.63/inc/Module/000755 000765 000024 00000000000 12305724300 015147 5ustar00gfxstaff000000 000000 Data-Util-0.63/inc/Module/Install/000755 000765 000024 00000000000 12305724300 016555 5ustar00gfxstaff000000 000000 Data-Util-0.63/inc/Module/Install.pm000644 000765 000024 00000030135 12305724276 017131 0ustar00gfxstaff000000 000000 #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. Data-Util-0.63/inc/Module/Install/AuthorTests.pm000644 000765 000024 00000002215 12305724276 021414 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; Data-Util-0.63/inc/Module/Install/Base.pm000644 000765 000024 00000002147 12305724276 020005 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Data-Util-0.63/inc/Module/Install/Can.pm000644 000765 000024 00000006157 12305724276 017641 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 Data-Util-0.63/inc/Module/Install/Makefile.pm000644 000765 000024 00000027437 12305724276 020661 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 Data-Util-0.63/inc/Module/Install/Metadata.pm000644 000765 000024 00000043277 12305724276 020664 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Data-Util-0.63/inc/Module/Install/Repository.pm000644 000765 000024 00000004256 12305724277 021316 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 Data-Util-0.63/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 12305724277 020663 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Data-Util-0.63/inc/Module/Install/XSUtil.pm000644 000765 000024 00000045703 12305724276 020330 0ustar00gfxstaff000000 000000 #line 1 package Module::Install::XSUtil; use 5.005_03; $VERSION = '0.45'; use Module::Install::Base; @ISA = qw(Module::Install::Base); use strict; use Config; use File::Spec; use File::Find; use constant _VERBOSE => $ENV{MI_VERBOSE} ? 1 : 0; my %ConfigureRequires = ( 'ExtUtils::ParseXS' => 3.18, # shipped with Perl 5.18.0 ); my %BuildRequires = ( ); my %Requires = ( 'XSLoader' => 0.02, ); my %ToInstall; my $UseC99 = 0; my $UseCplusplus = 0; sub _verbose{ print STDERR q{# }, @_, "\n"; } sub _xs_debugging{ return $ENV{XS_DEBUG} || scalar( grep{ $_ eq '-g' } @ARGV ); } sub _xs_initialize{ my($self) = @_; unless($self->{xsu_initialized}){ $self->{xsu_initialized} = 1; if(!$self->cc_available()){ warn "This distribution requires a C compiler, but it's not available, stopped.\n"; exit; } $self->configure_requires(%ConfigureRequires); $self->build_requires(%BuildRequires); $self->requires(%Requires); $self->makemaker_args->{OBJECT} = '$(O_FILES)'; $self->clean_files('$(O_FILES)'); $self->clean_files('*.stackdump') if $^O eq 'cygwin'; if($self->_xs_debugging()){ # override $Config{optimize} if(_is_msvc()){ $self->makemaker_args->{OPTIMIZE} = '-Zi'; } else{ $self->makemaker_args->{OPTIMIZE} = '-g -ggdb -g3'; } $self->cc_define('-DXS_ASSERT'); } } return; } # GNU C Compiler sub _is_gcc{ return $Config{gccversion}; } # Microsoft Visual C++ Compiler (cl.exe) sub _is_msvc{ return $Config{cc} =~ /\A cl \b /xmsi; } { my $cc_available; sub cc_available { return defined $cc_available ? $cc_available : ($cc_available = shift->can_cc()) ; } # cf. https://github.com/sjn/toolchain-site/blob/219db464af9b2f19b04fec05547ac10180a469f3/lancaster-consensus.md my $want_xs; sub want_xs { my($self, $default) = @_; return $want_xs if defined $want_xs; # you're using this module, you must want XS by default # unless PERL_ONLY is true. $default = !$ENV{PERL_ONLY} if not defined $default; foreach my $arg(@ARGV){ my ($k, $v) = split '=', $arg; # MM-style named args if ($k eq 'PUREPERL_ONLY' && defined $v) { return $want_xs = !$v; } elsif($arg eq '--pp'){ # old-style return $want_xs = 0; } elsif($arg eq '--xs'){ return $want_xs = 1; } } if ($ENV{PERL_MM_OPT}) { my($v) = $ENV{PERL_MM_OPT} =~ /\b PUREPERL_ONLY = (\S+) /xms; if (defined $v) { return $want_xs = !$v; } } return $want_xs = $default; } } sub use_ppport{ my($self, $dppp_version) = @_; return if $self->{_ppport_ok}++; $self->_xs_initialize(); my $filename = 'ppport.h'; $dppp_version ||= 3.19; # the more, the better $self->configure_requires('Devel::PPPort' => $dppp_version); $self->build_requires('Devel::PPPort' => $dppp_version); print "Writing $filename\n"; my $e = do{ local $@; eval qq{ use Devel::PPPort; Devel::PPPort::WriteFile(q{$filename}); }; $@; }; if($e){ print "Cannot create $filename because: $@\n"; } if(-e $filename){ $self->clean_files($filename); $self->cc_define('-DUSE_PPPORT'); $self->cc_append_to_inc('.'); } return; } sub use_xshelper { my($self, $opt) = @_; $self->_xs_initialize(); $self->use_ppport(); my $file = 'xshelper.h'; open my $fh, '>', $file or die "Cannot open $file for writing: $!"; print $fh $self->_xshelper_h(); close $fh or die "Cannot close $file: $!"; if(defined $opt) { if($opt eq '-clean') { $self->clean_files($file); } else { $self->realclean_files($file); } } return; } sub _gccversion { my $res = `$Config{cc} --version`; my ($version) = $res =~ /\(GCC\) ([0-9.]+)/; no warnings 'numeric', 'uninitialized'; return sprintf '%g', $version; } sub cc_warnings{ my($self) = @_; $self->_xs_initialize(); if(_is_gcc()){ $self->cc_append_to_ccflags(qw(-Wall)); my $gccversion = _gccversion(); if($gccversion >= 4.0){ $self->cc_append_to_ccflags(qw(-Wextra)); if(!($UseC99 or $UseCplusplus)) { # Note: MSVC++ doesn't support C99, # so -Wdeclaration-after-statement helps # ensure C89 specs. $self->cc_append_to_ccflags(qw(-Wdeclaration-after-statement)); } if($gccversion >= 4.1 && !$UseCplusplus) { $self->cc_append_to_ccflags(qw(-Wc++-compat)); } } else{ $self->cc_append_to_ccflags(qw(-W -Wno-comment)); } } elsif(_is_msvc()){ $self->cc_append_to_ccflags(qw(-W3)); } else{ # TODO: support other compilers } return; } sub c99_available { my($self) = @_; return 0 if not $self->cc_available(); require File::Temp; require File::Basename; my $tmpfile = File::Temp->new(SUFFIX => '.c'); $tmpfile->print(<<'C99'); // include a C99 header #include inline // a C99 keyword with C99 style comments int test_c99() { int i = 0; i++; int j = i - 1; // another C99 feature: declaration after statement return j; } C99 $tmpfile->close(); system "$Config{cc} -c " . $tmpfile->filename; (my $objname = File::Basename::basename($tmpfile->filename)) =~ s/\Q.c\E$/$Config{_o}/; unlink $objname or warn "Cannot unlink $objname (ignored): $!"; return $? == 0; } sub requires_c99 { my($self) = @_; if(!$self->c99_available) { warn "This distribution requires a C99 compiler, but $Config{cc} seems not to support C99, stopped.\n"; exit; } $self->_xs_initialize(); $UseC99 = 1; return; } sub requires_cplusplus { my($self) = @_; if(!$self->cc_available) { warn "This distribution requires a C++ compiler, but $Config{cc} seems not to support C++, stopped.\n"; exit; } $self->_xs_initialize(); $UseCplusplus = 1; return; } sub cc_append_to_inc{ my($self, @dirs) = @_; $self->_xs_initialize(); for my $dir(@dirs){ unless(-d $dir){ warn("'$dir' not found: $!\n"); } _verbose "inc: -I$dir" if _VERBOSE; } my $mm = $self->makemaker_args; my $paths = join q{ }, map{ s{\\}{\\\\}g; qq{"-I$_"} } @dirs; if($mm->{INC}){ $mm->{INC} .= q{ } . $paths; } else{ $mm->{INC} = $paths; } return; } sub cc_libs { my ($self, @libs) = @_; @libs = map{ my($name, $dir) = ref($_) eq 'ARRAY' ? @{$_} : ($_, undef); my $lib; if(defined $dir) { $lib = ($dir =~ /^-/ ? qq{$dir } : qq{-L$dir }); } else { $lib = ''; } $lib .= ($name =~ /^-/ ? qq{$name} : qq{-l$name}); _verbose "libs: $lib" if _VERBOSE; $lib; } @libs; $self->cc_append_to_libs( @libs ); } sub cc_append_to_libs{ my($self, @libs) = @_; $self->_xs_initialize(); return unless @libs; my $libs = join q{ }, @libs; my $mm = $self->makemaker_args; if ($mm->{LIBS}){ $mm->{LIBS} .= q{ } . $libs; } else{ $mm->{LIBS} = $libs; } return $libs; } sub cc_assert_lib { my ($self, @dcl_args) = @_; if ( ! $self->{xsu_loaded_checklib} ) { my $loaded_lib = 0; foreach my $checklib (qw(inc::Devel::CheckLib Devel::CheckLib)) { eval "use $checklib 0.4"; if (!$@) { $loaded_lib = 1; last; } } if (! $loaded_lib) { warn "Devel::CheckLib not found in inc/ nor \@INC"; exit 0; } $self->{xsu_loaded_checklib}++; $self->configure_requires( "Devel::CheckLib" => "0.4" ); $self->build_requires( "Devel::CheckLib" => "0.4" ); } Devel::CheckLib::check_lib_or_exit(@dcl_args); } sub cc_append_to_ccflags{ my($self, @ccflags) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; $mm->{CCFLAGS} ||= $Config{ccflags}; $mm->{CCFLAGS} .= q{ } . join q{ }, @ccflags; return; } sub cc_define{ my($self, @defines) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; if(exists $mm->{DEFINE}){ $mm->{DEFINE} .= q{ } . join q{ }, @defines; } else{ $mm->{DEFINE} = join q{ }, @defines; } return; } sub requires_xs_module { my $self = shift; return $self->requires() unless @_; $self->_xs_initialize(); my %added = $self->requires(@_); my(@inc, @libs); my $rx_lib = qr{ \. (?: lib | a) \z}xmsi; my $rx_dll = qr{ \. dll \z}xmsi; # for Cygwin while(my $module = each %added){ my $mod_basedir = File::Spec->join(split /::/, $module); my $rx_header = qr{\A ( .+ \Q$mod_basedir\E ) .+ \. h(?:pp)? \z}xmsi; SCAN_INC: foreach my $inc_dir(@INC){ my @dirs = grep{ -e } File::Spec->join($inc_dir, 'auto', $mod_basedir), File::Spec->join($inc_dir, $mod_basedir); next SCAN_INC unless @dirs; my $n_inc = scalar @inc; find(sub{ if(my($incdir) = $File::Find::name =~ $rx_header){ push @inc, $incdir; } elsif($File::Find::name =~ $rx_lib){ my($libname) = $_ =~ /\A (?:lib)? (\w+) /xmsi; push @libs, [$libname, $File::Find::dir]; } elsif($File::Find::name =~ $rx_dll){ # XXX: hack for Cygwin my $mm = $self->makemaker_args; $mm->{macro}->{PERL_ARCHIVE_AFTER} ||= ''; $mm->{macro}->{PERL_ARCHIVE_AFTER} .= ' ' . $File::Find::name; } }, @dirs); if($n_inc != scalar @inc){ last SCAN_INC; } } } my %uniq = (); $self->cc_append_to_inc (grep{ !$uniq{ $_ }++ } @inc); %uniq = (); $self->cc_libs(grep{ !$uniq{ $_->[0] }++ } @libs); return %added; } sub cc_src_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); return unless @dirs; my $mm = $self->makemaker_args; my $XS_ref = $mm->{XS} ||= {}; my $C_ref = $mm->{C} ||= []; my $_obj = $Config{_o}; my @src_files; find(sub{ if(/ \. (?: xs | c (?: c | pp | xx )? ) \z/xmsi){ # *.{xs, c, cc, cpp, cxx} push @src_files, $File::Find::name; } }, @dirs); my $xs_to = $UseCplusplus ? '.cpp' : '.c'; foreach my $src_file(@src_files){ my $c = $src_file; if($c =~ s/ \.xs \z/$xs_to/xms){ $XS_ref->{$src_file} = $c; _verbose "xs: $src_file" if _VERBOSE; } else{ _verbose "c: $c" if _VERBOSE; } push @{$C_ref}, $c unless grep{ $_ eq $c } @{$C_ref}; } $self->clean_files(map{ File::Spec->catfile($_, '*.gcov'), File::Spec->catfile($_, '*.gcda'), File::Spec->catfile($_, '*.gcno'), } @dirs); $self->cc_append_to_inc('.'); return; } sub cc_include_paths{ my($self, @dirs) = @_; $self->_xs_initialize(); push @{ $self->{xsu_include_paths} ||= []}, @dirs; my $h_map = $self->{xsu_header_map} ||= {}; foreach my $dir(@dirs){ my $prefix = quotemeta( File::Spec->catfile($dir, '') ); find(sub{ return unless / \.h(?:pp)? \z/xms; (my $h_file = $File::Find::name) =~ s/ \A $prefix //xms; $h_map->{$h_file} = $File::Find::name; }, $dir); } $self->cc_append_to_inc(@dirs); return; } sub install_headers{ my $self = shift; my $h_files; if(@_ == 0){ $h_files = $self->{xsu_header_map} or die "install_headers: cc_include_paths not specified.\n"; } elsif(@_ == 1 && ref($_[0]) eq 'HASH'){ $h_files = $_[0]; } else{ $h_files = +{ map{ $_ => undef } @_ }; } $self->_xs_initialize(); my @not_found; my $h_map = $self->{xsu_header_map} || {}; while(my($ident, $path) = each %{$h_files}){ $path ||= $h_map->{$ident} || File::Spec->join('.', $ident); $path = File::Spec->canonpath($path); unless($path && -e $path){ push @not_found, $ident; next; } $ToInstall{$path} = File::Spec->join('$(INST_ARCHAUTODIR)', $ident); _verbose "install: $path as $ident" if _VERBOSE; my @funcs = $self->_extract_functions_from_header_file($path); if(@funcs){ $self->cc_append_to_funclist(@funcs); } } if(@not_found){ die "Header file(s) not found: @not_found\n"; } return; } my $home_directory; sub _extract_functions_from_header_file{ my($self, $h_file) = @_; my @functions; ($home_directory) = <~> unless defined $home_directory; # get header file contents through cpp(1) my $contents = do { my $mm = $self->makemaker_args; my $cppflags = q{"-I}. File::Spec->join($Config{archlib}, 'CORE') . q{"}; $cppflags =~ s/~/$home_directory/g; $cppflags .= ' ' . $mm->{INC} if $mm->{INC}; $cppflags .= ' ' . ($mm->{CCFLAGS} || $Config{ccflags}); $cppflags .= ' ' . $mm->{DEFINE} if $mm->{DEFINE}; my $add_include = _is_msvc() ? '-FI' : '-include'; $cppflags .= ' ' . join ' ', map{ qq{$add_include "$_"} } qw(EXTERN.h perl.h XSUB.h); my $cppcmd = qq{$Config{cpprun} $cppflags $h_file}; # remove all the -arch options to workaround gcc errors: # "-E, -S, -save-temps and -M options are not allowed # with multiple -arch flags" $cppcmd =~ s/ -arch \s* \S+ //xmsg; _verbose("extract functions from: $cppcmd") if _VERBOSE; `$cppcmd`; }; unless(defined $contents){ die "Cannot call C pre-processor ($Config{cpprun}): $! ($?)"; } # remove other include file contents my $chfile = q/\# (?:line)? \s+ \d+ /; $contents =~ s{ ^$chfile \s+ (?!"\Q$h_file\E") .*? ^(?= $chfile) }{}xmsig; if(_VERBOSE){ local *H; open H, "> $h_file.out" and print H $contents and close H; } while($contents =~ m{ ([^\\;\s]+ # type \s+ ([a-zA-Z_][a-zA-Z0-9_]*) # function name \s* \( [^;#]* \) # argument list [\w\s\(\)]* # attributes or something ;) # end of declaration }xmsg){ my $decl = $1; my $name = $2; next if $decl =~ /\b typedef \b/xms; next if $name =~ /^_/xms; # skip something private push @functions, $name; if(_VERBOSE){ $decl =~ tr/\n\r\t / /s; $decl =~ s/ (\Q$name\E) /<$name>/xms; _verbose("decl: $decl"); } } return @functions; } sub cc_append_to_funclist{ my($self, @functions) = @_; $self->_xs_initialize(); my $mm = $self->makemaker_args; push @{$mm->{FUNCLIST} ||= []}, @functions; $mm->{DL_FUNCS} ||= { '$(NAME)' => [] }; return; } sub _xshelper_h { my $h = <<'XSHELPER_H'; :/* THIS FILE IS AUTOMATICALLY GENERATED BY Module::Install::XSUtil $VERSION. */ :/* :=head1 NAME : :xshelper.h - Helper C header file for XS modules : :=head1 DESCRIPTION : : // This includes all the perl header files and ppport.h : #include "xshelper.h" : :=head1 SEE ALSO : :L, where this file is distributed as a part of : :=head1 AUTHOR : :Fuji, Goro (gfx) Egfuji at cpan.orgE : :=head1 LISENCE : :Copyright (c) 2010, Fuji, Goro (gfx). All rights reserved. : :This library is free software; you can redistribute it and/or modify :it under the same terms as Perl itself. : :=cut :*/ : :#ifdef __cplusplus :extern "C" { :#endif : :#define PERL_NO_GET_CONTEXT /* we want efficiency */ :#include :#include :#define NO_XSLOCKS /* for exceptions */ :#include : :#ifdef __cplusplus :} /* extern "C" */ :#endif : :#include "ppport.h" : :/* portability stuff not supported by ppport.h yet */ : :#ifndef STATIC_INLINE /* from 5.13.4 */ :# if defined(__GNUC__) || defined(__cplusplus) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L)) :# define STATIC_INLINE static inline :# else :# define STATIC_INLINE static :# endif :#endif /* STATIC_INLINE */ : :#ifndef __attribute__format__ :#define __attribute__format__(a,b,c) /* nothing */ :#endif : :#ifndef LIKELY /* they are just a compiler's hint */ :#define LIKELY(x) (!!(x)) :#define UNLIKELY(x) (!!(x)) :#endif : :#ifndef newSVpvs_share :#define newSVpvs_share(s) Perl_newSVpvn_share(aTHX_ STR_WITH_LEN(s), 0U) :#endif : :#ifndef get_cvs :#define get_cvs(name, flags) get_cv(name, flags) :#endif : :#ifndef GvNAME_get :#define GvNAME_get GvNAME :#endif :#ifndef GvNAMELEN_get :#define GvNAMELEN_get GvNAMELEN :#endif : :#ifndef CvGV_set :#define CvGV_set(cv, gv) (CvGV(cv) = (gv)) :#endif : :/* general utility */ : :#if PERL_BCDVERSION >= 0x5008005 :#define LooksLikeNumber(x) looks_like_number(x) :#else :#define LooksLikeNumber(x) (SvPOKp(x) ? looks_like_number(x) : (I32)SvNIOKp(x)) :#endif : :#define newAV_mortal() (AV*)sv_2mortal((SV*)newAV()) :#define newHV_mortal() (HV*)sv_2mortal((SV*)newHV()) :#define newRV_inc_mortal(sv) sv_2mortal(newRV_inc(sv)) :#define newRV_noinc_mortal(sv) sv_2mortal(newRV_noinc(sv)) : :#define DECL_BOOT(name) EXTERN_C XS(CAT2(boot_, name)) :#define CALL_BOOT(name) STMT_START { \ : PUSHMARK(SP); \ : CALL_FPTR(CAT2(boot_, name))(aTHX_ cv); \ : } STMT_END XSHELPER_H $h =~ s/^://xmsg; $h =~ s/\$VERSION\b/$Module::Install::XSUtil::VERSION/xms; return $h; } package MY; # XXX: We must append to PM inside ExtUtils::MakeMaker->new(). sub init_PM { my $self = shift; $self->SUPER::init_PM(@_); while(my($k, $v) = each %ToInstall){ $self->{PM}{$k} = $v; } return; } # append object file names to CCCMD sub const_cccmd { my $self = shift; my $cccmd = $self->SUPER::const_cccmd(@_); return q{} unless $cccmd; if (Module::Install::XSUtil::_is_msvc()){ $cccmd .= ' -Fo$@'; } else { $cccmd .= ' -o $@'; } return $cccmd } sub xs_c { my($self) = @_; my $mm = $self->SUPER::xs_c(); $mm =~ s/ \.c /.cpp/xmsg if $UseCplusplus; return $mm; } sub xs_o { my($self) = @_; my $mm = $self->SUPER::xs_o(); $mm =~ s/ \.c /.cpp/xmsg if $UseCplusplus; return $mm; } 1; __END__ #line 1030 Data-Util-0.63/example/curry.pl000644 000765 000024 00000000726 12040510404 016304 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Data::Util qw(:all); { package Foo; use Data::Dumper; use Data::Util qw(:all); use Carp qw(cluck); install_subroutine(__PACKAGE__, baz => curry(\0, 'bar', x => \1, y => \2, z => \3), ); sub bar{ my($self, %args) = @_; print Dumper \%args; } sub incr{ $_[1]++ } } Foo->baz(10, 20, 30); my $i = 0; install_subroutine __PACKAGE__, incr => curry('Foo', 'incr', *_); for (1 .. 3){ incr($i); print 'incr $i = ', $i, "\n"; } Data-Util-0.63/example/export_lexical.pl000644 000765 000024 00000001162 12040510404 020155 0ustar00gfxstaff000000 000000 #!perl -w use strict; use FindBin qw($Bin); use lib "$Bin/lib"; BEGIN{ package Foo; use feature 'say'; use Sub::Exporter::Lexical # in example/lib/Sub/Exporter/Lexical.pm exports => [qw(foo bar baz), ('A' .. 'Z')], ; sub foo{ say 'foo!' } sub bar{ say 'bar!' } sub baz{ say 'baz!' } $INC{'Foo.pm'} = __FILE__; package Bar; use Exporter qw(import); our @EXPORT = (qw(foo bar baz), ('A' .. 'Z')); sub foo{} sub bar{} sub baz{} $INC{'Bar.pm'} = __FILE__; } { use Foo qw(foo bar baz); foo; bar; baz; } eval{ foo() } or warn '! ', $@; eval{ bar() } or warn '! ', $@; eval{ baz() } or warn '! ', $@; Data-Util-0.63/example/lib/000755 000765 000024 00000000000 12305724300 015352 5ustar00gfxstaff000000 000000 Data-Util-0.63/example/modifier.pl000644 000765 000024 00000000736 12040510404 016737 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Data::Util qw(:all); use Data::Dumper; use Carp qw(cluck); { sub foo { cluck('foo called'); print Dumper [foo => @_]; return (-1, -2); } sub bar { my $f = shift; print Dumper [bar => @_ ]; $f->(@_); }; sub baz { my $f = shift; print Dumper [baz => @_ ]; $f->(@_); }; } my $c = modify_subroutine( \&foo, before => [sub { print ":before\n" } ], around => [\&bar, \&baz], after => [sub { print ":after\n" } ], ); $c->(42); Data-Util-0.63/example/neat.pl000644 000765 000024 00000000545 12040510404 016066 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Data::Util qw(neat); sub say{ print @_, "\n" } say neat "foo"; say neat "here is a very long string"; say neat \"bar"; say neat 3.14; say neat 42; say neat \0xFF; say neat *foo; say neat \*foo; say neat \&foo; say neat []; say neat { foo => "bar" }; say neat { "foo\n" => "bar\n" }; say neat bless {} => 'Foo'; say neat undef; Data-Util-0.63/example/synopsis.pl000644 000765 000024 00000000466 12040510404 017030 0ustar00gfxstaff000000 000000 #!perl -w # synopsis.pl use strict; use Data::Util qw(:all); # print the file for example open my $this, '<', __FILE__; print while <$this>; sub f{ printf "f(%s) called.\n", neat($_[0]); my $ary_ref = array_ref shift; } sub g{ f([undef, 42]); # pass f({foo => "bar\n"}); # FATAL } g(); __END__ Data-Util-0.63/example/lib/Method/000755 000765 000024 00000000000 12305724300 016572 5ustar00gfxstaff000000 000000 Data-Util-0.63/example/lib/Sub/000755 000765 000024 00000000000 12305724300 016103 5ustar00gfxstaff000000 000000 Data-Util-0.63/example/lib/Sub/Exporter/000755 000765 000024 00000000000 12305724300 017713 5ustar00gfxstaff000000 000000 Data-Util-0.63/example/lib/Sub/Exporter/Lexical.pm000644 000765 000024 00000003273 12040510404 021631 0ustar00gfxstaff000000 000000 package # this is an example for install_subroutine()/uninstall_subroutine(). Sub::Exporter::Lexical; use 5.008_001; use strict; use warnings; use Data::Util; use Carp (); sub import :method{ my $class = shift; my $exportee = caller; $class->setup_installer($exportee, @_); } sub setup_installer :method{ my($exporter, $exportee, %args) = @_; my $exportable_ref = Data::Util::mkopt_hash $args{exports}, 'setup', 'CODE'; while(my($name, $entity) = each %{$exportable_ref}){ unless($entity){ $exportable_ref->{$name} = Data::Util::get_code_ref($exportee, $name, -create); } } Data::Util::install_subroutine($exportee, import => sub :method{ my $class = shift; my $export_ref; if(@_){ $export_ref = {}; for my $name(@_){ $export_ref->{$name} = $exportable_ref->{$name} or Carp::croak "$name is not exportable in $exportee"; } } else{ $export_ref = $exportable_ref; } my $into = caller; Data::Util::install_subroutine($into, %{$export_ref}); $^H |= 0x020000; # HINT_LOCALIZE_HH my $cleaner = $^H{$exporter .'/'. $into} ||= bless [$into], $exporter; push @{$cleaner}, %{$export_ref}; return; }); } sub DESTROY :method{ my($self) = @_; Data::Util::uninstall_subroutine(@{$self}); } 1; __END__ =head1 NAME Sub::Exporter::Lexical - Exports subrtouines lexically =head1 SYNOPSIS package Foo; use Sub::Exporter::Lexical exports => [ qw(foo bar), baz => \&bar, # i.e. the synonym of bar ], ; # ... { use Foo; foo(...); # Foo::foo(...) bar(...); # Foo::bar(...) baz(...); # Foo::bar(...), too } # foo, bar and baz are uninstalled foo(); # fatal! bar(); # fatal! baz(); # fatal! =head1 SEE ALSO L. =cut Data-Util-0.63/example/lib/Method/Modifiers.pm000644 000765 000024 00000004615 12040510404 021051 0ustar00gfxstaff000000 000000 package # this is an example for modify_subroutine()/subroutne_modifier(). Method::Modifiers; use strict; use warnings; our $VERSION = '1.00'; use Exporter qw(import); our @EXPORT = qw(before around after); our @EXPORT_OK = (@EXPORT, qw(add_method_modifier)); our %EXPORT_TAGS = ( all => \@EXPORT_OK, moose => \@EXPORT, ); use Data::Util (); sub _croak{ require Data::Util::Error; goto &Data::Util::Error::croak; } sub add_method_modifier{ my $into = shift; my $type = shift; my $modifier = pop; foreach my $name(@_){ my $method = Data::Util::get_code_ref($into, $name); if(!$method || !Data::Util::subroutine_modifier($method)){ unless($method){ $method = $into->can($name) or _croak(qq{The method '$name' is not found in the inheritance hierarchy for class $into}); } $method = Data::Util::modify_subroutine($method, $type => [$modifier]); no warnings 'redefine'; Data::Util::install_subroutine($into, $name => $method); } else{ # $method exists and is modified Data::Util::subroutine_modifier($method, $type => $modifier); } } return; } sub before{ my $into = caller; add_method_modifier($into, before => @_); } sub around{ my $into = caller; add_method_modifier($into, around => @_); } sub after{ my $into = caller; add_method_modifier($into, after => @_); } 1; __END__ =head1 NAME Method::Modifiers - Lightweight method modifiers =head1 SYNOPSIS package Foo; use warnings; use Data::Util qw(:all); use Method::Modifiers; before old_method => curry \&warnings::warnif, deprecated => q{"old_method" is deprecated, use "new_method" instead}; my $success = 0; after qw(foo bar baz) => sub{ $success++ }; around foo => sub{ my $next = shift; my $self = shift; $self->$next(map{ instance $_, 'Foo' } @_); }; =head1 DESCRIPTION This module is an implementation of C that provides C-like method modifiers. This is just a front-end of C and C See L for details. =head1 INTERFACE =head2 Default exported functions =over 4 =item before(method(s) => code) =item around(method(s) => code) =item after(method(s) => code) =back =head2 Exportable functions =over 4 =item add_method_modifier(class, modifer_type, method(s), modifier) =back =head1 SEE ALSO L. L. L. =cut Data-Util-0.63/benchmark/Common.pm000644 000765 000024 00000001306 12040510404 016663 0ustar00gfxstaff000000 000000 # benchmark/common.pl use 5.008_001; use strict; use B qw(svref_2object); use Config qw(%Config); use XSLoader(); use DynaLoader(); use Carp qw(longmess); $SIG{__WARN__} = \&longmess; sub perl_signeture{ printf "Perl %vd on %s\n", $^V, $Config{archname}; } sub module_signeture{ my($name, $subr) = @_; my $cv = svref_2object($subr); printf "%s(%s)/%s\n", $name, $cv->XSUB ? 'XS' : 'PurePerl', $name->VERSION; } sub signeture{ my %mods = @_; perl_signeture(); while(my($name, $subr) = each %mods){ module_signeture($name => $subr); } print "\n"; } if(grep { /^--pureperl$/ } @ARGV){ no warnings 'redefine'; *DynaLoader::bootstrap = sub{ die }; *XSLoader::load = sub{ die }; } 1; Data-Util-0.63/benchmark/curry_bench.pl000644 000765 000024 00000001616 12040510404 017741 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Data::Util qw(curry); use FindBin qw($Bin); use lib $Bin; use Common; use Benchmark qw(:all); signeture 'Data::Util' => \&curry, ; sub f{ @_ } print "Creation:\n"; cmpthese -1 => { curry => sub{ my($a, $b) = (1, 3); my $c = curry(\&f, $a, \0, $b, \1); }, closure => sub{ my($a, $b) = (1, 3); my $c = sub{ f($a, $_[0], $b, $_[1]) }; }, }; my($a, $b) = (1, 3); my $c = curry(\&f, $a, \0, $b, \1); my $d = sub{ f($a, $_[0], $b, $_[1]) }; print "Calling with subscriptive placeholders:\n"; cmpthese -1 => { curry => sub{ $c->(2, 4) == 4 or die; }, closure => sub{ $d->(2, 4) == 4 or die; }, }; $c = curry(\&f, $a, *_, $b); $d = sub{ f($a, @_[0 .. $#_], $b) }; print "Calling with the symbolic placeholder:\n"; cmpthese -1 => { curry => sub{ $c->(1 .. 5) == 7 or die $c->(1 .. 5); }, closure => sub{ $d->(1 .. 5) == 7 or die $d->(1 .. 5); }, }; Data-Util-0.63/benchmark/export_bench.pl000644 000765 000024 00000001541 12040510404 020113 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin, "$Bin/../example/lib"; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&install_subroutine, 'Sub::Exporter' => \&Sub::Exporter::import, 'Exporter' => \&Exporter::import, ; BEGIN{ package SE; use Sub::Exporter -setup => { exports => [qw(foo bar baz hoge fuga piyo)], }; $INC{'SE.pm'} = __FILE__; package SEL; use Sub::Exporter::Lexical exports => [qw(foo bar baz hoge fuga piyo)], ; $INC{'SEL.pm'} = __FILE__; package E; use Exporter qw(import); our @EXPORT = qw(foo bar baz hoge fuga piyo); $INC{'E.pm'} = __FILE__; } cmpthese timethese -1 => { 'S::Exporter' => sub{ package A; eval q{ use SE; }; }, 'S::E::Lexical' => sub{ package B; eval q{ use SEL; }; }, 'Exporter' => sub{ package C; eval q{ use E; }; }, } Data-Util-0.63/benchmark/gen_bench.pl000644 000765 000024 00000001071 12040510404 017341 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use Data::Util qw(anon_scalar); use FindBin qw($Bin); use lib $Bin; use Common; signeture 'Data::Util' => \&anon_scalar; cmpthese timethese -1 => { anon_scalar => sub{ for(1 .. 10){ my $ref = anon_scalar(); } }, '\do{my $tmp}' => sub{ for(1 .. 10){ my $ref = \do{ my $tmp }; } }, }; print "\nwith an argument\n"; cmpthese timethese -1 => { anon_scalar => sub{ for(1 .. 10){ my $ref = anon_scalar(10); } }, '\do{my $tmp}' => sub{ for(1 .. 10){ my $ref = \do{ my $tmp = 10 }; } }, }; Data-Util-0.63/benchmark/get_code_ref_bench.pl000644 000765 000024 00000000624 12040510404 021200 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&get_code_ref; my $pkg = 'Data::Util'; my $name = 'get_code_ref'; cmpthese timethese -1 => { get_code_ref => sub{ my $code = get_code_ref($pkg, $name); }, direct => sub{ my $code = do{ no strict 'refs'; *{$pkg . '::' . $name}{CODE}; }; }, }; Data-Util-0.63/benchmark/get_stash_bench.pl000644 000765 000024 00000000535 12040510404 020555 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&get_stash; my $pkg = 'Data::Util'; cmpthese timethese -1 => { get_stash => sub{ my $stash = get_stash($pkg); }, direct => sub{ my $stash = do{ no strict 'refs'; \%{$pkg . '::'}; }; }, }; Data-Util-0.63/benchmark/install_subr_bench.pl000644 000765 000024 00000002242 12040510404 021272 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); signeture 'Data::Util' => \&install_subroutine; my $pkg = do{ package Foo; __PACKAGE__ }; sub foo{ 42 } print "Installing a subroutine:\n"; cmpthese timethese -1 => { installer => sub{ no warnings 'redefine'; install_subroutine($pkg, foo => \&foo); }, direct => sub{ no warnings 'redefine'; no strict 'refs'; *{$pkg . '::foo'} = \&foo; }, }; print "\nInstalling 2 subroutines:\n"; cmpthese timethese -1 => { installer => sub{ no warnings 'redefine'; install_subroutine($pkg, foo => \&foo, bar => \&foo); }, direct => sub{ no warnings 'redefine'; no strict 'refs'; *{$pkg . '::foo'} = \&foo; *{$pkg . '::bar'} = \&foo; }, }; print "\nInstalling 4 subroutines:\n"; cmpthese timethese -1 => { installer => sub{ no warnings 'redefine'; install_subroutine($pkg, foo => \&foo, bar => \&foo, baz => \&foo, baz => \&foo, ); }, direct => sub{ no warnings 'redefine'; no strict 'refs'; *{$pkg . '::foo'} = \&foo; *{$pkg . '::bar'} = \&foo; *{$pkg . '::baz'} = \&foo; *{$pkg . '::bax'} = \&foo; }, }; Data-Util-0.63/benchmark/instance_bench.pl000644 000765 000024 00000002105 12040510404 020373 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); use Params::Util qw(_INSTANCE); # 0.35 provides a XS implementation use Scalar::Util qw(blessed); signeture 'Data::Util' => \&is_instance, 'Params::Util' => \&_INSTANCE, 'Scalar::Util' => \&blessed, ; BEGIN{ package Base; sub new{ bless {} => shift; } package Foo; our @ISA = qw(Base); package Foo::X; our @ISA = qw(Foo); package Foo::X::X; our @ISA = qw(Foo::X); package Foo::X::X::X; our @ISA = qw(Foo::X::X); package Unrelated; our @ISA = qw(Base); package SpecificIsa; our @ISA = qw(Base); sub isa{ $_[1] eq 'Foo'; } } foreach my $x (Foo->new, Foo::X::X::X->new, Unrelated->new, undef, {}){ print 'For ', neat($x), "\n"; my $i = 0; cmpthese -1 => { 'blessed' => sub{ for(1 .. 10){ $i++ if blessed($x) && $x->isa('Foo'); } }, '_INSTANCE' => sub{ for(1 .. 10){ $i++ if _INSTANCE($x, 'Foo'); } }, 'is_instance' => sub{ for(1 .. 10){ $i++ if is_instance($x, 'Foo'); } }, }; print "\n"; } Data-Util-0.63/benchmark/invocant_bench.pl000644 000765 000024 00000001674 12040510404 020422 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all), @ARGV; use Params::Util qw(_INVOCANT); signeture 'Data::Util' => \&is_invocant, 'Params::Util' => \&_INVOCANT; BEGIN{ package Base; sub new{ bless {} => shift; } package Foo; our @ISA = qw(Base); package Foo::X; our @ISA = qw(Foo); package Foo::X::X; our @ISA = qw(Foo::X); package Foo::X::X::X; our @ISA = qw(Foo::X::X); } print "Benchmark: Data::Util::is_invocant() vs. Params::Util::_INVOCANT() vs. eval{}\n"; foreach my $x (Foo->new, Foo::X::X::X->new(), 'Foo', 'Foo::X::X::X', undef, {}){ print 'For ', neat($x), "\n"; my $i = 0; cmpthese -1 => { 'eval{}' => sub{ for(1 .. 10){ $i++ if eval{ $x->VERSION; 1 }; } }, '_INVOCANT' => sub{ for(1 .. 10){ $i++ if _INVOCANT($x); } }, 'is_invocant' => sub{ for(1 .. 10){ $i++ if is_invocant($x); } }, }; print "\n"; } Data-Util-0.63/benchmark/methext_bench.pl000644 000765 000024 00000002273 12040510404 020253 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin, "$Bin/../example/lib"; use Common; { package Base; sub e{ $_[1] } sub f{ $_[1] } sub g{ $_[1] } sub h{ $_[1] } sub i{ $_[1] } sub j{ $_[1] } } sub around{ my $next = shift; goto &{$next}; } { package X; use parent -norequire => qw(Base); use Method::Modifiers; before f => sub{ }; around g => \&main::around; after h => sub{ }; sub i{ my $self = shift; $self->SUPER::i(@_); } Data::Util::install_subroutine( __PACKAGE__, j => Data::Util::modify_subroutine(__PACKAGE__->can('j')), ); } signeture 'Data::Util' => \&Data::Util::modify_subroutine, ; print <<'END'; Calling extended methods: inher - no extended, only inherited before - extended with :before modifier around - extended with :around modifier after - extended with :after modifier super - extended with SUPER:: pseudo class END cmpthese -1 => { inher => sub{ X->e(42) == 42 or die; }, before => sub{ X->f(42) == 42 or die; }, around => sub{ X->g(42) == 42 or die; }, after => sub{ X->h(42) == 42 or die; }, super => sub{ X->i(42) == 42 or die; }, # simple => sub{ # X->j(42) == 42 or die; # }, }; Data-Util-0.63/benchmark/mkopt_bench.pl000644 000765 000024 00000005235 12040510404 017730 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Data::Util qw(:all); use Data::OptList(); signeture 'Data::Util' => \&mkopt, 'Data::OptList' => \&Data::OptList::mkopt; my @args = ([qw(foo bar), baz => []], "moniker", 0); #use Test::More 'no_plan'; #is_deeply Data::Util::mkopt(@args), Data::OptList::mkopt(@args); print "mkopt()\n"; print "no-unique, no-validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, 'inline' => sub{ for(1 .. 10){ my $opt_ref = [ (map{ [$_ => undef] } qw(foo bar) ), [baz => []] ]; } }, }; @args = ([qw(foo bar), baz => []], "moniker", 1); print "unique, no-validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ([qw(foo bar), baz => []], "moniker", 0, 'ARRAY'); print "no-unique, validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ([qw(foo bar), baz => []], "moniker", 1, 'ARRAY'); print "unique, validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ({foo => [], bar => [], baz => []}, "moniker", 0); print "\nmkopt() from HASH ref\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt(@args); } }, }; @args = ([qw(foo bar), baz => []]); print "\nmkopt_hash()\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt_hash(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt_hash(@args); } }, 'inline' => sub{ for(1 .. 10){ my $opt_ref = { (map{ $_ => undef} qw(foo bar) ), baz => [] }; } } }; @args = ([qw(foo bar), baz => []], 'test', 'ARRAY'); print "mkopt_hash() with validation\n"; cmpthese -1 => { 'OptList' => sub{ for(1 .. 10){ my $opt_ref = Data::OptList::mkopt_hash(@args); } }, 'Util' => sub{ for(1 .. 10){ my $opt_ref = Data::Util::mkopt_hash(@args); } }, 'inline' => sub{ for(1 .. 10){ my $opt_ref = { (map{ $_ => undef} qw(foo bar) ), baz => [] }; while(my($k, $v) = each %{$opt_ref}){ defined $v and array_ref($v); } } } }; Data-Util-0.63/benchmark/modifier_bench.pl000644 000765 000024 00000003343 12040510404 020372 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin, "$Bin/../example/lib"; use Common; { package Base; sub f{ 42 } sub g{ 42 } sub h{ 42 } } my $i = 0; sub around{ my $next = shift; $i++; goto &{$next}; } { package DUMM; use parent -norequire => qw(Base); use Method::Modifiers; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } { package CMM; use parent -norequire => qw(Base); use Class::Method::Modifiers; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } { package MOP; use parent -norequire => qw(Base); use Moose; before f => sub{ $i++ }; around g => \&main::around; after h => sub{ $i++ }; } signeture 'Data::Util' => \&Data::Util::modify_subroutine, 'Moose' => \&Moose::around, 'Class::Method::Modifiers' => \&Class::Method::Modifiers::around, ; print "Calling methods with before modifiers:\n"; cmpthese -1 => { du => sub{ my $old = $i; DUMM->f(); $i == ($old+1) or die $i; }, cmm => sub{ my $old = $i; CMM->f(); $i == ($old+1) or die $i; }, moose => sub{ my $old = $i; MOP->f(); $i == ($old+1) or die $i; } }; print "\n", "Calling methods with around modifiers:\n"; cmpthese -1 => { du => sub{ my $old = $i; DUMM->g(); $i == ($old+1) or die $i; }, cmm => sub{ my $old = $i; CMM->g(); $i == ($old+1) or die $i; }, moose => sub{ my $old = $i; MOP->g(); $i == ($old+1) or die $i; } }; print "\n", "Calling methods with after modifiers:\n"; cmpthese -1 => { du => sub{ my $old = $i; DUMM->h(); $i == ($old+1) or die $i; }, cmm => sub{ my $old = $i; CMM->h(); $i == ($old+1) or die $i; }, moose => sub{ my $old = $i; MOP->h(); $i == ($old+1) or die $i; } }; Data-Util-0.63/benchmark/modify_bench.pl000644 000765 000024 00000002660 12040510404 020064 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Data::Util qw(:all); use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; signeture 'Data::Util' => \&modify_subroutine; sub f { 42 } sub before { 1 } sub around { my $f = shift; $f->(@_) + 1; } sub after { 1 } my @before = (\&before, \&before); my @around = (\&around); my @after = (\&after, \&after); my $modified = modify_subroutine(\&f, before => \@before, around => \@around, after => \@after); sub modify{ my $subr = shift; my @before = @{(shift)}; my @around = @{(shift)}; my @after = @{(shift)}; $subr = curry($_, (my $tmp = $subr), *_) for @around; return sub{ $_->(@_) for @before; my @ret = wantarray ? $subr->(@_) : scalar $subr->(@_); $_->(@_) for @after; return wantarray ? @ret : $ret[0]; }; } my $closure = modify(\&f, \@before, \@around, \@after); $modified->(-1) == 43 or die $modified->(-10); $closure->(-2) == 43 or die $closure->(-20); print "Creation of modified subs:\n"; cmpthese timethese -1 => { modify => sub{ my $w = modify_subroutine(\&f, before => \@before, around => \@around, after => \@after); }, closure => sub{ my $w = modify(\&f, \@before, \@around, \@after); }, }; sub combined{ $_->(@_) for @before; around(\&f, @_); $_->(@_) for @after; } print "Calling modified subs:\n"; cmpthese timethese -1 => { modify => sub{ $modified->(42); }, closure => sub{ $closure->(42); }, combined => sub{ combined(42); }, }; Data-Util-0.63/benchmark/number_bench.pl000644 000765 000024 00000001254 12040510404 020063 0ustar00gfxstaff000000 000000 #!perl -w use strict; use Benchmark qw(:all); use Scalar::Util qw(looks_like_number); use Data::Util qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; signeture 'Data::Util' => \&is_number, 'Scalar::Util' => \&looks_like_number; print "Benchmark: is_number(), is_integer(), looks_like_number()\n"; for my $x(42, exp(1), '42', sprintf('%g', exp(1)), undef){ print "For ", neat($x), "\n"; cmpthese -1 => { is_number => sub{ for(1 .. 100){ my $ok = is_number $x; } }, is_integer => sub{ for(1 .. 100){ my $ok = is_integer $x; } }, looks_like_number => sub{ for(1 .. 100){ my $ok = looks_like_number $x; } }, }; print "\n"; } Data-Util-0.63/benchmark/ref_bench.pl000644 000765 000024 00000001310 12040510404 017340 0ustar00gfxstaff000000 000000 #!perl -w use strict; use warnings FATAL => 'all'; use Benchmark qw(:all); use FindBin qw($Bin); use lib $Bin; use Common; use Params::Util qw(_ARRAY0); use Data::Util qw(:all); signeture 'Data::Util' => \&is_array_ref, 'Params::Util' => \&_ARRAY0; print "Benchmark: Params::Util::_ARRAY0() vs. Data::Util::is_array() vs. ref()\n"; foreach my $o([], {}, bless({}, 'Foo'), undef){ print "\nFor ", neat($o), "\n"; cmpthese -1 => { '_ARRAY0' => sub{ for(1 .. 10){ if(_ARRAY0($o)){ ; } } }, 'is_array_ref' => sub{ for(1 .. 10){ if(is_array_ref($o)){ ; } } }, 'ref() eq "ARRAY"' => sub{ for(1 ..10){ if(ref($o) eq 'ARRAY'){ ; } } }, }; }