Params-Classify-0.015000755001750001750 013137120523 14445 5ustar00zeframzefram000000000000Params-Classify-0.015/.gitignore000444001750001750 30113137120515 16545 0ustar00zeframzefram000000000000/Build /Makefile /_build /blib /META.json /META.yml /MYMETA.json /MYMETA.yml /Makefile.PL /SIGNATURE /Params-Classify-* /lib/Params/callchecker0.h /lib/Params/Classify.c /lib/Params/Classify.o Params-Classify-0.015/Build.PL000444001750001750 701013137120515 16075 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 && eval { require ExtUtils::ParseXS; ExtUtils::ParseXS->VERSION(3.30); 1; }; return $self->SUPER::find_xs_files; } sub compile_xs { my($self, $file, %args) = @_; require ExtUtils::ParseXS; ExtUtils::ParseXS->VERSION(3.30); return $self->SUPER::compile_xs($file, %args); } sub compile_c { my($self, $file, %args) = @_; my $cc0_h = $self->localize_file_path("lib/Params/callchecker0.h"); unless(-f $cc0_h) { my $content = eval { local $SIG{__DIE__}; require Devel::CallChecker; Devel::CallChecker->VERSION(0.003); &Devel::CallChecker::callchecker0_h(); } || ""; $self->add_to_cleanup($cc0_h); require IO::File; my $fh = IO::File->new($cc0_h, "w") or die $!; $fh->printflush($content) or die $!; $fh->close or die $!; } return $self->SUPER::compile_c($file, %args); } sub link_c { no strict "refs"; my($self, $spec) = @_; my $cb = $self->cbuilder; my $cbclass = ref($cb); my $orig_cb_link = $cb->can("link"); local *{"${cbclass}::link"} = sub { my($self, %args) = @_; if($args{module_name} eq "Params::Classify") { my $cc_linkables = eval { local $SIG{__DIE__}; require Devel::CallChecker; Devel::CallChecker->VERSION(0.003); [&Devel::CallChecker::callchecker_linkable]; } || []; $args{objects} = [ @{$args{objects}}, @$cc_linkables, ]; } @_ = ($self, %args); goto &$orig_cb_link; }; $self->SUPER::link_c($spec); } })->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 => { "Module::Build" => 0, "Test::More" => 0, "perl" => "5.006001", "strict" => 0, "warnings" => 0, }, build_recommends => { "Devel::CallChecker" => "0.003", "ExtUtils::CBuilder" => "0.15", "ExtUtils::ParseXS" => "3.30", }, requires => { "Exporter" => 0, "Scalar::Util" => "1.01", "parent" => 0, "perl" => "5.006001", "strict" => 0, "warnings" => 0, }, recommends => { "Devel::CallChecker" => "0.003", "XSLoader" => 0, }, needs_compiler => 0, dynamic_config => 0, meta_add => { distribution_type => "module" }, meta_merge => { "meta-spec" => { version => "2" }, resources => { bugtracker => { mailto => "bug-Params-Classify\@rt.cpan.org", web => "https://rt.cpan.org/Public/Dist/". "Display.html?Name=Params-Classify", }, }, }, sign => 1, )->create_build_script; 1; Params-Classify-0.015/Changes000444001750001750 1454013137120515 16122 0ustar00zeframzefram000000000000version 0.015; 2017-07-29 * update for changed S_croak_xs_usage() prototype in ExtUtils::ParseXS 3.30, requiring the new version of that module in order to build the XS implementation * in documentation, use four-column indentation for all verbatim material * in META.{yml,json}, point to public bug tracker * correctly classify ExtUtils::ParseXS dependency as a recommendation rather than a requirement * avoid some compiler warnings version 0.014; 2017-07-16 * port to Perl 5.19.4, where the C type of array indices has changed * update to accommodate PERL_OP_PARENT builds of Perl 5.21.11 or later (which is the default from Perl 5.25.1) * trigger custom op generation via Devel::CallChecker rather than by hooking the underlying op checker * update test suite to not rely on . in @INC, which is no longer necessarily there from Perl 5.25.7 * no longer include a Makefile.PL in the distribution * correct dynamic_config setting to 0 * use boolSV() where appropriate in XS code * use cBOOL() where appropriate * consistently use THX_ prefix on internal function names * include META.json in distribution * convert .cvsignore to .gitignore * add MYMETA.json to .cvsignore version 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.015/MANIFEST000444001750001750 50413137120515 15713 0ustar00zeframzefram000000000000.gitignore Build.PL Changes MANIFEST META.json META.yml README 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.015/META.json000444001750001750 322013137120515 16221 0ustar00zeframzefram000000000000{ "abstract" : "argument type classification", "author" : [ "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Params-Classify", "prereqs" : { "build" : { "requires" : { "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" } }, "runtime" : { "recommends" : { "Devel::CallChecker" : "0.003", "XSLoader" : "0" }, "requires" : { "Exporter" : "0", "Scalar::Util" : "1.01", "parent" : "0", "perl" : "5.006001", "strict" : "0", "warnings" : "0" } } }, "provides" : { "Params::Classify" : { "file" : "lib/Params/Classify.pm", "version" : "0.015" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Params-Classify@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Params-Classify" }, "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.015", "x_serialization_backend" : "JSON::PP version 2.93" } Params-Classify-0.015/META.yml000444001750001750 172713137120515 16063 0ustar00zeframzefram000000000000--- abstract: 'argument type classification' author: - 'Andrew Main (Zefram) ' build_requires: 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' dynamic_config: 0 generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' 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.015' recommends: Devel::CallChecker: '0.003' XSLoader: '0' requires: Exporter: '0' Scalar::Util: '1.01' parent: '0' perl: '5.006001' strict: '0' warnings: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Params-Classify license: http://dev.perl.org/licenses/ version: '0.015' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Params-Classify-0.015/README000444001750001750 302613137120515 15464 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, 2017 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.015/SIGNATURE000644001750001750 401013137120523 16063 0ustar00zeframzefram000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.81. 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 23fe160a5180101b0c60d58b6348de332b8008b9 .gitignore SHA1 7631199ef70df2ec207adc87132825d34e7160c2 Build.PL SHA1 a81a83d2e34ee5e85a8cdc152962e9724f306511 Changes SHA1 54793f1da593406ac164e4dd2ff190f3211c0062 MANIFEST SHA1 240890b30827a235eba2c017c7bbcdceb31abfc2 META.json SHA1 4832e50df1f2b581ac97e832d15f4d6bd861e366 META.yml SHA1 bb0e036b5c11cb7e0e07f909776fb2b973e891cb README SHA1 683529801ed37ce8ac6393836a492fa94137b6f2 lib/Params/Classify.pm SHA1 1cc33ea6793cd87043e868f98e7812610ccac8f5 lib/Params/Classify.xs SHA1 497c90b7b470f8c3a4594265c4a97376000fc2aa t/blessed.t SHA1 7217d9cfb3ff600005ea54634f3776da43b88e4a t/blessed_pp.t SHA1 e05666c5b2480ce441116ff26e55fa5bb07fb741 t/check.t SHA1 2107a86bccaeb55e02dbc51f79cfcabc657d06de t/check_pp.t SHA1 071b996f6953fd005472b99a0ed867404425239a t/classify.t SHA1 0fef2e6f108aeb7cdcfacbbc201fa6c2e32e688d t/classify_pp.t SHA1 29b6f328b7b3c928d455f82d1a0708d821445554 t/error.t SHA1 a1db817b20659750c1acc66816815e9604286b3a t/error_pp.t SHA1 904d9a4f76525e2303e4b0c168c68230f223c8de t/pod_cvg.t SHA1 8b0ef0af30cd5064cf1b3d57c5fdbab11f8c567c t/pod_cvg_pp.t SHA1 65c75abdef6f01a5d1588a307f2ddfe2333dc961 t/pod_syn.t SHA1 8a817d64d2098a5dfa7b65ba87b38314f9b3241e t/ref.t SHA1 a79c42e5e482fbf0c47a40fa4d20db975854fa89 t/ref_pp.t SHA1 97157325ac601fe786026cdc319f958c8ea785ae t/setup_pp.pl -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iEYEARECAAYFAll8oU0ACgkQOV9mt2VyAVHtqQCdHuuvfO8MFk+746FRVvgqXofR u5QAniv1tkNWSQJ/7tbXLX0eweqzmSbS =ni3G -----END PGP SIGNATURE----- Params-Classify-0.015/lib000755001750001750 013137120515 15214 5ustar00zeframzefram000000000000Params-Classify-0.015/lib/Params000755001750001750 013137120515 16437 5ustar00zeframzefram000000000000Params-Classify-0.015/lib/Params/Classify.pm000444001750001750 3631713137120515 20741 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.015"; 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 Devel::CallChecker; Devel::CallChecker->VERSION(0.003); }; 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 137 \"$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, 2017 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.015/lib/Params/Classify.xs000444001750001750 4573513137120515 20763 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "callchecker0.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)) #if !PERL_VERSION_GE(5,7,2) # undef dNOOP # define dNOOP extern int Perl___notused_func(void) #endif /* <5.7.2 */ #ifndef cBOOL # define cBOOL(x) ((bool)!!(x)) #endif /* !cBOOL */ #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 */ #if PERL_VERSION_GE(5,19,4) typedef SSize_t array_ix_t; #else /* <5.19.4 */ typedef I32 array_ix_t; #endif /* <5.19.4 */ #ifndef DPTR2FPTR # define DPTR2FPTR(t,x) ((t)(UV)(x)) #endif /* !DPTR2FPTR */ #ifndef FPTR2DPTR # define FPTR2DPTR(t,x) ((t)(UV)(x)) #endif /* !FPTR2DPTR */ #ifndef OpMORESIB_set # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif /* !OpMORESIB_set */ #ifndef OpSIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) # define OpSIBLING(o) (0 + (o)->op_sibling) #endif /* !OpSIBLING */ #ifdef cv_set_call_checker # define QUSE_CUSTOM_OPS 1 #else /* !cv_set_call_checker */ # define QUSE_CUSTOM_OPS 0 #endif /* !cv_set_call_checker */ #if defined(QUSE_CUSTOM_OPS) && !defined(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 /* QUSE_CUSTOM_OPS && !ptr_table_new */ #if PERL_VERSION_GE(5,7,3) # define PERL_UNUSED_THX() NOOP #else /* <5.7.3 */ # define PERL_UNUSED_THX() ((void)(aTHX+0)) #endif /* <5.7.3 */ #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))) static bool THX_sv_is_undef(pTHX_ SV *sv) { PERL_UNUSED_THX(); return cBOOL(sv_is_undef(sv)); } static bool THX_sv_is_string(pTHX_ SV *sv) { PERL_UNUSED_THX(); return cBOOL(sv_is_string(sv)); } static bool THX_sv_is_glob(pTHX_ SV *sv) { PERL_UNUSED_THX(); return cBOOL(sv_is_glob(sv)); } static bool THX_sv_is_regexp(pTHX_ SV *sv) { PERL_UNUSED_THX(); PERL_UNUSED_ARG(sv); return cBOOL(sv_is_regexp(sv)); } static bool THX_sv_is_untyped_ref(pTHX_ SV *sv) { PERL_UNUSED_THX(); return cBOOL(sv_is_untyped_ref(sv)); } static bool THX_sv_is_untyped_blessed(pTHX_ SV *sv) { PERL_UNUSED_THX(); return cBOOL(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) { PERL_UNUSED_THX(); 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) { PERL_UNUSED_THX(); 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); PERL_UNUSED_THX(); 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 = cBOOL(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 = boolSV(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 = boolSV(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; array_ix_t 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); array_ix_t 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 = boolSV(matches); XPUSHs(result); } PUTBACK; } #if QUSE_CUSTOM_OPS 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; } #endif /* QUSE_CUSTOM_OPS */ #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE static void S_croak_xs_usage(const CV *, const char *); # define croak_xs_usage(cv, params) S_croak_xs_usage(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 */ #if QUSE_CUSTOM_OPS static PTR_TBL_t *ppmap; static OP *THX_ck_entersub_pc(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { CV *cv = (CV*)protosv; OP *(*THX_ppfunc)(pTHX) = DPTR2FPTR(OP*(*)(pTHX), ptr_table_fetch(ppmap, cv)); I32 cvflags = CvXSUBANY(cv).any_i32; OP *pushop, *aop, *bop, *cop, *op; entersubop = ck_entersub_args_proto(entersubop, namegv, protosv); pushop = cUNOPx(entersubop)->op_first; if(!OpHAS_SIBLING(pushop)) pushop = cUNOPx(pushop)->op_first; aop = OpSIBLING(pushop); bop = OpSIBLING(aop); cop = bop ? OpSIBLING(bop) : NULL; if(bop && !cop) { if(!(cvflags & PC_ALLOW_UNARY)) return entersubop; unary: OpMORESIB_set(pushop, bop); OpLASTSIB_set(aop, NULL); op_free(entersubop); op = newUNOP(OP_NULL, 0, aop); op->op_type = OP_RAND; op->op_ppaddr = THX_ppfunc; op->op_private = (U8)cvflags; return op; } else if(cop && !OpHAS_SIBLING(cop)) { if(!(cvflags & PC_ALLOW_BINARY)) return entersubop; if(THX_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; THX_ppfunc = THX_pp_check_rtype; goto unary; } THX_ppfunc = THX_pp_check_dyn_rtype; } else if(THX_ppfunc == THX_pp_check_sclass && (cvflags & PC_TYPE_MASK) == SCLASS_BLESSED) { cvflags &= ~PC_TYPE_MASK; THX_ppfunc = THX_pp_check_dyn_battr; } OpMORESIB_set(pushop, cop); OpLASTSIB_set(aop, NULL); OpLASTSIB_set(bop, NULL); op_free(entersubop); op = newBINOP(OP_NULL, 0, aop, bop); op->op_type = OP_RAND; op->op_ppaddr = THX_ppfunc; op->op_private = (U8)cvflags; return op; } else { return entersubop; } } #endif /* QUSE_CUSTOM_OPS */ MODULE = Params::Classify PACKAGE = Params::Classify PROTOTYPES: DISABLE BOOT: { int i; 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); } } { int i; SV *tsv = sv_2mortal(newSV(0)); #if QUSE_CUSTOM_OPS ppmap = ptr_table_new(); # define SETUP_CUSTOM_OP(pcv, THX_ppfunc) \ do { \ ptr_table_store(ppmap, FPTR2DPTR(void*, pcv), \ FPTR2DPTR(void*, THX_ppfunc)); \ cv_set_call_checker(pcv, THX_ck_entersub_pc, (SV*)pcv); \ } while(0) #else /* !QUSE_CUSTOM_OPS */ # define SETUP_CUSTOM_OP(pcv, THX_ppfunc) ((void)0) #endif /* !QUSE_CUSTOM_OPS */ #define SETUP_SIMPLE_UNARY_XSUB(NAME) \ do { \ CV *pcv = newXSproto_portable("Params::Classify::"#NAME, \ THX_xsfunc_##NAME, __FILE__, "$"); \ CvXSUBANY(pcv).any_i32 = PC_ALLOW_UNARY; \ SETUP_CUSTOM_OP(pcv, 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 (*THX_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 *pcv; sv_setpvf(tsv, "Params::Classify::%s_%s", variant & PC_CROAK ? "check" : "is", variant & PC_ABLE ? "able" : variant & PC_STRICTBLESS ? "strictly_blessed" : lckeyword); pcv = newXSproto_portable(SvPVX(tsv), THX_xsfunc, __FILE__, is_refish ? "$;$" : "$"); CvXSUBANY(pcv).any_i32 = cvflags | variant; SETUP_CUSTOM_OP(pcv, THX_pp_check_sclass); } } } Params-Classify-0.015/t000755001750001750 013137120515 14711 5ustar00zeframzefram000000000000Params-Classify-0.015/t/blessed.t000444001750001750 321613137120515 16656 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.015/t/blessed_pp.t000444001750001750 15113137120515 17330 0ustar00zeframzefram000000000000use warnings; use strict; do "./t/setup_pp.pl" or die $@ || $!; do "./t/blessed.t" or die $@ || $!; 1; Params-Classify-0.015/t/check.t000444001750001750 1346613137120515 16342 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; Params-Classify-0.015/t/check_pp.t000444001750001750 14713137120515 16771 0ustar00zeframzefram000000000000use warnings; use strict; do "./t/setup_pp.pl" or die $@ || $!; do "./t/check.t" or die $@ || $!; 1; Params-Classify-0.015/t/classify.t000444001750001750 333213137120515 17051 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.015/t/classify_pp.t000444001750001750 15213137120515 17525 0ustar00zeframzefram000000000000use warnings; use strict; do "./t/setup_pp.pl" or die $@ || $!; do "./t/classify.t" or die $@ || $!; 1; Params-Classify-0.015/t/error.t000444001750001750 536513137120515 16375 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.015/t/error_pp.t000444001750001750 14713137120515 17045 0ustar00zeframzefram000000000000use warnings; use strict; do "./t/setup_pp.pl" or die $@ || $!; do "./t/error.t" or die $@ || $!; 1; Params-Classify-0.015/t/pod_cvg.t000444001750001750 27313137120515 16636 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.015/t/pod_cvg_pp.t000444001750001750 15113137120515 17330 0ustar00zeframzefram000000000000use warnings; use strict; do "./t/setup_pp.pl" or die $@ || $!; do "./t/pod_cvg.t" or die $@ || $!; 1; Params-Classify-0.015/t/pod_syn.t000444001750001750 23613137120515 16667 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.015/t/ref.t000444001750001750 322613137120515 16012 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.015/t/ref_pp.t000444001750001750 14513137120515 16466 0ustar00zeframzefram000000000000use warnings; use strict; do "./t/setup_pp.pl" or die $@ || $!; do "./t/ref.t" or die $@ || $!; 1; Params-Classify-0.015/t/setup_pp.pl000444001750001750 33113137120515 17217 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;