Params-Classify-0.013000755001750001750 011470565450 14455 5ustar00zeframzefram000000000000Params-Classify-0.013/META.yml000444001750001750 142711470565443 16071 0ustar00zeframzefram000000000000--- abstract: 'argument type classification' author: - 'Andrew Main (Zefram) ' build_requires: ExtUtils::ParseXS: 2.2006 Module::Build: 0 Test::More: 0 perl: 5.006001 strict: 0 warnings: 0 configure_requires: Module::Build: 0 perl: 5.006001 strict: 0 warnings: 0 distribution_type: module dynamic_config: 1 generated_by: 'Module::Build version 0.3607' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Params-Classify provides: Params::Classify: file: lib/Params/Classify.pm version: 0.013 recommends: XSLoader: 0 requires: Exporter: 0 Scalar::Util: 1.01 parent: 0 perl: 5.006001 strict: 0 warnings: 0 resources: license: http://dev.perl.org/licenses/ version: 0.013 Params-Classify-0.013/SIGNATURE000644001750001750 413611470565450 16104 0ustar00zeframzefram000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.66. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 2f6a77cc1af0bc60cf87ec5335a995defa3e6eaf .cvsignore SHA1 a433f32fb0d0334e4001ec04741f776c4199379d Build.PL SHA1 22cbe81208a74303ace05ff63a9243c3cb87221d Changes SHA1 2e0cd1c1b78fb8591fde383f023acb4a579cb4dc MANIFEST SHA1 1463aa8b2d472d2dca1d6f601e28e874ef95e502 META.yml SHA1 0e23f901a8f88cc5f8fd6f9aa29c9122db1c00e4 Makefile.PL SHA1 00ef56b107920b1bb435a80247d50dded3c1eace README SHA1 91978573e906c90b93752e0733ef8e875f0d1b89 lib/Params/.cvsignore SHA1 615202f9e823f139fbfcb4fe46fc7cc8989da9b0 lib/Params/Classify.pm SHA1 40b5ef7d1c03d951912097973ecd6b2e095a3c32 lib/Params/Classify.xs SHA1 497c90b7b470f8c3a4594265c4a97376000fc2aa t/blessed.t SHA1 a3d9a389510faf3bfecb4860a14813988a0eddcd t/blessed_pp.t SHA1 e05666c5b2480ce441116ff26e55fa5bb07fb741 t/check.t SHA1 ec88f98f2f29c1a6999db46666e5eb7cf9fa46b1 t/check_pp.t SHA1 071b996f6953fd005472b99a0ed867404425239a t/classify.t SHA1 22c8bb9af38f3eaa604350884e3fcc9c200b5f1b t/classify_pp.t SHA1 29b6f328b7b3c928d455f82d1a0708d821445554 t/error.t SHA1 fc008cb61eb02798d6ec02df230ef4d59bcdca12 t/error_pp.t SHA1 904d9a4f76525e2303e4b0c168c68230f223c8de t/pod_cvg.t SHA1 3f447b1d0b8a6247c3a311087f8d66da1c3ca5db t/pod_cvg_pp.t SHA1 65c75abdef6f01a5d1588a307f2ddfe2333dc961 t/pod_syn.t SHA1 8a817d64d2098a5dfa7b65ba87b38314f9b3241e t/ref.t SHA1 4a19b745e2bcdfb8db18b149e79fcf8c235b24f8 t/ref_pp.t SHA1 97157325ac601fe786026cdc319f958c8ea785ae t/setup_pp.pl -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.9 (GNU/Linux) iEYEARECAAYFAkzi6yMACgkQOV9mt2VyAVE+hQCeOJemX8bpRvhEK7XBeB3YBmkF ZhIAoI/InODHqUDzt2Aryvc6tZH1SFNb =kZIC -----END PGP SIGNATURE----- Params-Classify-0.013/MANIFEST000444001750001750 53411470565443 15727 0ustar00zeframzefram000000000000.cvsignore Build.PL Changes MANIFEST META.yml Makefile.PL README lib/Params/.cvsignore lib/Params/Classify.pm lib/Params/Classify.xs t/blessed.t t/blessed_pp.t t/check.t t/check_pp.t t/classify.t t/classify_pp.t t/error.t t/error_pp.t t/pod_cvg.t t/pod_cvg_pp.t t/pod_syn.t t/ref.t t/ref_pp.t t/setup_pp.pl SIGNATURE Added here by Module::Build Params-Classify-0.013/Changes000444001750001750 1217211470565443 16132 0ustar00zeframzefram000000000000version 0.013; 2010-11-16 * bugfix: avoid triggering a core assertion on debugging builds, by using OP_NULL as a stalking-horse opcode instead of OP_PUSHMARK (nothing actually broke apart from the assertion) * provide reserve definition of Newx(), to allow compilation on non-threaded Perls prior to 5.8.8 * avoid a compiler warning from the reserve implementation of the ptr_table data structure version 0.012; 2010-11-03 * generate custom ops for most functions, to avoid heavyweight function calls at runtime * change "please update me" messages to "please update Params::Classify" for clarity * use shared SVs for return values from scalar_class() and ref_type() * allow is_able() and check_able() to be called with only one argument * change message generated by check_strictly_blessed() when called with only one argument, to be consistent between XS and pure Perl * refactor some Perl version portability code * in XS, declare "PROTOTYPES: DISABLE" to prevent automatic generation of unintended prototypes * jump through hoops to avoid compiler warnings * in t/setup_pp.pl, avoid a warning that occurs if XSLoader::load() is given no arguments, which is now a valid usage version 0.011; 2010-08-21 * bugfix: add a typemap entry for "const char *", to make XS version of scalar_class() work correctly on Perl 5.6, having been broken by the const fix in version 0.010 * in XS code, on Perls where it exists (prior to 5.9.5), treat SVt_PVBM as a scalar referent type version 0.010; 2010-08-20 * in XS, use PERL_NO_GET_CONTEXT for efficiency * use full stricture in test suite * also test POD coverage of pure Perl implementation * in test suite, make all numeric comparisons against $] stringify it first, to avoid architecture-dependent problems with floating point rounding giving it an unexpected numeric value * make XS code const clean for gcc -Wwrite-strings * in Build.PL, explicitly set needs_compiler to avoid bogus auto-dependency on ExtUtils::CBuilder * in Build.PL, explicitly declare configure-time requirements * add MYMETA.yml to .cvsignore version 0.009; 2009-10-07 * port to Perl 5.11.0, supporting the addition of first-class regexp objects (which are actually a type of scalar) and the removal of the distinct RV type; new functions is_regexp() and check_regexp() * fix a test skip count in t/ref.t, which was causing false test failures on Perl 5.6 * check for required Perl version at runtime version 0.008; 2009-09-10 * add "check_" functions for argument checking * strict argument checking in all functions that take control arguments * revise documentation * revise pure Perl code to avoid unnecessary argument copying * in XS code, make all auxiliary functions "static" * revise POD markup * remove bogus "exit 0" from Build.PL version 0.007; 2009-05-13 * XS implementation, used if available with fallback to existing pure Perl implementation if XS is not available * use simpler "parent" pragma in place of "base" * in documentation, use the term "truth value" instead of the less precise "boolean" * use full stricture in Build.PL version 0.006; 2009-02-15 * withdraw is_pure_string() and is_pure_number() functions, because they've never worked right and bring in a big dependency for marginal utility * use "base" pragma to import Exporter behaviour * test POD syntax and coverage * build with Module::Build instead of ExtUtils::MakeMaker * complete dependency list * include signature in distribution * in documentation, separate "license" section from "copyright" section version 0.005; 2007-09-02 * in t/purity.t, modify purity test on dualvar(0, "0") to operate appropriately on older Perls where this has a different numeric value from 0 * in t/purity.t, fix a skip count for the case where dualvar() is not available version 0.004; 2007-08-16 * in t/purity.t, fix a skip count for the case where floating point zero is unsigned version 0.003; 2007-08-15 * in t/purity.t, modify purity test on dualvar(+0.0, "0") to operate appropriately on older Perls where "0" numifies to a floating point zero, and add a test for dualvar(0, "0") version 0.002; 2007-01-25 * add is_pure_string() and is_pure_number() functions that determine how complicated a string scalar is * in documentation for is_number(), reference Scalar::Number and Data::Integer * correct version requirement of Scalar::Util in module, making it consistent with the dependency listed in Makefile.PL version 0.001; 2006-08-03 * bugfix: in is_number(), check whether numeric conversion warns, rather than using looks_like_number(), to avoid being confused by dualvars * in t/ref.t, skip *foo{FORMAT} tests on older Perls that don't provide that facility * refer to Data::Float for classification of floating point values * versioned dependencies in .pm * declare module dependencies in Makefile.PL * correct .cvsignore (had copy&modify detritus) * include Changes file version 0.000; 2004-03-20 * initial released version Params-Classify-0.013/README000444001750001750 302011470565443 15467 0ustar00zeframzefram000000000000NAME Params::Classify - argument type classification DESCRIPTION This module provides various type-testing functions. These are intended for functions that, unlike most Perl code, care what type of data they are operating on. For example, some functions wish to behave differently depending on the type of their arguments (like overloaded functions in C++). There are two flavours of function in this module. Functions of the first flavour only provide type classification, to allow code to discriminate between argument types. Functions of the second flavour package up the most common type of type discrimination: checking that an argument is of an expected type. The functions come in matched pairs, of the two flavours, and so the type enforcement functions handle only the simplest requirements for arguments of the types handled by the classification functions. Enforcement of more complex types may, of course, be built using the classification functions, or it may be more convenient to use a module designed for the more complex job, such as L. This module is implemented in XS, with a pure Perl backup version for systems that can't handle XS. INSTALLATION perl Build.PL ./Build ./Build test ./Build install AUTHOR Andrew Main (Zefram) COPYRIGHT Copyright (C) 2004, 2006, 2007, 2009, 2010 Andrew Main (Zefram) Copyright (C) 2009, 2010 PhotoBox Ltd LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Params-Classify-0.013/Makefile.PL000444001750001750 233611470565443 16572 0ustar00zeframzefram000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.3607 require 5.006001; unless (eval "use Module::Build::Compat 0.02; 1" ) { print "This module requires Module::Build to install itself.\n"; require ExtUtils::MakeMaker; my $yn = ExtUtils::MakeMaker::prompt (' Install Module::Build now from CPAN?', 'y'); unless ($yn =~ /^y/i) { die " *** Cannot install without Module::Build. Exiting ...\n"; } require Cwd; require File::Spec; require CPAN; # Save this 'cause CPAN will chdir all over the place. my $cwd = Cwd::cwd(); CPAN::Shell->install('Module::Build::Compat'); CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate or die "Couldn't install Module::Build, giving up.\n"; chdir $cwd or die "Cannot chdir() back to $cwd: $!"; } eval "use Module::Build::Compat 0.02; 1" or die $@; use lib '_build/lib'; Module::Build::Compat->run_build_pl(args => \@ARGV); my $build_script = 'Build'; $build_script .= '.com' if $^O eq 'VMS'; exit(0) unless(-e $build_script); # cpantesters convention require MyModuleBuilder; Module::Build::Compat->write_makefile(build_class => 'MyModuleBuilder'); Params-Classify-0.013/.cvsignore000444001750001750 12711470565443 16574 0ustar00zeframzefram000000000000Build Makefile _build blib META.yml MYMETA.yml Makefile.PL SIGNATURE Params-Classify-* Params-Classify-0.013/Build.PL000444001750001750 351411470565443 16113 0ustar00zeframzefram000000000000{ use 5.006; } use warnings; use strict; use Module::Build; Module::Build->subclass(code => q{ unless(__PACKAGE__->can("cbuilder")) { *cbuilder = sub { $_[0]->_cbuilder or die "no C support" }; } unless(__PACKAGE__->can("have_c_compiler")) { *have_c_compiler = sub { my $cb = eval { $_[0]->cbuilder }; return $cb && $cb->have_compiler; }; } if($Module::Build::VERSION < 0.33) { # Older versions of Module::Build have a bug where if the # cbuilder object is used at Build.PL time (which it will # be for this distribution due to the logic in # ->find_xs_files) then that object can be dumped to the # build_params file, and then at Build time it will # attempt to use the dumped blessed object without loading # the ExtUtils::CBuilder class that is needed to make it # work. *write_config = sub { delete $_[0]->{properties}->{_cbuilder}; return $_[0]->SUPER::write_config; }; } sub find_xs_files { my($self) = @_; return {} unless $self->have_c_compiler; return $self->SUPER::find_xs_files; } })->new( module_name => "Params::Classify", license => "perl", configure_requires => { "Module::Build" => 0, "perl" => "5.006001", "strict" => 0, "warnings" => 0, }, configure_recommends => { "ExtUtils::CBuilder" => "0.15", }, build_requires => { "ExtUtils::ParseXS" => "2.2006", "Module::Build" => 0, "Test::More" => 0, "perl" => "5.006001", "strict" => 0, "warnings" => 0, }, build_recommends => { "ExtUtils::CBuilder" => "0.15", }, requires => { "Exporter" => 0, "Scalar::Util" => "1.01", "parent" => 0, "perl" => "5.006001", "strict" => 0, "warnings" => 0, }, recommends => { "XSLoader" => 0, }, needs_compiler => 0, dynamic_config => 1, meta_add => { distribution_type => "module" }, create_makefile_pl => "passthrough", sign => 1, )->create_build_script; 1; Params-Classify-0.013/lib000755001750001750 011470565443 15225 5ustar00zeframzefram000000000000Params-Classify-0.013/lib/Params000755001750001750 011470565443 16450 5ustar00zeframzefram000000000000Params-Classify-0.013/lib/Params/Classify.xs000444001750001750 4357011470565443 20767 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #define PERL_DECIMAL_VERSION \ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif /* !PERL_UNUSED_VAR */ #ifndef PERL_UNUSED_ARG # define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x) #endif /* !PERL_UNUSED_ARG */ #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif /* !Newx */ #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef newSVpvs_share # define newSVpvs_share(s) newSVpvn_share(""s"", (sizeof(""s"")-1), 0) #endif /* !newSVpvs_share */ #ifndef newSVpvn_share # define newSVpvn_share(s, l, h) newSVpvn(s, l) #endif /* !newSVpvn_share */ #ifndef DPTR2FPTR # define DPTR2FPTR(t,x) ((t)(UV)(x)) #endif /* !DPTR2FPTR */ #ifndef FPTR2DPTR # define FPTR2DPTR(t,x) ((t)(UV)(x)) #endif /* !FPTR2DPTR */ #ifndef ptr_table_new struct q_ptr_tbl_ent { struct q_ptr_tbl_ent *next; void *from, *to; }; # undef PTR_TBL_t # define PTR_TBL_t struct q_ptr_tbl_ent * # define ptr_table_new() THX_ptr_table_new(aTHX) static PTR_TBL_t *THX_ptr_table_new(pTHX) { PTR_TBL_t *tbl; Newx(tbl, 1, PTR_TBL_t); *tbl = NULL; return tbl; } # if 0 # define ptr_table_free(tbl) THX_ptr_table_free(aTHX_ tbl) static void THX_ptr_table_free(pTHX_ PTR_TBL_t *tbl) { struct q_ptr_tbl_ent *ent = *tbl; Safefree(tbl); while(ent) { struct q_ptr_tbl_ent *nent = ent->next; Safefree(ent); ent = nent; } } # endif /* 0 */ # define ptr_table_store(tbl, from, to) THX_ptr_table_store(aTHX_ tbl, from, to) static void THX_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *from, void *to) { struct q_ptr_tbl_ent *ent; Newx(ent, 1, struct q_ptr_tbl_ent); ent->next = *tbl; ent->from = from; ent->to = to; *tbl = ent; } # define ptr_table_fetch(tbl, from) THX_ptr_table_fetch(aTHX_ tbl, from) static void *THX_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *from) { struct q_ptr_tbl_ent *ent; for(ent = *tbl; ent; ent = ent->next) { if(ent->from == from) return ent->to; } return NULL; } #endif /* !ptr_table_new */ #if PERL_VERSION_GE(5,11,0) # define case_SVt_RV_ #else /* <5.11.0 */ # define case_SVt_RV_ case SVt_RV: #endif /* <5.11.0 */ #if PERL_VERSION_GE(5,9,5) # define case_SVt_PVBM_ #else /* <5.11.0 */ # define case_SVt_PVBM_ case SVt_PVBM: #endif /* <5.11.0 */ #if PERL_VERSION_GE(5,11,0) # define case_SVt_REGEXP_ case SVt_REGEXP: #else /* <5.11.0 */ # define case_SVt_REGEXP_ #endif /* <5.11.0 */ #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV) #if PERL_VERSION_GE(5,11,0) # define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP) #else /* <5.11.0 */ # define sv_is_regexp(sv) 0 #endif /* <5.11.0 */ #define sv_is_undef(sv) (!sv_is_glob(sv) && !sv_is_regexp(sv) && !SvOK(sv)) #define sv_is_string(sv) \ (!sv_is_glob(sv) && !sv_is_regexp(sv) && \ (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK))) #define sv_is_untyped_ref(sv) (SvROK(sv) && !SvOBJECT(SvRV(sv))) #define sv_is_untyped_blessed(sv) (SvROK(sv) && SvOBJECT(SvRV(sv))) #define bool_sv(b) ((b) ? &PL_sv_yes : &PL_sv_no) static bool THX_sv_is_undef(pTHX_ SV *sv) { return !!sv_is_undef(sv); } static bool THX_sv_is_string(pTHX_ SV *sv) { return !!sv_is_string(sv); } static bool THX_sv_is_glob(pTHX_ SV *sv) { return !!sv_is_glob(sv); } static bool THX_sv_is_regexp(pTHX_ SV *sv) { PERL_UNUSED_ARG(sv); return !!sv_is_regexp(sv); } static bool THX_sv_is_untyped_ref(pTHX_ SV *sv) { return !!sv_is_untyped_ref(sv); } static bool THX_sv_is_untyped_blessed(pTHX_ SV *sv) { return !!sv_is_untyped_blessed(sv); } enum { SCLASS_UNDEF, SCLASS_STRING, SCLASS_GLOB, SCLASS_REGEXP, SCLASS_REF, SCLASS_BLESSED, SCLASS_COUNT }; static struct sclass_metadata { char const *desc_adj_or_noun_phrase, *keyword_pv; SV *keyword_sv; bool (*THX_sv_is_sclass)(pTHX_ SV *); } sclass_metadata[SCLASS_COUNT] = { { "undefined", "UNDEF", NULL, THX_sv_is_undef }, { "a string", "STRING", NULL, THX_sv_is_string }, { "a typeglob", "GLOB", NULL, THX_sv_is_glob }, { "a regexp", "REGEXP", NULL, THX_sv_is_regexp }, { "a reference to plain object", "REF", NULL, THX_sv_is_untyped_ref }, { "a reference to blessed object", "BLESSED", NULL, THX_sv_is_untyped_blessed }, }; enum { RTYPE_SCALAR, RTYPE_ARRAY, RTYPE_HASH, RTYPE_CODE, RTYPE_FORMAT, RTYPE_IO, RTYPE_COUNT }; static struct rtype_metadata { char const *desc_noun, *keyword_pv; SV *keyword_sv; } rtype_metadata[RTYPE_COUNT] = { { "scalar", "SCALAR", NULL }, { "array", "ARRAY", NULL }, { "hash", "HASH", NULL }, { "code", "CODE", NULL }, { "format", "FORMAT", NULL }, { "io", "IO", NULL }, }; #define PC_TYPE_MASK 0x00f #define PC_CROAK 0x010 #define PC_STRICTBLESS 0x020 #define PC_ABLE 0x040 #define PC_ALLOW_UNARY 0x100 #define PC_ALLOW_BINARY 0x200 #define scalar_class(arg) THX_scalar_class(aTHX_ arg) static I32 THX_scalar_class(pTHX_ SV *arg) { if(sv_is_glob(arg)) { return SCLASS_GLOB; } else if(sv_is_regexp(arg)) { return SCLASS_REGEXP; } else if(!SvOK(arg)) { return SCLASS_UNDEF; } else if(SvROK(arg)) { return SvOBJECT(SvRV(arg)) ? SCLASS_BLESSED : SCLASS_REF; } else if(SvFLAGS(arg) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)) { return SCLASS_STRING; } else { croak("unknown scalar class, please update Params::Classify\n"); } } #define read_reftype_or_neg(reftype) THX_read_reftype_or_neg(aTHX_ reftype) static I32 THX_read_reftype_or_neg(pTHX_ SV *reftype) { char *p; STRLEN l; if(!sv_is_string(reftype)) return -2; p = SvPV(reftype, l); if(strlen(p) != l) return -1; switch(p[0]) { case 'S': if(!strcmp(p, "SCALAR")) return RTYPE_SCALAR; return -1; case 'A': if(!strcmp(p, "ARRAY")) return RTYPE_ARRAY; return -1; case 'H': if(!strcmp(p, "HASH")) return RTYPE_HASH; return -1; case 'C': if(!strcmp(p, "CODE")) return RTYPE_CODE; return -1; case 'F': if(!strcmp(p, "FORMAT")) return RTYPE_FORMAT; return -1; case 'I': if(!strcmp(p, "IO")) return RTYPE_IO; return -1; default: return -1; } } #define read_reftype(reftype) THX_read_reftype(aTHX_ reftype) static I32 THX_read_reftype(pTHX_ SV *reftype) { I32 rtype = read_reftype_or_neg(reftype); if(rtype < 0) croak(rtype == -2 ? "reference type argument is not a string\n" : "invalid reference type\n"); return rtype; } #define ref_type(referent) THX_ref_type(aTHX_ referent) static I32 THX_ref_type(pTHX_ SV *referent) { switch(SvTYPE(referent)) { case SVt_NULL: case SVt_IV: case SVt_NV: case_SVt_RV_ case SVt_PV: case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: case SVt_PVLV: case SVt_PVGV: case_SVt_PVBM_ case_SVt_REGEXP_ return RTYPE_SCALAR; case SVt_PVAV: return RTYPE_ARRAY; case SVt_PVHV: return RTYPE_HASH; case SVt_PVCV: return RTYPE_CODE; case SVt_PVFM: return RTYPE_FORMAT; case SVt_PVIO: return RTYPE_IO; default: croak("unknown SvTYPE, " "please update Params::Classify\n"); } } #define blessed_class(referent) THX_blessed_class(aTHX_ referent) static const char *THX_blessed_class(pTHX_ SV *referent) { HV *stash = SvSTASH(referent); const char *name = HvNAME_get(stash); return name ? name : "__ANON__"; } #define call_bool_method(objref, methodname, arg) \ THX_call_bool_method(aTHX_ objref, methodname, arg) static bool THX_call_bool_method(pTHX_ SV *objref, const char *methodname, SV *arg) { dSP; int retcount; SV *ret; bool retval; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(objref); XPUSHs(arg); PUTBACK; retcount = call_method(methodname, G_SCALAR); SPAGAIN; if(retcount != 1) croak("call_method misbehaving\n"); ret = POPs; retval = !!SvTRUE(ret); PUTBACK; FREETMPS; LEAVE; return retval; } #define pp1_scalar_class() THX_pp1_scalar_class(aTHX) static void THX_pp1_scalar_class(pTHX) { dSP; SV *arg = TOPs; TOPs = sclass_metadata[scalar_class(arg)].keyword_sv; } #define pp1_ref_type() THX_pp1_ref_type(aTHX) static void THX_pp1_ref_type(pTHX) { dSP; SV *arg, *referent; arg = TOPs; TOPs = !SvROK(arg) || (referent = SvRV(arg), SvOBJECT(referent)) ? &PL_sv_undef : rtype_metadata[ref_type(referent)].keyword_sv; } #define pp1_blessed_class() THX_pp1_blessed_class(aTHX) static void THX_pp1_blessed_class(pTHX) { dSP; SV *arg, *referent; arg = TOPs; TOPs = !SvROK(arg) || (referent = SvRV(arg), !SvOBJECT(referent)) ? &PL_sv_undef : sv_2mortal(newSVpv(blessed_class(referent), 0)); } #define pp1_check_sclass(t) THX_pp1_check_sclass(aTHX_ t) static void THX_pp1_check_sclass(pTHX_ I32 t) { dSP; SV *arg = POPs; struct sclass_metadata const *sclassmeta = &sclass_metadata[t & PC_TYPE_MASK]; bool matches; PUTBACK; matches = sclassmeta->THX_sv_is_sclass(aTHX_ arg); SPAGAIN; if(t & PC_CROAK) { if(!matches) croak("argument is not %s\n", sclassmeta->desc_adj_or_noun_phrase); if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); } else { SV *result = bool_sv(matches); XPUSHs(result); } PUTBACK; } #define pp1_check_rtype(t) THX_pp1_check_rtype(aTHX_ t) static void THX_pp1_check_rtype(pTHX_ I32 t) { dSP; SV *arg = POPs, *referent; I32 rtype = t & PC_TYPE_MASK; struct rtype_metadata const *rtypemeta = &rtype_metadata[rtype]; bool matches = SvROK(arg) && (referent = SvRV(arg), !SvOBJECT(referent)) && ref_type(referent) == rtype; if(t & PC_CROAK) { if(!matches) croak("argument is not a reference to plain %s\n", rtypemeta->desc_noun); if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); } else { SV *result = bool_sv(matches); XPUSHs(result); } PUTBACK; } #define pp1_check_dyn_rtype(t) THX_pp1_check_dyn_rtype(aTHX_ t) static void THX_pp1_check_dyn_rtype(pTHX_ I32 t) { dSP; SV *type_sv = POPs; PUTBACK; pp1_check_rtype(t | read_reftype(type_sv)); } #define pp1_check_dyn_battr(t) THX_pp1_check_dyn_battr(aTHX_ t) static void THX_pp1_check_dyn_battr(pTHX_ I32 t) { dSP; SV *attr, *arg, *meth = NULL; bool matches; attr = POPs; if(t & PC_ABLE) { if(sv_is_string(attr)) { meth = attr; } else { AV *methods_av; I32 alen, pos; if(!SvROK(attr) || SvOBJECT(SvRV(attr)) || SvTYPE(SvRV(attr)) != SVt_PVAV) croak("methods argument is not " "a string or array\n"); methods_av = (AV*)SvRV(attr); alen = av_len(methods_av); for(pos = 0; pos <= alen; pos++) { SV **m_ptr = av_fetch(methods_av, pos, 0); if(!m_ptr || !sv_is_string(*m_ptr)) croak("method name is not a string\n"); } if(alen != -1) meth = *av_fetch(methods_av, 0, 0); } } else { if(!sv_is_string(attr)) croak("class argument is not a string\n"); } arg = POPs; if((matches = SvROK(arg) && SvOBJECT(SvRV(arg)))) { if(t & PC_ABLE) { PUTBACK; if(!SvROK(attr)) { meth = attr; matches = call_bool_method(arg, "can", attr); } else { AV *methods_av = (AV*)SvRV(attr); I32 alen = av_len(methods_av), pos; for(pos = 0; pos <= alen; pos++) { meth = *av_fetch(methods_av, pos, 0); if(!call_bool_method(arg, "can", meth)) { matches = 0; break; } } } SPAGAIN; } else if(t & PC_STRICTBLESS) { char const *actual_class = blessed_class(SvRV(arg)); char const *check_class; STRLEN check_len; check_class = SvPV(attr, check_len); matches = check_len == strlen(actual_class) && !strcmp(check_class, actual_class); } else { PUTBACK; matches = call_bool_method(arg, "isa", attr); SPAGAIN; } } if(t & PC_CROAK) { if(!matches) { if(t & PC_ABLE) { if(meth) { croak("argument is not able to " "perform method \"%s\"\n", SvPV_nolen(meth)); } else { croak("argument is not able to " "perform at all\n"); } } else { croak("argument is not a reference to " "%sblessed %s\n", t & PC_STRICTBLESS ? "strictly " : "", SvPV_nolen(attr)); } } if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef); } else { SV *result = bool_sv(matches); XPUSHs(result); } PUTBACK; } static OP *THX_pp_scalar_class(pTHX) { pp1_scalar_class(); return NORMAL; } static OP *THX_pp_ref_type(pTHX) { pp1_ref_type(); return NORMAL; } static OP *THX_pp_blessed_class(pTHX) { pp1_blessed_class(); return NORMAL; } static OP *THX_pp_check_sclass(pTHX) { pp1_check_sclass(PL_op->op_private); return NORMAL; } static OP *THX_pp_check_rtype(pTHX) { pp1_check_rtype(PL_op->op_private); return NORMAL; } static OP *THX_pp_check_dyn_rtype(pTHX) { pp1_check_dyn_rtype(PL_op->op_private); return NORMAL; } static OP *THX_pp_check_dyn_battr(pTHX) { pp1_check_dyn_battr(PL_op->op_private); return NORMAL; } #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE static void S_croak_xs_usage(pTHX_ const CV *, const char *); # define croak_xs_usage(cv, params) S_croak_xs_usage(aTHX_ cv, params) #endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */ static void THX_xsfunc_scalar_class(pTHX_ CV *cv) { dMARK; dSP; if(SP - MARK != 1) croak_xs_usage(cv, "arg"); pp1_scalar_class(); } static void THX_xsfunc_ref_type(pTHX_ CV *cv) { dMARK; dSP; if(SP - MARK != 1) croak_xs_usage(cv, "arg"); pp1_ref_type(); } static void THX_xsfunc_blessed_class(pTHX_ CV *cv) { dMARK; dSP; if(SP - MARK != 1) croak_xs_usage(cv, "arg"); pp1_blessed_class(); } static void THX_xsfunc_check_sclass(pTHX_ CV *cv) { dMARK; dSP; if(SP - MARK != 1) croak_xs_usage(cv, "arg"); pp1_check_sclass(CvXSUBANY(cv).any_i32); } static void THX_xsfunc_check_ref(pTHX_ CV *cv) { I32 cvflags = CvXSUBANY(cv).any_i32; dMARK; dSP; switch(SP - MARK) { case 1: pp1_check_sclass(cvflags); break; case 2: pp1_check_dyn_rtype(cvflags & ~PC_TYPE_MASK); break; default: croak_xs_usage(cv, "arg, type"); } } static void THX_xsfunc_check_blessed(pTHX_ CV *cv) { I32 cvflags = CvXSUBANY(cv).any_i32; dMARK; dSP; switch(SP - MARK) { case 1: pp1_check_sclass(cvflags); break; case 2: pp1_check_dyn_battr(cvflags & ~PC_TYPE_MASK); break; default: croak_xs_usage(cv, "arg, class"); } } #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE # undef croak_xs_usage #endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */ #define rvop_cv(rvop) THX_rvop_cv(aTHX_ rvop) static CV *THX_rvop_cv(pTHX_ OP *rvop) { switch(rvop->op_type) { case OP_CONST: { SV *rv = cSVOPx_sv(rvop); return SvROK(rv) ? (CV*)SvRV(rv) : NULL; } break; case OP_GV: return GvCV(cGVOPx_gv(rvop)); default: return NULL; } } static PTR_TBL_t *ppmap; static OP *(*nxck_entersub)(pTHX_ OP *o); static OP *myck_entersub(pTHX_ OP *op) { OP *pushop, *cvop, *aop, *bop; CV *cv; OP *(*ppfunc)(pTHX); I32 cvflags; pushop = cUNOPx(op)->op_first; if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first; for(cvop = pushop; cvop->op_sibling; cvop = cvop->op_sibling) ; if(!(cvop->op_type == OP_RV2CV && !(cvop->op_private & OPpENTERSUB_AMPER) && (cv = rvop_cv(cUNOPx(cvop)->op_first)) && (ppfunc = DPTR2FPTR(OP*(*)(pTHX), ptr_table_fetch(ppmap, cv))))) return nxck_entersub(aTHX_ op); cvflags = CvXSUBANY(cv).any_i32; op = nxck_entersub(aTHX_ op); /* for prototype checking */ aop = pushop->op_sibling; bop = aop->op_sibling; if(bop == cvop) { if(!(cvflags & PC_ALLOW_UNARY)) return op; unary: pushop->op_sibling = bop; aop->op_sibling = NULL; op_free(op); op = newUNOP(OP_NULL, 0, aop); op->op_type = OP_RAND; op->op_ppaddr = ppfunc; op->op_private = (U8)cvflags; return op; } else if(bop && bop->op_sibling == cvop) { if(!(cvflags & PC_ALLOW_BINARY)) return op; if(ppfunc == THX_pp_check_sclass && (cvflags & PC_TYPE_MASK) == SCLASS_REF) { I32 rtype; cvflags &= ~PC_TYPE_MASK; if(bop->op_type == OP_CONST && (rtype = read_reftype_or_neg(cSVOPx_sv(bop))) >= 0) { cvflags |= rtype; ppfunc = THX_pp_check_rtype; goto unary; } ppfunc = THX_pp_check_dyn_rtype; } else if(ppfunc == THX_pp_check_sclass && (cvflags & PC_TYPE_MASK) == SCLASS_BLESSED) { cvflags &= ~PC_TYPE_MASK; ppfunc = THX_pp_check_dyn_battr; } pushop->op_sibling = cvop; aop->op_sibling = NULL; bop->op_sibling = NULL; op_free(op); op = newBINOP(OP_NULL, 0, aop, bop); op->op_type = OP_RAND; op->op_ppaddr = ppfunc; op->op_private = (U8)cvflags; return op; } else { return op; } } MODULE = Params::Classify PACKAGE = Params::Classify PROTOTYPES: DISABLE BOOT: { int i; SV *tsv = sv_2mortal(newSV(0)); ppmap = ptr_table_new(); #define SETUP_SIMPLE_UNARY_XSUB(NAME) \ do { \ CV *cv = newXSproto_portable("Params::Classify::"#NAME, \ THX_xsfunc_##NAME, __FILE__, "$"); \ CvXSUBANY(cv).any_i32 = PC_ALLOW_UNARY; \ ptr_table_store(ppmap, FPTR2DPTR(void*, cv), \ FPTR2DPTR(void*, THX_pp_##NAME)); \ } while(0) SETUP_SIMPLE_UNARY_XSUB(scalar_class); SETUP_SIMPLE_UNARY_XSUB(ref_type); SETUP_SIMPLE_UNARY_XSUB(blessed_class); for(i = SCLASS_COUNT; i--; ) { bool is_refish = i >= SCLASS_REF; struct sclass_metadata *sclassmeta = &sclass_metadata[i]; char const *keyword_pv = sclassmeta->keyword_pv, *p; char lckeyword[8], *q; I32 cvflags = PC_ALLOW_UNARY | (is_refish ? PC_ALLOW_BINARY : 0) | i; I32 variant = (i == SCLASS_BLESSED ? PC_ABLE : 0) | PC_CROAK; void (*xsfunc)(pTHX_ CV*) = i == SCLASS_REF ? THX_xsfunc_check_ref : i == SCLASS_BLESSED ? THX_xsfunc_check_blessed : THX_xsfunc_check_sclass; for(p = keyword_pv, q = lckeyword; *p; p++, q++) *q = *p | 0x20; *q = 0; sclassmeta->keyword_sv = newSVpvn_share(keyword_pv, strlen(keyword_pv), 0); for(; variant >= 0; variant -= PC_CROAK) { CV *cv; sv_setpvf(tsv, "Params::Classify::%s_%s", variant & PC_CROAK ? "check" : "is", variant & PC_ABLE ? "able" : variant & PC_STRICTBLESS ? "strictly_blessed" : lckeyword); cv = newXSproto_portable(SvPVX(tsv), xsfunc, __FILE__, is_refish ? "$;$" : "$"); CvXSUBANY(cv).any_i32 = cvflags | variant; ptr_table_store(ppmap, cv, FPTR2DPTR(void*, THX_pp_check_sclass)); } } for(i = RTYPE_COUNT; i--; ) { struct rtype_metadata *rtypemeta = &rtype_metadata[i]; rtypemeta->keyword_sv = newSVpvn_share(rtypemeta->keyword_pv, strlen(rtypemeta->keyword_pv), 0); } nxck_entersub = PL_check[OP_ENTERSUB]; PL_check[OP_ENTERSUB] = myck_entersub; } Params-Classify-0.013/lib/Params/Classify.pm000444001750001750 3604611470565443 20751 0ustar00zeframzefram000000000000=head1 NAME Params::Classify - argument type classification =head1 SYNOPSIS use Params::Classify qw( scalar_class is_undef check_undef is_string check_string is_number check_number is_glob check_glob is_regexp check_regexp is_ref check_ref ref_type is_blessed check_blessed blessed_class is_strictly_blessed check_strictly_blessed is_able check_able ); $c = scalar_class($arg); if(is_undef($arg)) { check_undef($arg); if(is_string($arg)) { check_string($arg); if(is_number($arg)) { check_number($arg); if(is_glob($arg)) { check_glob($arg); if(is_regexp($arg)) { check_regexp($arg); if(is_ref($arg)) { check_ref($arg); $t = ref_type($arg); if(is_ref($arg, "HASH")) { check_ref($arg, "HASH"); if(is_blessed($arg)) { check_blessed($arg); if(is_blessed($arg, "IO::Handle")) { check_blessed($arg, "IO::Handle"); $c = blessed_class($arg); if(is_strictly_blessed($arg, "IO::Pipe::End")) { check_strictly_blessed($arg, "IO::Pipe::End"); if(is_able($arg, ["print", "flush"])) { check_able($arg, ["print", "flush"]); =head1 DESCRIPTION This module provides various type-testing functions. These are intended for functions that, unlike most Perl code, care what type of data they are operating on. For example, some functions wish to behave differently depending on the type of their arguments (like overloaded functions in C++). There are two flavours of function in this module. Functions of the first flavour only provide type classification, to allow code to discriminate between argument types. Functions of the second flavour package up the most common type of type discrimination: checking that an argument is of an expected type. The functions come in matched pairs, of the two flavours, and so the type enforcement functions handle only the simplest requirements for arguments of the types handled by the classification functions. Enforcement of more complex types may, of course, be built using the classification functions, or it may be more convenient to use a module designed for the more complex job, such as L. This module is implemented in XS, with a pure Perl backup version for systems that can't handle XS. =cut package Params::Classify; { use 5.006001; } use warnings; use strict; our $VERSION = "0.013"; use parent "Exporter"; our @EXPORT_OK = qw( scalar_class is_undef check_undef is_string check_string is_number check_number is_glob check_glob is_regexp check_regexp is_ref check_ref ref_type is_blessed check_blessed blessed_class is_strictly_blessed check_strictly_blessed is_able check_able ); eval { local $SIG{__DIE__}; require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); }; if($@ eq "") { close(DATA); } else { (my $filename = __FILE__) =~ tr# -~##cd; local $/ = undef; my $pp_code = "#line 128 \"$filename\"\n".; close(DATA); { local $SIG{__DIE__}; eval $pp_code; } die $@ if $@ ne ""; } sub is_string($); sub is_number($) { return 0 unless &is_string; my $warned; local $SIG{__WARN__} = sub { $warned = 1; }; my $arg = $_[0]; { no warnings "void"; 0 + $arg; } return !$warned; } sub check_number($) { die "argument is not a number\n" unless &is_number; } 1; __DATA__ use Scalar::Util 1.01 qw(blessed reftype); =head1 TYPE CLASSIFICATION This module divides up scalar values into the following classes: =over =item * undef =item * string (defined ordinary scalar) =item * typeglob (yes, typeglobs fit into scalar variables) =item * regexp (first-class regular expression objects in Perl 5.11 onwards) =item * reference to unblessed object (further classified by physical data type of the referenced object) =item * reference to blessed object (further classified by class blessed into) =back These classes are mutually exclusive and should be exhaustive. This classification has been chosen as the most useful when one wishes to discriminate between types of scalar. Other classifications are possible. (For example, the two reference classes are distinguished by a feature of the referenced object; Perl does not internally treat this as a feature of the reference.) =head1 FUNCTIONS Each of these functions takes one scalar argument (I) to be tested, possibly with other arguments specifying details of the test. Any scalar value is acceptable for the argument to be tested. Each C function returns a simple truth value result, which is true iff I is of the type being checked for. Each C function will return normally if the argument is of the type being checked for, or will C if it is not. =head2 Classification =over =item scalar_class(ARG) Determines which of the five classes described above I falls into. Returns "B", "B", "B", "B", "B", or "B" accordingly. =cut sub scalar_class($) { my $type = reftype(\$_[0]); if($type eq "SCALAR") { $type = defined($_[0]) ? "STRING" : "UNDEF"; } elsif($type eq "REF") { $type = "BLESSED" if defined(blessed($_[0])); } $type; } =back =head2 The Undefined Value =over =item is_undef(ARG) =item check_undef(ARG) Check whether I is C. C is precisely equivalent to C, and is included for completeness. =cut sub is_undef($) { !defined($_[0]) } sub check_undef($) { die "argument is not undefined\n" unless &is_undef; } =back =head2 Strings =over =item is_string(ARG) =item check_string(ARG) Check whether I is defined and is an ordinary scalar value (not a reference, typeglob, or regexp). This is what one usually thinks of as a string in Perl. In fact, any scalar (including C and references) can be coerced to a string, but if you're trying to classify a scalar then you don't want to do that. =cut sub is_string($) { defined($_[0]) && reftype(\$_[0]) eq "SCALAR" } sub check_string($) { die "argument is not a string\n" unless &is_string; } =item is_number(ARG) =item check_number(ARG) Check whether I is defined and an ordinary scalar (i.e., satisfies L above) and is an acceptable number to Perl. This is what one usually thinks of as a number. Note that simple (L-satisfying) scalars may have independent numeric and string values, despite the usual pretence that they have only one value. Such a scalar is deemed to be a number if I it already has a numeric value (e.g., was generated by a numeric literal or an arithmetic computation) I its string value has acceptable syntax for a number (so it can be converted). Where a scalar has separate numeric and string values (see L), it is possible for it to have an acceptable numeric value while its string value does I have acceptable numeric syntax. Be careful to use such a value only in a numeric context, if you are using it as a number. L extracts the numeric part of a scalar as an ordinary number. (C<0+ARG> suffices for that unless you need to preserve floating point signed zeroes.) A number may be either a native integer or a native floating point value, and there are several subtypes of floating point value. For classification, and other handling of numbers in scalars, see L. For details of the two numeric data types, see L and L. This function differs from C (see L; also L for a lower-level description) in excluding C, typeglobs, and references. Why C returns true for C or typeglobs is anybody's guess. References, if treated as numbers, evaluate to the address in memory that they reference; this is useful for comparing references for equality, but it is not otherwise useful to treat references as numbers. Blessed references may have overloaded numeric operators, but if so then they don't necessarily behave like ordinary numbers. C is also confused by dualvars: it looks at the string portion of the scalar. =back =head2 Typeglobs =over =item is_glob(ARG) =item check_glob(ARG) Check whether I is a typeglob. =cut sub is_glob($) { reftype(\$_[0]) eq "GLOB" } sub check_glob($) { die "argument is not a typeglob\n" unless &is_glob; } =back =head2 Regexps =over =item is_regexp(ARG) =item check_regexp(ARG) Check whether I is a regexp object. =cut sub is_regexp($) { reftype(\$_[0]) eq "REGEXP" } sub check_regexp($) { die "argument is not a regexp\n" unless &is_regexp; } =back =head2 References to Unblessed Objects =over =item is_ref(ARG) =item check_ref(ARG) Check whether I is a reference to an unblessed object. If it is, then the referenced data type can be determined using C (see below), which will return a string such as "HASH" or "SCALAR". =item ref_type(ARG) Returns C if I is not a reference to an unblessed object. Otherwise, determines what type of object is referenced. Returns "B", "B", "B", "B", "B", or "B" accordingly. Note that, unlike C, this does not distinguish between different types of referenced scalar. A reference to a string and a reference to a reference will both return "B". Consequently, what C returns for a particular reference will not change due to changes in the value of the referent, except for the referent being blessed. =item is_ref(ARG, TYPE) =item check_ref(ARG, TYPE) Check whether I is a reference to an unblessed object of type I, as determined by L. I must be a string. Possible Is are "B", "B", "B", "B", "B", and "B". =cut { my %xlate_reftype = ( REF => "SCALAR", SCALAR => "SCALAR", LVALUE => "SCALAR", GLOB => "SCALAR", REGEXP => "SCALAR", ARRAY => "ARRAY", HASH => "HASH", CODE => "CODE", FORMAT => "FORMAT", IO => "IO", ); my %reftype_ok = map { ($_ => undef) } qw( SCALAR ARRAY HASH CODE FORMAT IO ); sub ref_type($) { my $reftype = &reftype; return undef unless defined($reftype) && !defined(blessed($_[0])); my $xlated_reftype = $xlate_reftype{$reftype}; die "unknown reftype `$reftype', please update Params::Classify" unless defined $xlated_reftype; $xlated_reftype; } sub is_ref($;$) { if(@_ == 2) { die "reference type argument is not a string\n" unless is_string($_[1]); die "invalid reference type\n" unless exists $reftype_ok{$_[1]}; } my $reftype = reftype($_[0]); return undef unless defined($reftype) && !defined(blessed($_[0])); return 1 if @_ != 2; my $xlated_reftype = $xlate_reftype{$reftype}; die "unknown reftype `$reftype', please update Params::Classify" unless defined $xlated_reftype; return $xlated_reftype eq $_[1]; } } sub check_ref($;$) { unless(&is_ref) { die "argument is not a reference to plain ". (@_ == 2 ? lc($_[1]) : "object")."\n"; } } =back =head2 References to Blessed Objects =over =item is_blessed(ARG) =item check_blessed(ARG) Check whether I is a reference to a blessed object. If it is, then the class into which the object was blessed can be determined using L. =item is_blessed(ARG, CLASS) =item check_blessed(ARG, CLASS) Check whether I is a reference to a blessed object that claims to be an instance of I (via its C method; see L). I must be a string, naming a Perl class. =cut sub is_blessed($;$) { die "class argument is not a string\n" if @_ == 2 && !is_string($_[1]); return defined(blessed($_[0])) && (@_ != 2 || $_[0]->isa($_[1])); } sub check_blessed($;$) { unless(&is_blessed) { die "argument is not a reference to blessed ". (@_ == 2 ? $_[1] : "object")."\n"; } } =item blessed_class(ARG) Returns C if I is not a reference to a blessed object. Otherwise, returns the class into which the object is blessed. C (see L) gives the same result on references to blessed objects, but different results on other types of value. C is actually identical to L. =cut *blessed_class = \&blessed; =item is_strictly_blessed(ARG) =item check_strictly_blessed(ARG) Check whether I is a reference to a blessed object, identically to L. This exists only for symmetry; the useful form of C appears below. =item is_strictly_blessed(ARG, CLASS) =item check_strictly_blessed(ARG, CLASS) Check whether I is a reference to an object blessed into I exactly. I must be a string, naming a Perl class. Because this excludes subclasses, this is rarely what one wants, but there are some specialised occasions where it is useful. =cut sub is_strictly_blessed($;$) { return &is_blessed unless @_ == 2; die "class argument is not a string\n" unless is_string($_[1]); my $blessed = blessed($_[0]); return defined($blessed) && $blessed eq $_[1]; } sub check_strictly_blessed($;$) { return &check_blessed unless @_ == 2; unless(&is_strictly_blessed) { die "argument is not a reference to strictly blessed $_[1]\n"; } } =item is_able(ARG) =item check_able(ARG) Check whether I is a reference to a blessed object, identically to L. This exists only for symmetry; the useful form of C appears below. =item is_able(ARG, METHODS) =item check_able(ARG, METHODS) Check whether I is a reference to a blessed object that claims to implement the methods specified by I (via its C method; see L). I must be either a single method name or a reference to an array of method names. Each method name is a string. This interface check is often more appropriate than a direct ancestry check (such as L performs). =cut sub _check_methods_arg($) { return if &is_string; die "methods argument is not a string or array\n" unless is_ref($_[0], "ARRAY"); foreach(@{$_[0]}) { die "method name is not a string\n" unless is_string($_); } } sub is_able($;$) { return &is_blessed unless @_ == 2; _check_methods_arg($_[1]); return 0 unless defined blessed $_[0]; foreach my $method (ref($_[1]) eq "" ? $_[1] : @{$_[1]}) { return 0 unless $_[0]->can($method); } return 1; } sub check_able($;$) { return &check_blessed unless @_ == 2; _check_methods_arg($_[1]); unless(defined blessed $_[0]) { my $desc = ref($_[1]) eq "" ? "method \"$_[1]\"" : @{$_[1]} == 0 ? "at all" : "method \"".$_[1]->[0]."\""; die "argument is not able to perform $desc\n"; } foreach my $method (ref($_[1]) eq "" ? $_[1] : @{$_[1]}) { die "argument is not able to perform method \"$method\"\n" unless $_[0]->can($method); } } =back =head1 BUGS Probably ought to handle something like L's scalar type specification system, which makes much the same distinctions. =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Andrew Main (Zefram) =head1 COPYRIGHT Copyright (C) 2004, 2006, 2007, 2009, 2010 Andrew Main (Zefram) Copyright (C) 2009, 2010 PhotoBox Ltd =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Params-Classify-0.013/lib/Params/.cvsignore000444001750001750 1311470565443 20537 0ustar00zeframzefram000000000000Classify.c Params-Classify-0.013/t000755001750001750 011470565443 14722 5ustar00zeframzefram000000000000Params-Classify-0.013/t/pod_cvg_pp.t000444001750001750 14511470565443 17344 0ustar00zeframzefram000000000000use warnings; use strict; do "t/setup_pp.pl" or die $@ || $!; do "t/pod_cvg.t" or die $@ || $!; 1; Params-Classify-0.013/t/setup_pp.pl000444001750001750 33111470565443 17230 0ustar00zeframzefram000000000000require XSLoader; my $orig_load = \&XSLoader::load; no warnings "redefine"; *XSLoader::load = sub { die "XS loading disabled for Params::Classify" if ($_[0] || "") eq "Params::Classify"; goto &$orig_load; }; 1; Params-Classify-0.013/t/check_pp.t000444001750001750 14311470565443 16776 0ustar00zeframzefram000000000000use warnings; use strict; do "t/setup_pp.pl" or die $@ || $!; do "t/check.t" or die $@ || $!; 1; Params-Classify-0.013/t/pod_cvg.t000444001750001750 27311470565443 16647 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod::Coverage not available" unless eval "use Test::Pod::Coverage; 1"; Test::Pod::Coverage::all_pod_coverage_ok(); 1; Params-Classify-0.013/t/classify_pp.t000444001750001750 14611470565443 17541 0ustar00zeframzefram000000000000use warnings; use strict; do "t/setup_pp.pl" or die $@ || $!; do "t/classify.t" or die $@ || $!; 1; Params-Classify-0.013/t/classify.t000444001750001750 333211470565443 17062 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 1 + 2*8*11; BEGIN { use_ok "Params::Classify", qw( scalar_class is_undef is_string is_number is_glob is_regexp is_ref is_blessed ); } sub test_scalar_classification($$$$$$$$$) { my(undef, $class, $iu, $is, $in, $ig, $ix, $ir, $ib) = @_; is(scalar_class($_[0]), $class); is(&scalar_class($_[0]), $class); is(!!is_undef($_[0]), !!$iu); is(!!&is_undef($_[0]), !!$iu); is(!!is_string($_[0]), !!$is); is(!!&is_string($_[0]), !!$is); is(!!is_number($_[0]), !!$in); is(!!&is_number($_[0]), !!$in); is(!!is_glob($_[0]), !!$ig); is(!!&is_glob($_[0]), !!$ig); is(!!is_regexp($_[0]), !!$ix); is(!!&is_regexp($_[0]), !!$ix); is(!!is_ref($_[0]), !!$ir); is(!!&is_ref($_[0]), !!$ir); is(!!is_blessed($_[0]), !!$ib); is(!!&is_blessed($_[0]), !!$ib); } test_scalar_classification(undef, "UNDEF", 1, 0, 0, 0, 0, 0, 0); test_scalar_classification("", "STRING", 0, 1, 0, 0, 0, 0, 0); test_scalar_classification("abc", "STRING", 0, 1, 0, 0, 0, 0, 0); test_scalar_classification(123, "STRING", 0, 1, 1, 0, 0, 0, 0); test_scalar_classification(0, "STRING", 0, 1, 1, 0, 0, 0, 0); test_scalar_classification("0 but true", "STRING", 0, 1, 1, 0, 0, 0, 0); test_scalar_classification("1ab", "STRING", 0, 1, 0, 0, 0, 0, 0); test_scalar_classification(*STDOUT, "GLOB", 0, 0, 0, 1, 0, 0, 0); SKIP: { skip "no first-class regexps", 2*8 unless "$]" >= 5.011; test_scalar_classification(${qr/xyz/}, "REGEXP", 0, 0, 0, 0, 1, 0, 0); } test_scalar_classification({}, "REF", 0, 0, 0, 0, 0, 1, 0); test_scalar_classification(bless({}, "main"), "BLESSED", 0, 0, 0, 0, 0, 0, 1); 1; Params-Classify-0.013/t/ref.t000444001750001750 322611470565443 16023 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 1 + 2*14*12; BEGIN { use_ok "Params::Classify", qw(is_ref ref_type); } format foo = . my $foo = ""; sub test_ref_type($$) { my($scalar, $reftype) = @_; is(ref_type($scalar), $reftype); is(&ref_type($scalar), $reftype); is(!!is_ref($scalar), !!$reftype); is(!!&is_ref($scalar), !!$reftype); $reftype = "" if !defined($reftype); is(!!is_ref($scalar, "SCALAR"), "SCALAR" eq $reftype); is(!!&is_ref($scalar, "SCALAR"), "SCALAR" eq $reftype); is(!!is_ref($scalar, "ARRAY"), "ARRAY" eq $reftype); is(!!&is_ref($scalar, "ARRAY"), "ARRAY" eq $reftype); is(!!is_ref($scalar, "HASH"), "HASH" eq $reftype); is(!!&is_ref($scalar, "HASH"), "HASH" eq $reftype); is(!!is_ref($scalar, "CODE"), "CODE" eq $reftype); is(!!&is_ref($scalar, "CODE"), "CODE" eq $reftype); is(!!is_ref($scalar, "FORMAT"), "FORMAT" eq $reftype); is(!!&is_ref($scalar, "FORMAT"), "FORMAT" eq $reftype); is(!!is_ref($scalar, "IO"), "IO" eq $reftype); is(!!&is_ref($scalar, "IO"), "IO" eq $reftype); foreach my $type (qw(SCALAR ARRAY HASH CODE FORMAT IO)) { is(!!is_ref($scalar, $type), $type eq $reftype); is(!!&is_ref($scalar, $type), $type eq $reftype); } } test_ref_type(undef, undef); test_ref_type("foo", undef); test_ref_type(123, undef); test_ref_type(*STDOUT, undef); test_ref_type(bless({}, "main"), undef); test_ref_type(\1, "SCALAR"); test_ref_type(\\1, "SCALAR"); test_ref_type(\pos($foo), "SCALAR"); test_ref_type([], "ARRAY"); test_ref_type({}, "HASH"); test_ref_type(\&is, "CODE"); SKIP: { my $format = *foo{FORMAT}; skip "this Perl doesn't do *foo{FORMAT}", 2*14 unless defined $format; test_ref_type($format, "FORMAT"); } 1; Params-Classify-0.013/t/ref_pp.t000444001750001750 14111470565443 16473 0ustar00zeframzefram000000000000use warnings; use strict; do "t/setup_pp.pl" or die $@ || $!; do "t/ref.t" or die $@ || $!; 1; Params-Classify-0.013/t/error_pp.t000444001750001750 14311470565443 17052 0ustar00zeframzefram000000000000use warnings; use strict; do "t/setup_pp.pl" or die $@ || $!; do "t/error.t" or die $@ || $!; 1; Params-Classify-0.013/t/pod_syn.t000444001750001750 23611470565443 16700 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod not available" unless eval "use Test::Pod 1.00; 1"; Test::Pod::all_pod_files_ok(); 1; Params-Classify-0.013/t/error.t000444001750001750 536511470565443 16406 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 1 + (4*3 + 8 + 8*3 + 8*3)*6; BEGIN { use_ok "Params::Classify", qw( is_ref check_ref is_blessed check_blessed is_strictly_blessed check_strictly_blessed is_able check_able ); } foreach my $arg ( undef, "foo", *STDOUT, bless({}, "main"), \1, {}, ) { foreach my $type (undef, *STDOUT, {}) { eval { is_ref($arg, $type); }; is $@, "reference type argument is not a string\n"; eval { &is_ref($arg, $type); }; is $@, "reference type argument is not a string\n"; eval { check_ref($arg, $type); }; is $@, "reference type argument is not a string\n"; eval { &check_ref($arg, $type); }; is $@, "reference type argument is not a string\n"; } eval { is_ref($arg, "WIBBLE"); }; is $@, "invalid reference type\n"; eval { &is_ref($arg, "WIBBLE"); }; is $@, "invalid reference type\n"; eval { check_ref($arg, "WIBBLE"); }; is $@, "invalid reference type\n"; eval { &check_ref($arg, "WIBBLE"); }; is $@, "invalid reference type\n"; my $type = "WIBBLE"; eval { is_ref($arg, $type); }; is $@, "invalid reference type\n"; eval { &is_ref($arg, $type); }; is $@, "invalid reference type\n"; eval { check_ref($arg, $type); }; is $@, "invalid reference type\n"; eval { &check_ref($arg, $type); }; is $@, "invalid reference type\n"; foreach my $class (undef, *STDOUT, {}) { eval { is_blessed($arg, $class); }; is $@, "class argument is not a string\n"; eval { &is_blessed($arg, $class); }; is $@, "class argument is not a string\n"; eval { check_blessed($arg, $class); }; is $@, "class argument is not a string\n"; eval { &check_blessed($arg, $class); }; is $@, "class argument is not a string\n"; eval { is_strictly_blessed($arg, $class); }; is $@, "class argument is not a string\n"; eval { &is_strictly_blessed($arg, $class); }; is $@, "class argument is not a string\n"; eval { check_strictly_blessed($arg, $class); }; is $@, "class argument is not a string\n"; eval { &check_strictly_blessed($arg, $class); }; is $@, "class argument is not a string\n"; } foreach my $meth (undef, *STDOUT, {}) { eval { is_able($arg, $meth); }; is $@, "methods argument is not a string or array\n"; eval { &is_able($arg, $meth); }; is $@, "methods argument is not a string or array\n"; eval { check_able($arg, $meth); }; is $@, "methods argument is not a string or array\n"; eval { &check_able($arg, $meth); }; is $@, "methods argument is not a string or array\n"; eval { is_able($arg, [$meth]); }; is $@, "method name is not a string\n"; eval { &is_able($arg, [$meth]); }; is $@, "method name is not a string\n"; eval { check_able($arg, [$meth]); }; is $@, "method name is not a string\n"; eval { &check_able($arg, [$meth]); }; is $@, "method name is not a string\n"; } } 1; Params-Classify-0.013/t/blessed_pp.t000444001750001750 14511470565443 17344 0ustar00zeframzefram000000000000use warnings; use strict; do "t/setup_pp.pl" or die $@ || $!; do "t/blessed.t" or die $@ || $!; 1; Params-Classify-0.013/t/blessed.t000444001750001750 321611470565443 16667 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 1 + 2*(4 + 2*4 + 5)*8; @B::ISA = qw(A); sub A::flange { } BEGIN { use_ok "Params::Classify", qw( is_blessed blessed_class is_strictly_blessed is_able ); } my @class_names = qw(UNIVERSAL qwerty A B); my @method_names = qw(qwerty can isa print flange); sub test_blessed($$@) { my($scalar, $class, $isb, @expect) = @_; is(blessed_class($scalar), $class); is(&blessed_class($scalar), $class); is(!!is_blessed($scalar), !!$isb); is(!!&is_blessed($scalar), !!$isb); is(!!is_strictly_blessed($scalar), !!$isb); is(!!&is_strictly_blessed($scalar), !!$isb); is(!!is_able($scalar), !!$isb); is(!!&is_able($scalar), !!$isb); foreach my $cn (@class_names) { my $state = shift(@expect); is(!!is_blessed($scalar, $cn), !!$state); is(!!&is_blessed($scalar, $cn), !!$state); is(!!is_strictly_blessed($scalar, $cn), $state eq 2); is(!!&is_strictly_blessed($scalar, $cn), $state eq 2); } foreach my $mn (@method_names) { my $expect = !!shift(@expect); is(!!is_able($scalar, $mn), $expect); is(!!&is_able($scalar, $mn), $expect); } } test_blessed(undef, undef, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); test_blessed("foo", undef, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); test_blessed(123, undef, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); test_blessed(*STDOUT, undef, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); test_blessed({}, undef, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); test_blessed(bless({}, "main"), "main", 1, 1, 0, 0, 0, 0, 1, 1, 0, 0); test_blessed(bless({}, "A"), "A", 1, 1, 0, 2, 0, 0, 1, 1, 0, 1); test_blessed(bless({}, "B"), "B", 1, 1, 0, 1, 2, 0, 1, 1, 0, 1); 1; Params-Classify-0.013/t/check.t000444001750001750 1346611470565443 16353 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 1 + 2*28*21; BEGIN { use_ok "Params::Classify", map { ("is_$_", "check_$_") } qw( undef string number glob regexp ref blessed strictly_blessed able ); } format foo = . my $foo = ""; @B::ISA = qw(A); sub A::flange { } foreach( undef, "", "abc", 123, 0, "0 but true", "1ab", *STDOUT, ${qr/xyz/}, \"", \\"", \pos($foo), [], {}, \&is, do { my $format = *foo{FORMAT}; defined($format) ? $format : undef; }, bless({}, "main"), bless({}, "ARRAY"), bless({}, "HASH"), bless({}, "A"), bless({}, "B"), ) { eval { check_undef($_); }; is $@, is_undef($_) ? "" : "argument is not undefined\n"; eval { &check_undef($_); }; is $@, is_undef($_) ? "" : "argument is not undefined\n"; eval { check_string($_); }; is $@, is_string($_) ? "" : "argument is not a string\n"; eval { &check_string($_); }; is $@, is_string($_) ? "" : "argument is not a string\n"; eval { check_number($_); }; is $@, is_number($_) ? "" : "argument is not a number\n"; eval { &check_number($_); }; is $@, is_number($_) ? "" : "argument is not a number\n"; eval { check_glob($_); }; is $@, is_glob($_) ? "" : "argument is not a typeglob\n"; eval { &check_glob($_); }; is $@, is_glob($_) ? "" : "argument is not a typeglob\n"; eval { check_regexp($_); }; is $@, is_regexp($_) ? "" : "argument is not a regexp\n"; eval { &check_regexp($_); }; is $@, is_regexp($_) ? "" : "argument is not a regexp\n"; eval { check_ref($_); }; is $@, is_ref($_) ? "" : "argument is not a reference to plain object\n"; eval { &check_ref($_); }; is $@, is_ref($_) ? "" : "argument is not a reference to plain object\n"; eval { check_ref($_, "SCALAR"); }; is $@, is_ref($_, "SCALAR") ? "" : "argument is not a reference to plain scalar\n"; eval { &check_ref($_, "SCALAR"); }; is $@, is_ref($_, "SCALAR") ? "" : "argument is not a reference to plain scalar\n"; eval { check_ref($_, "ARRAY"); }; is $@, is_ref($_, "ARRAY") ? "" : "argument is not a reference to plain array\n"; eval { &check_ref($_, "ARRAY"); }; is $@, is_ref($_, "ARRAY") ? "" : "argument is not a reference to plain array\n"; eval { check_ref($_, "HASH"); }; is $@, is_ref($_, "HASH") ? "" : "argument is not a reference to plain hash\n"; eval { &check_ref($_, "HASH"); }; is $@, is_ref($_, "HASH") ? "" : "argument is not a reference to plain hash\n"; eval { check_ref($_, "CODE"); }; is $@, is_ref($_, "CODE") ? "" : "argument is not a reference to plain code\n"; eval { &check_ref($_, "CODE"); }; is $@, is_ref($_, "CODE") ? "" : "argument is not a reference to plain code\n"; eval { check_ref($_, "FORMAT"); }; is $@, is_ref($_, "FORMAT") ? "" : "argument is not a reference to plain format\n"; eval { &check_ref($_, "FORMAT"); }; is $@, is_ref($_, "FORMAT") ? "" : "argument is not a reference to plain format\n"; eval { check_ref($_, "IO"); }; is $@, is_ref($_, "IO") ? "" : "argument is not a reference to plain io\n"; eval { &check_ref($_, "IO"); }; is $@, is_ref($_, "IO") ? "" : "argument is not a reference to plain io\n"; foreach my $type (qw(SCALAR ARRAY HASH CODE FORMAT IO)) { eval { check_ref($_, $type); }; is $@, is_ref($_, $type) ? "" : "argument is not a reference to plain @{[lc($type)]}\n"; eval { &check_ref($_, $type); }; is $@, is_ref($_, $type) ? "" : "argument is not a reference to plain @{[lc($type)]}\n"; } eval { check_blessed($_); }; is $@, is_blessed($_) ? "" : "argument is not a reference to blessed object\n"; eval { &check_blessed($_); }; is $@, is_blessed($_) ? "" : "argument is not a reference to blessed object\n"; eval { check_blessed($_, "A"); }; is $@, is_blessed($_, "A") ? "" : "argument is not a reference to blessed A\n"; eval { &check_blessed($_, "A"); }; is $@, is_blessed($_, "A") ? "" : "argument is not a reference to blessed A\n"; eval { check_blessed($_, "B"); }; is $@, is_blessed($_, "B") ? "" : "argument is not a reference to blessed B\n"; eval { &check_blessed($_, "B"); }; is $@, is_blessed($_, "B") ? "" : "argument is not a reference to blessed B\n"; eval { check_strictly_blessed($_); }; is $@, is_blessed($_) ? "" : "argument is not a reference to blessed object\n"; eval { &check_strictly_blessed($_); }; is $@, is_blessed($_) ? "" : "argument is not a reference to blessed object\n"; eval { check_strictly_blessed($_, "A"); }; is $@, is_strictly_blessed($_, "A") ? "" : "argument is not a reference to strictly blessed A\n"; eval { &check_strictly_blessed($_, "A"); }; is $@, is_strictly_blessed($_, "A") ? "" : "argument is not a reference to strictly blessed A\n"; eval { check_strictly_blessed($_, "B"); }; is $@, is_strictly_blessed($_, "B") ? "" : "argument is not a reference to strictly blessed B\n"; eval { &check_strictly_blessed($_, "B"); }; is $@, is_strictly_blessed($_, "B") ? "" : "argument is not a reference to strictly blessed B\n"; eval { check_able($_); }; is $@, is_able($_) ? "" : "argument is not a reference to blessed object\n"; eval { &check_able($_); }; is $@, is_able($_) ? "" : "argument is not a reference to blessed object\n"; eval { check_able($_, []); }; is $@, is_able($_, []) ? "" : "argument is not able to perform at all\n"; eval { &check_able($_, []); }; is $@, is_able($_, []) ? "" : "argument is not able to perform at all\n"; eval { check_able($_, "flange"); }; is $@, is_able($_, "flange") ? "" : "argument is not able to perform method \"flange\"\n"; eval { &check_able($_, "flange"); }; is $@, is_able($_, "flange") ? "" : "argument is not able to perform method \"flange\"\n"; eval { check_able($_, ["flange","can"]); }; is $@, is_able($_, ["flange","can"]) ? "" : "argument is not able to perform method \"flange\"\n"; eval { &check_able($_, ["flange","can"]); }; is $@, is_able($_, ["flange","can"]) ? "" : "argument is not able to perform method \"flange\"\n"; } 1;