Devel-CallParser-0.006000755000000000024 015261001060 14020 5ustar00rootstaff000000000000Devel-CallParser-0.006/.gitignore000444000000000024 30315261001057 16127 0ustar00rootstaff000000000000/Build /Makefile /_build /blib /META.json /META.yml /MYMETA.json /MYMETA.yml /Makefile.PL /SIGNATURE /Devel-CallParser-* /lib/Devel/callchecker0.h /lib/Devel/CallParser.c /lib/Devel/CallParser.o Devel-CallParser-0.006/Build.PL000444000000000024 1017115261001057 15477 0ustar00rootstaff000000000000{ 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" }; } sub compile_c { my($self, $file, %args) = @_; my $cc0_h = $self->localize_file_path("lib/Devel/callchecker0.h"); unless(-f $cc0_h) { require Devel::CallChecker; Devel::CallChecker->VERSION(0.001); my $content = &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_prelink = $cb->can("prelink"); local *{"${cbclass}::prelink"} = sub { use strict "refs"; my($self, %args) = @_; if($args{dl_name} eq "Devel::CallParser") { $args{dl_func_list} = [ @{$args{dl_func_list}||[]}, qw( C8K61oRQKxigiqmUlVdk_gcp0 C8K61oRQKxigiqmUlVdk_scp0 ), ("$]" < 5.013008 ? () : qw( C8K61oRQKxigiqmUlVdk_pac0 C8K61oRQKxigiqmUlVdk_paz0 C8K61oRQKxigiqmUlVdk_pau0 C8K61oRQKxigiqmUlVdk_pal0 C8K61oRQKxigiqmUlVdk_pab0 C8K61oRQKxigiqmUlVdk_pap0 C8K61oRQKxigiqmUlVdk_pan0 C8K61oRQKxigiqmUlVdk_gcp1 C8K61oRQKxigiqmUlVdk_scp1 )), ]; $args{dl_funcs} ||= {}; my $pname = $args{dl_name}; unless(exists $args{dl_funcs}->{$pname}) { $args{dl_funcs} = { %{$args{dl_funcs}}, $pname => [], }; } } @_ = ($self, %args); goto &$orig_cb_prelink; }; my $orig_cb_link = $cb->can("link"); local *{"${cbclass}::link"} = sub { my($self, %args) = @_; if($args{module_name} eq "Devel::CallParser") { require Devel::CallChecker; Devel::CallChecker->VERSION(0.002); $args{objects} = [ @{$args{objects}}, Devel::CallChecker::callchecker_linkable(), ]; } @_ = ($self, %args); goto &$orig_cb_link; }; my($libfile, $impfile); if($^O eq "MSWin32") { my $dlext = $cb->{config}->{dlext}; my $libext = $cb->{config}->{lib_ext}; $libfile = $spec->{lib_file}; ($impfile = $libfile) =~ s/\.\Q$dlext\E\z/$libext/ or die "can't generate import library name"; unlink $libfile, $impfile unless $self->up_to_date($libfile, $impfile); } my $orig_cb_flk = $cb->can("format_linker_cmd"); local *{"${cbclass}::format_linker_cmd"} = sub { use strict "refs"; my($self, %spec) = @_; my @cmds = &$orig_cb_flk; my $cf = $self->{config}; my $norm_libfile = $libfile; my $norm_impfile = $impfile; $self->normalize_filespecs( \$norm_libfile, \$norm_impfile); push @cmds, [ $cf->{dlltool} || "dlltool", "--def", $spec{def_file}, "--output-lib", $norm_impfile, "--dllname", $spec{basename}.".".$cf->{dlext}, $spec{output}, ] if $spec{output} eq $norm_libfile; return @cmds; } if $cb->isa("ExtUtils::CBuilder::Platform::Windows::GCC"); $self->SUPER::link_c($spec); if($^O eq "MSWin32") { die "failed to generate import library" unless -e $impfile; $self->add_to_cleanup($impfile); } } })->new( module_name => "Devel::CallParser", license => "perl", configure_requires => { "Module::Build" => 0, "perl" => "5.011002", "strict" => 0, "warnings" => 0, }, build_requires => { "Devel::CallChecker" => "0.002", "DynaLoader" => 0, "ExtUtils::CBuilder" => "0.15", "ExtUtils::ParseXS" => 0, "File::Spec" => 0, "IO::File" => "1.03", "Module::Build" => 0, "Test::More" => 0, "perl" => "5.011002", "strict" => 0, "warnings" => 0, }, requires => { "Devel::CallChecker" => "0.002", "DynaLoader" => 0, "DynaLoader::Functions" => "0.001", "Exporter" => 0, "parent" => 0, "perl" => "5.011002", "strict" => 0, "warnings" => 0, }, conflicts => { "Data::Alias" => "< 1.13", "Devel::Declare" => "< 0.006004", "indirect" => "< 0.27", }, dynamic_config => 0, meta_add => { distribution_type => "module" }, create_makefile_pl => "passthrough", sign => 1, )->create_build_script; 1; Devel-CallParser-0.006/Changes000444000000000024 516015261001057 15460 0ustar00rootstaff000000000000version 0.006 2026-10-05 * Fix MANIFEST version 0.005 2026-09-21 * restore the pad name list as well as the pad when a keyword is declined on ithreads perls: the first "my" of a block opened right after a declined keyword (if, while, print, any of them) was never closed at the block's end and masked an outer lexical of the same name for the rest of the scope. loading the module broke "my" scoping in everything compiled after it. t/blockscope.t. version 0.004 2026-04-16 * Adoption as this is a downstream dep for Object::Proto::Sugar * Fix failing tests where '.' was removed from INC? * Fix cpantester fails on debug perls switch to a rv2cv op that dereferences a code reference, matching what Perl expects as the last child of OP_ENTERSUB newUNOP(OP_RV2CV, 0, newSVOP(OP_CONST, 0, newRV_inc((SV*)cv))); * Fix qerror compatibility across perl versions: declare Perl_qerror via EXTERN_C to fix implicit declaration error on blead perl 5.43.9+ and avoid Perl_yyerror linker failure on Windows * PERL_VERSION_GE is now wrapped in #ifndef so it skips the local definition when Perl's handy.h already defines it * The qerror fallback now checks for Perl_qerror first (older Perls), and falls back to Perl_yyerror * Fix t/leximport.t failures on threaded/debugging Perl builds: add find_lexical_cv() helper that checks %^H hints hash directly for Lexical::Sub CVs before falling back to rv2cv_op_cv() lookup * six developer releases under 0.003* version 0.002; 2013-09-21 * bugfix: allow generated headers to work on API-compatible Perls other than the specific version under which this module was installed * bugfix: work around core bugs relating to the padrange op * load DynaLoader::Functions lazily, because it is only required at build time of users of this module, not required at all in normal runtime * avoid potential circular dependency chain, by requiring a version of DynaLoader::Functions that has reduced its dependencies * in documentation, clarify that the header and linkable functions should be called at build time * test compatibility with indirect, and declare incompatibility with older versions * test compatibility with Sub::StrictDecl * fix a typo in the documentation * convert .cvsignore to .gitignore version 0.001; 2011-05-20 * add callparser_linkable constant to help users link with this module * avoid false test failures with parallel testing * look up Devel::CallChecker linkable library through its callchecker_linkable constant version 0.000; 2011-04-29 * initial released version Devel-CallParser-0.006/MANIFEST000444000000000024 75115261001057 15277 0ustar00rootstaff000000000000.gitignore Build.PL Changes MANIFEST META.json META.yml Makefile.PL README lib/Devel/CallParser.pm lib/Devel/CallParser.xs t/LoadXS.pm t/WriteHeader.pm t/blockscope.t t/dataalias.t t/develdeclare.t t/getset0.t t/getset0.xs t/getset1.t t/getset1.xs t/indirect.t t/leximport.t t/listquote.t t/listquote.xs t/multiblock.t t/multiblock.xs t/no_hdr.t t/padrange.t t/pod_cvg.t t/pod_syn.t t/proto.t t/proto.xs t/stdargs.t t/stdargs.xs t/substrictdecl.t SIGNATURE Added here by Module::Build Devel-CallParser-0.006/META.json000444000000000024 352115261001057 15605 0ustar00rootstaff000000000000{ "abstract" : "custom parsing attached to subroutines", "author" : [ "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Devel-CallParser", "prereqs" : { "build" : { "requires" : { "Devel::CallChecker" : "0.002", "DynaLoader" : "0", "ExtUtils::CBuilder" : "0.15", "ExtUtils::ParseXS" : "0", "File::Spec" : "0", "IO::File" : "1.03", "Module::Build" : "0", "Test::More" : "0", "perl" : "5.011002", "strict" : "0", "warnings" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0", "perl" : "5.011002", "strict" : "0", "warnings" : "0" } }, "runtime" : { "conflicts" : { "Data::Alias" : "< 1.13", "Devel::Declare" : "< 0.006004", "indirect" : "< 0.27" }, "requires" : { "Devel::CallChecker" : "0.002", "DynaLoader" : "0", "DynaLoader::Functions" : "0.001", "Exporter" : "0", "parent" : "0", "perl" : "5.011002", "strict" : "0", "warnings" : "0" } } }, "provides" : { "Devel::CallParser" : { "file" : "lib/Devel/CallParser.pm", "version" : "0.006" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.006", "x_serialization_backend" : "JSON::PP version 4.16" } Devel-CallParser-0.006/META.yml000444000000000024 216615261001057 15441 0ustar00rootstaff000000000000--- abstract: 'custom parsing attached to subroutines' author: - 'Andrew Main (Zefram) ' build_requires: Devel::CallChecker: '0.002' DynaLoader: '0' ExtUtils::CBuilder: '0.15' ExtUtils::ParseXS: '0' File::Spec: '0' IO::File: '1.03' Module::Build: '0' Test::More: '0' perl: '5.011002' strict: '0' warnings: '0' configure_requires: Module::Build: '0' perl: '5.011002' strict: '0' warnings: '0' conflicts: Data::Alias: '< 1.13' Devel::Declare: '< 0.006004' indirect: '< 0.27' dynamic_config: 0 generated_by: 'Module::Build version 0.4234, 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: Devel-CallParser provides: Devel::CallParser: file: lib/Devel/CallParser.pm version: '0.006' requires: Devel::CallChecker: '0.002' DynaLoader: '0' DynaLoader::Functions: '0.001' Exporter: '0' parent: '0' perl: '5.011002' strict: '0' warnings: '0' resources: license: http://dev.perl.org/licenses/ version: '0.006' x_serialization_backend: 'CPAN::Meta::YAML version 0.020' Devel-CallParser-0.006/Makefile.PL000444000000000024 233615261001057 16141 0ustar00rootstaff000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4234 require 5.011002; 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'); Devel-CallParser-0.006/README000444000000000024 201515261001057 15041 0ustar00rootstaff000000000000NAME Devel::CallParser - custom parsing attached to subroutines DESCRIPTION This module provides a C API, for XS modules, concerned with custom parsing. It is centred around the function "cv_set_call_parser", which allows XS code to attach a magical annotation to a Perl subroutine, resulting in resolvable calls to that subroutine having their arguments parsed by arbitrary C code. (This is a more conveniently structured facility than the core's "PL_keyword_plugin" API.) This module makes "cv_set_call_parser" and several supporting functions available. This module provides the implementation of the functions at runtime, and also at compile time supplies the C header file which provides access to the functions. INSTALLATION perl Build.PL ./Build ./Build test ./Build install AUTHOR Andrew Main (Zefram) COPYRIGHT Copyright (C) 2011, 2013 Andrew Main (Zefram) LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Devel-CallParser-0.006/SIGNATURE000644000000000024 655215261001060 15453 0ustar00rootstaff000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.96. 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: RIPEMD160 SHA256 bf0dbf61b35b40248b8bf990f8c6ba80688a24b8a7988393ee4ad81458b3d286 .gitignore SHA256 701608a0b4e68ef0fae83e1480cdb14ea1dad1b43d11e9570828083e6fb852a3 Build.PL SHA256 26cd17332e4e6c08691a121c1955694b8b5418a27684a5af0b2eb9e071a48f52 Changes SHA256 be0bc9ee981f01b89e32fb95897c6cbcea59dbaa6e310a014f7ad85a030df03d MANIFEST SHA256 f4e170ef31d39fabd0b134c4f01f588a9c8c856e0e724ea9fa52b03bfc8f7b81 META.json SHA256 0652c7b28e29d6258e844259103e6f25135c03e849646b5892c5f835cbd8e95d META.yml SHA256 b2ce225b3b1083842c4a387890bf93b9ce6e8fbaa2822026856e684b3a91cffa Makefile.PL SHA256 f8bf5a06da6aae880725e4c9e06bbaa3075b396839fe1ef4579213637bcdaa78 README SHA256 ceb9f850a3ba56155efcbba14a36edd6f9dea15fe3962a73543dcaf4d52a440d lib/Devel/CallParser.pm SHA256 f5bee96cd07c9eff700be8c6ad26224d6f91b1979e33e5c546cd58fb5e346cec lib/Devel/CallParser.xs SHA256 d6ebef46391432457c82d0b9341e5fa8fb832c551eb926e780725ad5c8365594 t/LoadXS.pm SHA256 7674febef146d9c50dc126b19a5151d893b3c356de36b01e612c0e551c28bde5 t/WriteHeader.pm SHA256 962fb3f185c9ecf3b087fec52527fbc6ef0560fe1ef03f5bad3ceb71684e1786 t/blockscope.t SHA256 5643466c4237734ae76542350ff32ddc9db87f87e9000976c093b05a4d42d835 t/dataalias.t SHA256 2d2e54f57a9bcd3a33de25d3b451a75246784b66ee6d7da08ee69e1d67fdc973 t/develdeclare.t SHA256 7e903f3d920827e52aa29fd0672af074651367ecda8a73ddfb63440a011de225 t/getset0.t SHA256 ad155fb28d8d8adec6e96c33c795fb59b4c0d9be0a3d9fe478ee952fe53e9989 t/getset0.xs SHA256 3bba41bfc7db59cea7109ef0112c2e64b5a75dc24a12b8a52cb0d3531fc6da4e t/getset1.t SHA256 1b1b90d9de5bcd79d5c82c2fcec249ecfa703a0e37f088033f44827ad400336b t/getset1.xs SHA256 c1048cfcba5c045862fb9d5b1a8b0459c45ffbbba58deba20e4ca744bcfbce5a t/indirect.t SHA256 267f4cfad370b76daf9119d40244b36a960c14860b988d0bc37cb3d7b06696f7 t/leximport.t SHA256 cac55d8066bebb5136fc0c0ea9828596449c97d581a35b072dd814be2ca086b2 t/listquote.t SHA256 258ec2d76c5d8881d42a1e1b023430f7d50e47d88ae476715397e6523f4df64c t/listquote.xs SHA256 1e5d63501c6e473410944538cd82028a7a8d7312e3c4708a29a2fe4302f5beac t/multiblock.t SHA256 efaa19199352cdbc1f8dcf25e139b84f9f0f28f1b6fcb524ea4af20eba735f85 t/multiblock.xs SHA256 566d16a2cf9ccbf359ca13d52a51520e14cece7c3a5cda4cd420fedc56985309 t/no_hdr.t SHA256 4a8367f4ced8859a7999c5b45033932e483c2e16679203f43e7667ddc5103846 t/padrange.t SHA256 64dbcf68e4b3e41685a428d9ade20cdd03a72a9156779d052778947a833aef63 t/pod_cvg.t SHA256 e6b3d5350091998d6769b5021c216849eefca471bb30ec87d7626a5e0e10d5f6 t/pod_syn.t SHA256 636374ea10d4d8a3f9ed6a41c3e58aad29a13e9ea80c56eeabf7ada682f3aa55 t/proto.t SHA256 dc620f091d153244929852f00b56182381d43124b4057e18d9be7f1afcc15a4e t/proto.xs SHA256 01c74d356d4c8a09fefe3acb89648ebb29740db10e870ae1845483b2e393bd06 t/stdargs.t SHA256 a360683eaf340e7a78c9a89ca1af6f68965e9fd3eacb34d1852d9d9026a85d94 t/stdargs.xs SHA256 62050f3891025470a715f5a10b893176065d64cf5237856a8d9bc0ef8f080b9c t/substrictdecl.t Devel-CallParser-0.006/lib000755000000000024 015261001057 14574 5ustar00rootstaff000000000000Devel-CallParser-0.006/lib/Devel000755000000000024 015261001057 15633 5ustar00rootstaff000000000000Devel-CallParser-0.006/lib/Devel/CallParser.pm000555000000000024 3472615261001057 20415 0ustar00rootstaff000000000000=head1 NAME Devel::CallParser - custom parsing attached to subroutines =head1 SYNOPSIS # to generate header prior to XS compilation perl -MDevel::CallParser=callparser0_h \ -e 'print callparser0_h' > callparser0.h perl -MDevel::CallParser=callparser1_h \ -e 'print callparser1_h' > callparser1.h # in Perl part of module use Devel::CallParser; /* in XS */ #include "callparser0.h" cv_get_call_parser(cv, &psfun, &psobj); static OP *my_psfun(pTHX_ GV *namegv, SV *psobj, U32 *flagsp); cv_set_call_parser(cv, my_psfun, psobj); #include "callparser1.h" cv_get_call_parser(cv, &psfun, &psobj); static OP *my_psfun(pTHX_ GV *namegv, SV *psobj, U32 *flagsp); cv_set_call_parser(cv, my_psfun, psobj); args = parse_args_parenthesised(&flags); args = parse_args_nullary(&flags); args = parse_args_unary(&flags); args = parse_args_list(&flags); args = parse_args_block_list(&flags); args = parse_args_proto(namegv, protosv, &flags); args = parse_args_proto_or_list(namegv, protosv, &flags); =head1 DESCRIPTION This module provides a C API, for XS modules, concerned with custom parsing. It is centred around the function C, which allows XS code to attach a magical annotation to a Perl subroutine, resulting in resolvable calls to that subroutine having their arguments parsed by arbitrary C code. (This is a more conveniently structured facility than the core's C API.) This module makes C and several supporting functions available. This module provides the implementation of the functions at runtime. It also, at compile time, supplies the C header file and link library which provide access to the functions. In normal use, L/L and L should be called at build time (not authoring time) for the module that wishes to use the C functions. =cut package Devel::CallParser; { use 5.011002; } use warnings; use strict; use Devel::CallChecker 0.001 (); our $VERSION = "0.006"; use parent "Exporter"; our @EXPORT_OK = qw(callparser0_h callparser1_h callparser_linkable); { require DynaLoader; local our @ISA = qw(DynaLoader); local *dl_load_flags = sub { 1 }; __PACKAGE__->bootstrap($VERSION); } =head1 CONSTANTS =over =item callparser0_h Content of a C header file, intended to be named "C". It is to be included in XS code, and C must be included first. When the XS module is loaded at runtime, the C module must be loaded first. This will result in a limited form of the C functions C and C being available to the XS code. The C and C functions supplied by this header are mostly as described below. However, for subroutines that have default argument parsing behaviour, C will return null pointers for the parsing function and its SV argument, rather than pointing to a real function that implements default parsing. Correspondingly, C will accept such a pair of null pointers to restore default argument parsing for a subroutine. The advantage of these modified semantics is that this much of the functionality is available on Perl versions where it is not possible to implement standard argument parsing as a distinct function. This is the case on all Perl versions prior to 5.13.8. This header is only available on Perl versions 5.11.2 and higher. =item callparser1_h Content of a C header file, intended to be named "C". It is to be included in XS code, and C must be included first. When the XS module is loaded at runtime, the C module must be loaded first. This will result in the C functions C, C, C, C, C, C, C, C, and C, as defined below, being available to the XS code. This header is only available on Perl versions 5.13.8 and higher. =item callparser_linkable List of names of files that must be used as additional objects when linking an XS module that uses the C functions supplied by this module. This list will be empty on many platforms. =cut sub callparser_linkable() { require DynaLoader::Functions; DynaLoader::Functions->VERSION(0.001); return DynaLoader::Functions::linkable_for_module(__PACKAGE__); } =back =head1 C FUNCTIONS =over =item cv_get_call_parser Retrieves the function that will be used to parse the arguments for a call to I. Specifically, the function is used for a subroutine call, not marked with C<&>, where the callee can be identified at compile time as I. The C-level function pointer is returned in I<*psfun_p>, and an SV argument for it is returned in I<*psobj_p>. The function is intended to be called in this manner: argsop = (*psfun_p)(aTHX_ namegv, (*psobj_p), &flags); This call is to be made when the parser has just scanned and accepted a bareword and determined that it begins the syntax of a call to I. I is a GV supplying the name that should be used by the parsing function to refer to the callee if it needs to emit any diagnostics, and I is a C that the parsing function can write to as an additional output. It is permitted to apply the parsing function in non-standard situations, such as to a call to a different subroutine. The parsing function's main output is an op tree describing a list of argument expressions. This may be null for an empty list. The argument expressions will be combined with the expression that identified I and used to build an C op describing a complete subroutine call. The parsing function may also set flag bits in I for special effects. The bit C indicates that the argument list was fully parenthesised, which makes a difference only in obscure situations. The bit C indicates that what was parsed was syntactically not an expression but a statement. By default, the parsing function is L, and the SV parameter is I itself. This implements standard subroutine argument parsing. It can be changed, for a particular subroutine, by L. void cv_get_call_parser(CV *cv, Perl_call_parser *psfun_p, SV **psobj_p) =item cv_set_call_parser Sets the function that will be used to parse the arguments for a call to I. Specifically, the function is used for a subroutine call, not marked with C<&>, where the callee can be identified at compile time as I. The C-level function pointer is supplied in I, and an SV argument for it is supplied in I. The function is intended to be called in this manner: argsop = (*psfun_p)(aTHX_ namegv, (*psobj_p), &flags); This call is to be made when the parser has just scanned and accepted a bareword and determined that it begins the syntax of a call to I. I is a GV supplying the name that should be used by the parsing function to refer to the callee if it needs to emit any diagnostics, and I is a C that the parsing function can write to as an additional output. It is permitted to apply the parsing function in non-standard situations, such as to a call to a different subroutine. The parsing function's main output is an op tree describing a list of argument expressions. This may be null for an empty list. The argument expressions will be combined with the expression that identified I and used to build an C op describing a complete subroutine call. The parsing function may also set flag bits in I for special effects. The bit C indicates that the argument list was fully parenthesised, which makes a difference only in obscure situations. The bit C indicates that what was parsed was syntactically not an expression but a statement. The current setting for a particular CV can be retrieved by L. void cv_set_call_parser(CV *cv, Perl_call_parser psfun, SV *psobj) =item parse_args_parenthesised Parse a parenthesised argument list for a subroutine call. The argument list consists of an optional expression enclosed in parentheses. This is the syntax that is used for any subroutine call where the first thing following the subroutine name is an open parenthesis. It is used regardless of the subroutine's prototype. The op tree representing the argument list is returned. The bit C is set in I<*flags_p>, to indicate that the argument list was fully parenthesised. OP *parse_args_parenthesised(U32 *flags_p) =item parse_args_nullary Parse an argument list for a call to a subroutine that is syntactically a nullary function. The argument list is either parenthesised or completely absent. This is the syntax that is used for a call to a subroutine with a C<()> prototype. The op tree representing the argument list is returned. The bit C is set in I<*flags_p> if the argument list was parenthesised. OP *parse_args_nullary(U32 *flags_p) =item parse_args_unary Parse an argument list for a call to a subroutine that is syntactically a unary function. The argument list is either parenthesised, absent, or consists of an unparenthesised arithmetic expression. This is the syntax that is used for a call to a subroutine with prototype C<($)>, C<(;$)>, or certain similar prototypes. The op tree representing the argument list is returned. The bit C is set in I<*flags_p> if the argument list was parenthesised. OP *parse_args_unary(U32 *flags_p) =item parse_args_list Parse an argument list for a call to a subroutine that is syntactically a list function. The argument list is either parenthesised, absent, or consists of an unparenthesised list expression. This is the syntax that is used for a call to a subroutine with any prototype that does not have special handling (such as C<(@)> or C<($$)>) or with no prototype at all. The op tree representing the argument list is returned. The bit C is set in I<*flags_p> if the argument list was parenthesised. OP *parse_args_list(U32 *flags_p) =item parse_args_block_list Parse an argument list for a call to a subroutine that is syntactically a block-and-list function. The argument list is either parenthesised, absent, an unparenthesised list expression, or consists of a code block followed by an optionl list expression. Where the first thing seen is an open brace, it is always interpreted as a code block. This is the syntax that is used for a call to a subroutine with any prototype beginning with C<&>, such as C<(&@)> or C<(&$)>. The op tree representing the argument list is returned. The bit C is set in I<*flags_p> if the argument list was parenthesised. OP *parse_args_block_list(U32 *flags_p) =item parse_args_proto Parse a subroutine argument list based on a subroutine prototype. The syntax used for the argument list will be that implemented by L, L, L, or L, depending on the prototype. This is the standard treatment used on a subroutine call, not marked with C<&>, where the callee can be identified at compile time and has a prototype. I supplies the subroutine prototype to be applied to the call. It may be a normal defined scalar, of which the string value will be used. Alternatively, for convenience, it may be a subroutine object (a C that has been cast to C) which has a prototype. The I parameter would be used to refer to the callee if required in any error message, but currently no message does so. The op tree representing the argument list is returned. The bit C is set in I<*flags_p> if the argument list was parenthesised. OP *parse_args_proto(GV *namegv, SV *protosv, U32 *flags_p) =item parse_args_proto_or_list Parse a subroutine argument list either based on a subroutine prototype or using default list-function syntax. The syntax used for the argument list will be that implemented by L, L, L, or L, depending on the prototype. This is the standard treatment used on a subroutine call, not marked with C<&>, where the callee can be identified at compile time. I supplies the subroutine prototype to be applied to the call, or indicates that there is no prototype. It may be a normal scalar, in which case if it is defined then the string value will be used as a prototype, and if it is undefined then there is no prototype. Alternatively, for convenience, it may be a subroutine object (a C that has been cast to C), of which the prototype will be used if it has one. The I parameter would be used to refer to the callee if required in any error message, but currently no message does so. The op tree representing the argument list is returned. The bit C is set in I<*flags_p> if the argument list was parenthesised. OP *parse_args_proto_or_list(GV *namegv, SV *protosv, U32 *flags_p) =back =head1 BUGS Due to reliance on Perl core features to do anything interesting, only a very limited form of custom parsing is possible prior to Perl 5.13.8, and none at all prior to Perl 5.11.2. The way this module determines which parsing code to use for a subroutine conflicts with the expectations of some particularly tricky modules that use nasty hacks to perform custom parsing without proper support from the Perl core. In particular, this module is incompatible with versions of L prior to 0.006004 and versions of L prior to 1.13. An arrangement has been reached that allows later versions of those modules to coexist with this module. Custom parsing code is only invoked if the subroutine to which it is attached is invoked using an unqualified name. For example, the name C works, but the name C will not, despite referring to the same subroutine. This is an unavoidable limitation imposed by the core's interim facility for custom parser plugins. This should be resolved if the API provided by this module, or something similar, migrates into the core in a future version of Perl. =head1 SEE ALSO L =head1 AUTHOR Andrew Main (Zefram) =head1 COPYRIGHT Copyright (C) 2011, 2013 Andrew Main (Zefram) =head1 LICENSE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; Devel-CallParser-0.006/lib/Devel/CallParser.xs000555000000000024 4267615261001057 20436 0ustar00rootstaff000000000000#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) #ifndef PERL_VERSION_GE # define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #endif /* !PERL_VERSION_GE */ /* the pad's name list: a PADNAMELIST from 5.21.7, an AV before */ #if PERL_VERSION_GE(5,21,7) # define Q_PADNAMES_MAX(pnl) PadnamelistMAX(pnl) # define Q_PADNAMES_TRIM(pnl, n) STMT_START { \ if(PadnamelistMAX(pnl) > (n)) PadnamelistMAX(pnl) = (n); \ } STMT_END #else /* < 5.21.7 */ # define Q_PADNAMES_MAX(pnl) av_len(pnl) # define Q_PADNAMES_TRIM(pnl, n) STMT_START { \ if(av_len(pnl) > (n)) av_fill(pnl, n); \ } STMT_END #endif /* < 5.21.7 */ #ifndef op_append_elem # define op_append_elem(t, f, l) THX_op_append_elem(aTHX_ t, f, l) static OP *THX_op_append_elem(pTHX_ I32 type, OP *first, OP *last) { if(!first) return last; if(!last) return first; if(first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) return newLISTOP(type, 0, first, last); if(first->op_flags & OPf_KIDS) { cLISTOPx(first)->op_last->op_sibling = last; } else { first->op_flags |= OPf_KIDS; cLISTOPx(first)->op_first = last; } cLISTOPx(first)->op_last = last; return first; } #endif /* !op_append_elem */ #ifndef qerror /* Perl_qerror is exported (EXp) on all platforms but its declaration * is hidden behind PERL_CORE/PERL_EXT header guards. Declare it * ourselves so we can use it. */ EXTERN_C void Perl_qerror(pTHX_ SV *err); # define qerror(m) Perl_qerror(aTHX_ m) #endif /* !qerror */ #define QPFX C8K61oRQKxigiqmUlVdk_ #define QPFXS STRINGIFY(QPFX) #define QCONCAT0(a,b) a##b #define QCONCAT1(a,b) QCONCAT0(a,b) #define QPFXD(name) QCONCAT1(QPFX, name) #if defined(WIN32) && PERL_VERSION_GE(5,13,6) # define MY_BASE_CALLCONV EXTERN_C # define MY_BASE_CALLCONV_S "EXTERN_C" #else /* !(WIN32 && >= 5.13.6) */ # define MY_BASE_CALLCONV PERL_CALLCONV # define MY_BASE_CALLCONV_S "PERL_CALLCONV" #endif /* !(WIN32 && >= 5.13.6) */ #define MY_EXPORT_CALLCONV MY_BASE_CALLCONV #if defined(WIN32) || defined(__CYGWIN__) # define MY_IMPORT_CALLCONV_S MY_BASE_CALLCONV_S" __declspec(dllimport)" #else # define MY_IMPORT_CALLCONV_S MY_BASE_CALLCONV_S #endif static MGVTBL mgvtbl_parsecall; typedef OP *(*Perl_call_parser)(pTHX_ GV *, SV *, U32 *); #define CALLPARSER_PARENS 0x00000001 #define CALLPARSER_STATEMENT 0x00000002 #ifdef parse_fullexpr # define Q_PARSER_AVAILABLE 1 #endif /* parse_fullexpr */ #if Q_PARSER_AVAILABLE # define Perl_parse_args_parenthesised QPFXD(pac0) # define parse_args_parenthesised(fp) Perl_parse_args_parenthesised(aTHX_ fp) MY_EXPORT_CALLCONV OP *QPFXD(pac0)(pTHX_ U32 *flags_p) { OP *argsop; lex_read_space(0); if(lex_peek_unichar(0) != '('/*)*/) { qerror(mess("syntax error")); return NULL; } lex_read_unichar(0); argsop = parse_fullexpr(PARSE_OPTIONAL); lex_read_space(0); if(lex_peek_unichar(0) != /*(*/')') { qerror(mess("syntax error")); return argsop; } lex_read_unichar(0); *flags_p |= CALLPARSER_PARENS; return argsop; } # define Perl_parse_args_nullary QPFXD(paz0) # define parse_args_nullary(fp) Perl_parse_args_nullary(aTHX_ fp) MY_EXPORT_CALLCONV OP *QPFXD(paz0)(pTHX_ U32 *flags_p) { lex_read_space(0); if(lex_peek_unichar(0) == '('/*)*/) return parse_args_parenthesised(flags_p); return NULL; } # define Perl_parse_args_unary QPFXD(pau0) # define parse_args_unary(fp) Perl_parse_args_unary(aTHX_ fp) MY_EXPORT_CALLCONV OP *QPFXD(pau0)(pTHX_ U32 *flags_p) { lex_read_space(0); if(lex_peek_unichar(0) == '('/*)*/) return parse_args_parenthesised(flags_p); return parse_arithexpr(PARSE_OPTIONAL); } # define Perl_parse_args_list QPFXD(pal0) # define parse_args_list(fp) Perl_parse_args_list(aTHX_ fp) MY_EXPORT_CALLCONV OP *QPFXD(pal0)(pTHX_ U32 *flags_p) { lex_read_space(0); if(lex_peek_unichar(0) == '('/*)*/) return parse_args_parenthesised(flags_p); return parse_listexpr(PARSE_OPTIONAL); } # define Perl_parse_args_block_list QPFXD(pab0) # define parse_args_block_list(fp) Perl_parse_args_block_list(aTHX_ fp) MY_EXPORT_CALLCONV OP *QPFXD(pab0)(pTHX_ U32 *flags_p) { OP *blkop, *argsop; I32 c; lex_read_space(0); c = lex_peek_unichar(0); if(c == '('/*)*/) return parse_args_parenthesised(flags_p); if(c == '{'/*}*/) { I32 floor = start_subparse(0, CVf_ANON); SAVEFREESV(PL_compcv); blkop = parse_block(0); SvREFCNT_inc_simple_void((SV*)PL_compcv); blkop = newANONATTRSUB(floor, NULL, NULL, blkop); } else { blkop = NULL; } argsop = parse_listexpr(PARSE_OPTIONAL); return op_prepend_elem(OP_LIST, blkop, argsop); } # define Perl_parse_args_proto QPFXD(pap0) # define parse_args_proto(gv, sv, fp) Perl_parse_args_proto(aTHX_ gv, sv, fp) MY_EXPORT_CALLCONV OP *QPFXD(pap0)(pTHX_ GV *namegv, SV *protosv, U32 *flags_p) { STRLEN proto_len; char const *proto; PERL_UNUSED_ARG(namegv); if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) croak("panic: parse_args_proto with no proto"); /* * There are variations between Perl versions in the syntactic * interpretation of prototypes, which this code in principle * needs to track. However, from the introduction of the parser * API functions required by this code (5.13.8) to the date * of this note (5.14.0-RC0) there have been no such changes. * With luck there may be no more before this function migrates * into the core. */ proto = SvPV(protosv, proto_len); if(!proto_len) return parse_args_nullary(flags_p); while(*proto == ';') proto++; if(proto[0] == '&') return parse_args_block_list(flags_p); if(((proto[0] == '$' || proto[0] == '_' || proto[0] == '*' || proto[0] == '+') && !proto[1]) || (proto[0] == '\\' && proto[1] && !proto[2])) return parse_args_unary(flags_p); if(proto[0] == '\\' && proto[1] == '['/*]*/) { proto += 2; while(*proto && *proto != /*[*/']') proto++; if(proto[0] == /*[*/']' && !proto[1]) return parse_args_unary(flags_p); } return parse_args_list(flags_p); } # define Perl_parse_args_proto_or_list QPFXD(pan0) # define parse_args_proto_or_list(gv, sv, fp) \ Perl_parse_args_proto_or_list(aTHX_ gv, sv, fp) MY_EXPORT_CALLCONV OP *QPFXD(pan0)(pTHX_ GV *namegv, SV *protosv, U32 *flags_p) { if(SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) return parse_args_proto(namegv, protosv, flags_p); else return parse_args_list(flags_p); } #endif /* Q_PARSER_AVAILABLE */ #ifndef mg_findext # define mg_findext(sv, type, vtbl) THX_mg_findext(aTHX_ sv, type, vtbl) static MAGIC *THX_mg_findext(pTHX_ SV *sv, int type, MGVTBL const *vtbl) { MAGIC *mg; if(sv) for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) if(mg->mg_type == type && mg->mg_virtual == vtbl) return mg; return NULL; } #endif /* !mg_findext */ #ifndef sv_unmagicext # define sv_unmagicext(sv, type, vtbl) THX_sv_unmagicext(aTHX_ sv, type, vtbl) static int THX_sv_unmagicext(pTHX_ SV *sv, int type, MGVTBL const *vtbl) { MAGIC *mg, **mgp; if((vtbl && vtbl->svt_free) || type == PERL_MAGIC_regex_global) /* exceeded intended usage of this reserve implementation */ return 0; if(SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = NULL; for(mg = mgp ? *mgp : SvMAGIC(sv); mg; mg = mgp ? *mgp : SvMAGIC(sv)) { if(mg->mg_type == type && mg->mg_virtual == vtbl) { if(mgp) *mgp = mg->mg_moremagic; else SvMAGIC_set(sv, mg->mg_moremagic); if(mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); } else { mgp = &mg->mg_moremagic; } } SvMAGICAL_off(sv); mg_magical(sv); return 0; } #endif /* !sv_unmagicext */ MY_EXPORT_CALLCONV void QPFXD(gcp0)(pTHX_ CV *cv, Perl_call_parser *psfun_p, SV **psobj_p) { MAGIC *callmg = SvMAGICAL((SV*)cv) ? mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_parsecall) : NULL; if(callmg) { *psfun_p = DPTR2FPTR(Perl_call_parser, callmg->mg_ptr); *psobj_p = callmg->mg_obj; } else { *psfun_p = DPTR2FPTR(Perl_call_parser, NULL); *psobj_p = NULL; } } MY_EXPORT_CALLCONV void QPFXD(scp0)(pTHX_ CV *cv, Perl_call_parser psfun, SV *psobj) { if( (!psfun && !psobj) #if Q_PARSER_AVAILABLE || (psfun == Perl_parse_args_proto_or_list && psobj == (SV*)cv) #endif /* Q_PARSER_AVAILABLE */ ) { if(SvMAGICAL((SV*)cv)) sv_unmagicext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_parsecall); } else { MAGIC *callmg = mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_parsecall); if(!callmg) callmg = sv_magicext((SV*)cv, &PL_sv_undef, PERL_MAGIC_ext, &mgvtbl_parsecall, NULL, 0); if(callmg->mg_flags & MGf_REFCOUNTED) { SvREFCNT_dec(callmg->mg_obj); callmg->mg_flags &= ~MGf_REFCOUNTED; } callmg->mg_ptr = FPTR2DPTR(char *, psfun); callmg->mg_obj = psobj; if(psobj != (SV*)cv) { SvREFCNT_inc(psobj); callmg->mg_flags |= MGf_REFCOUNTED; } } } #if Q_PARSER_AVAILABLE MY_EXPORT_CALLCONV void QPFXD(gcp1)(pTHX_ CV *cv, Perl_call_parser *psfun_p, SV **psobj_p) { QPFXD(gcp0)(aTHX_ cv, psfun_p, psobj_p); if(!*psfun_p && !*psobj_p) { *psfun_p = Perl_parse_args_proto_or_list; *psobj_p = (SV*)cv; } } MY_EXPORT_CALLCONV void QPFXD(scp1)(pTHX_ CV *cv, Perl_call_parser psfun, SV *psobj) { if(!psobj) croak("null object for cv_set_call_parser"); QPFXD(scp0)(aTHX_ cv, psfun, psobj); } #endif /* Q_PARSER_AVAILABLE */ /* * Find a CV by name, checking lexical hints first (for Lexical::Sub * and similar modules), then falling back to package lookup. * This is more reliable than rv2cv_op_cv() on threaded/debugging perls. * * Lexical::Sub (via Lexical::Var) stores CVs with the key format: * "Lexical::Var/&subname" */ static CV *THX_find_lexical_cv(pTHX_ char *name, STRLEN len) { /* Check %^H hints hash - where Lexical::Sub stores its subs */ if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) { SV *keysv; SV **svp; /* Construct the Lexical::Var key format: "Lexical::Var/&name" */ keysv = newSVpvs("Lexical::Var/&"); sv_catpvn(keysv, name, len); svp = hv_fetch(GvHV(PL_hintgv), SvPVX(keysv), (I32)SvCUR(keysv), 0); SvREFCNT_dec(keysv); if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVCV) { return (CV*)SvRV(*svp); } } return NULL; } static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { OP *nmop, *cvop, *argsop; CV *cv; GV *namegv; Perl_call_parser psfun; SV *psobj; U32 parser_flags; /* * First, check for lexically-scoped CVs directly in %^H. * This handles Lexical::Sub and similar modules reliably * across all Perl configurations (threaded, debugging, etc.). */ cv = THX_find_lexical_cv(aTHX_ keyword_ptr, keyword_len); if (cv) { QPFXD(gcp0)(aTHX_ cv, &psfun, &psobj); if (psfun || psobj) { /* Found lexical CV with call parser - use it */ nmop = newSVOP(OP_CONST, 0, newSVpvn(keyword_ptr, keyword_len)); nmop->op_private = OPpCONST_BARE; cvop = newUNOP(OP_RV2CV, 0, newSVOP(OP_CONST, 0, newRV_inc((SV*)cv))); namegv = (GV*)newSVpvn(keyword_ptr, keyword_len); parser_flags = 0; argsop = psfun(aTHX_ namegv, psobj, &parser_flags); SvREFCNT_dec((SV*)namegv); if(!(parser_flags & CALLPARSER_PARENS)) cvop->op_private |= OPpENTERSUB_NOPAREN; *op_ptr = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, argsop, cvop)); return (parser_flags & CALLPARSER_STATEMENT) ? KEYWORD_PLUGIN_STMT : KEYWORD_PLUGIN_EXPR; } } /* * Fall back to original op-based lookup for package subs. * * Creation of the rv2cv op below (or more precisely its gv op * child created during checking) uses a pad slot under threads. * Normally this is fine, but early versions of the padrange * mechanism make assumptions about pad slots being contiguous * that this breaks. On the affected perl versions, therefore, * we watch for the pad slot being consumed, and restore the * pad's fill pointer if we throw the op away (upon declining * to handle the keyword). * * The core bug was supposedly fixed in Perl 5.19.4, but actually * that version exhibits a different bug also apparently related * to padrange. Restoring the pad's fill pointer works around * this bug too. So for now this workaround is used with no * upper bound on the Perl version. * * The pad's name list must be restored with it. Allocating the * constant slot for the gv op stores a placeholder name at that * index, which can extend the name list; freeing the op replaces * the placeholder but leaves the list's fill where it was. A * block opened right after the declined keyword then takes the * inflated fill as its floor, the first "my" inside the block * lands on the floor slot, and pad_leavemy never closes it: the * lexical stays visible after the block, masking the outer one * of the same name (a "masks earlier declaration in same scope" * warning where the two are in different scopes). */ #define MUST_RESTORE_PAD_FILL PERL_VERSION_GE(5,17,6) #if MUST_RESTORE_PAD_FILL I32 padfill = av_len(PL_comppad); SSize_t namefill = Q_PADNAMES_MAX(PL_comppad_name); #endif /* MUST_RESTORE_PAD_FILL */ /* * If Devel::Declare happens to be loaded, it triggers magic * upon building of an rv2cv op, assuming that it's being built * by the lexer. Since we're about to build such an op here, * replicating what the lexer will normally do shortly after, * there's a risk that Devel::Declare could fire here, ultimately * firing twice for a single appearance of a name it's interested * in. To suppress Devel::Declare, therefore, we temporarily * set PL_parser to null. The same goes for Data::Alias and * some other modules that use similar techniques. * * Unfortunately Devel::Declare prior to 0.006004 still does some * work at the wrong time if PL_parser is null, and Data::Alias * prior to 1.13 crashes if PL_parser is null. So this module * is not compatible with earlier versions of those modules, * and can't be made compatible. */ ENTER; SAVEVPTR(PL_parser); PL_parser = NULL; nmop = newSVOP(OP_CONST, 0, newSVpvn(keyword_ptr, keyword_len)); nmop->op_private = OPpCONST_BARE; cvop = newCVREF(0, nmop); LEAVE; if(!(cv = rv2cv_op_cv(cvop, 0))) { decline: op_free(cvop); #if MUST_RESTORE_PAD_FILL av_fill(PL_comppad, padfill); Q_PADNAMES_TRIM(PL_comppad_name, namefill); #endif /* MUST_RESTORE_PAD_FILL */ return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } QPFXD(gcp0)(aTHX_ cv, &psfun, &psobj); if(!psfun && !psobj) goto decline; namegv = (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV); parser_flags = 0; argsop = psfun(aTHX_ namegv, psobj, &parser_flags); if(!(parser_flags & CALLPARSER_PARENS)) cvop->op_private |= OPpENTERSUB_NOPAREN; *op_ptr = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, argsop, cvop)); return (parser_flags & CALLPARSER_STATEMENT) ? KEYWORD_PLUGIN_STMT : KEYWORD_PLUGIN_EXPR; } #define fmt_header(n, content) THX_fmt_header(aTHX_ n, content) static SV *THX_fmt_header(pTHX_ char n, char const *content) { return newSVpvf( "/* DO NOT EDIT -- generated " "by Devel::CallParser version "XS_VERSION" */\n" "#ifndef "QPFXS"INCLUDED_callparser%c\n" "#define "QPFXS"INCLUDED_callparser%c 1\n" "#ifndef PERL_VERSION\n" " #error you must include perl.h before callparser%c.h\n" "#elif !(PERL_REVISION == "STRINGIFY(PERL_REVISION) " && PERL_VERSION == "STRINGIFY(PERL_VERSION) #if PERL_VERSION & 1 " && PERL_SUBVERSION == "STRINGIFY(PERL_SUBVERSION) #endif /* PERL_VERSION & 1 */ ")\n" " #error this callparser%c.h is for Perl " STRINGIFY(PERL_REVISION)"."STRINGIFY(PERL_VERSION) #if PERL_VERSION & 1 "."STRINGIFY(PERL_SUBVERSION) #endif /* PERL_VERSION & 1 */ " only\n" "#endif /* Perl version mismatch */\n" "%s" "#endif /* !"QPFXS"INCLUDED_callparser%c */\n", n, n, n, n, content, n); } #define DEFFN(RETTYPE, PUBNAME, PRIVNAME, ARGTYPES, ARGNAMES) \ MY_IMPORT_CALLCONV_S" "RETTYPE" "QPFXS PRIVNAME"(pTHX_ "ARGTYPES");\n" \ "#define Perl_"PUBNAME" "QPFXS PRIVNAME"\n" \ "#define "PUBNAME"("ARGNAMES") Perl_"PUBNAME"(aTHX_ "ARGNAMES")\n" #define DEFCALLBACK \ "typedef OP *(*Perl_call_parser)(pTHX_ GV *, SV *, U32 *);\n" \ "#define CALLPARSER_PARENS 0x00000001\n" \ "#define CALLPARSER_STATEMENT 0x00000002\n" MODULE = Devel::CallParser PACKAGE = Devel::CallParser PROTOTYPES: DISABLE BOOT: next_keyword_plugin = PL_keyword_plugin; PL_keyword_plugin = my_keyword_plugin; SV * callparser0_h() CODE: RETVAL = fmt_header('0', DEFCALLBACK DEFFN("void", "cv_get_call_parser", "gcp0", "CV *, Perl_call_parser *, SV **", "cv, fp, op") DEFFN("void", "cv_set_call_parser", "scp0", "CV *, Perl_call_parser, SV *", "cv, f, o") ); OUTPUT: RETVAL SV * callparser1_h() CODE: #if Q_PARSER_AVAILABLE RETVAL = fmt_header('1', DEFFN("OP *", "parse_args_parenthesised", "pac0", "U32 *", "fp") DEFFN("OP *", "parse_args_nullary", "paz0", "U32 *", "fp") DEFFN("OP *", "parse_args_unary", "pau0", "U32 *", "fp") DEFFN("OP *", "parse_args_list", "pal0", "U32 *", "fp") DEFFN("OP *", "parse_args_block_list", "pab0", "U32 *", "fp") DEFFN("OP *", "parse_args_proto", "pap0", "GV *, SV *, U32 *", "gv, sv, fp") DEFFN("OP *", "parse_args_proto_or_list", "pan0", "GV *, SV *, U32 *", "gv, sv, fp") DEFCALLBACK DEFFN("void", "cv_get_call_parser", "gcp1", "CV *, Perl_call_parser *, SV **", "cv, fp, op") DEFFN("void", "cv_set_call_parser", "scp1", "CV *, Perl_call_parser, SV *", "cv, f, o") ); #else /* !Q_PARSER_AVAILABLE */ croak("callparser1.h not available on this version of Perl"); #endif /* !Q_PARSER_AVAILABLE */ OUTPUT: RETVAL Devel-CallParser-0.006/t000755000000000024 015261001057 14271 5ustar00rootstaff000000000000Devel-CallParser-0.006/t/LoadXS.pm000555000000000024 233515261001057 16124 0ustar00rootstaff000000000000package t::LoadXS; use warnings; use strict; use Cwd (); use DynaLoader (); use ExtUtils::CBuilder (); use ExtUtils::ParseXS (); use File::Spec (); our @todelete; END { unlink @todelete; } sub load_xs($$$) { my($basename, $dir, $extralibs) = @_; my $xs_file = File::Spec->catdir("t", "$basename.xs"); my $c_file = File::Spec->catdir("t", "$basename.c"); ExtUtils::ParseXS::process_file( filename => $xs_file, output => $c_file, ); push @todelete, $c_file; my $cb = ExtUtils::CBuilder->new(quiet => 1); my $o_file = $cb->compile(source => $c_file); push @todelete, $o_file; my($so_file, @so_tmps) = $cb->link(objects => [ $o_file, @$extralibs ], module_name => "t::$basename"); push @todelete, $so_file, @so_tmps; $so_file = Cwd::abs_path($so_file); my $boot_symbol = "boot_t__$basename"; @DynaLoader::dl_require_symbols = ($boot_symbol); my $so_handle = DynaLoader::dl_load_file($so_file, 0); defined $so_handle or die(DynaLoader::dl_error()); my $boot_func = DynaLoader::dl_find_symbol($so_handle, $boot_symbol); defined $boot_func or die "symbol $boot_symbol not found in $so_file"; my $boot_perlname = "t::${basename}::bootstrap"; DynaLoader::dl_install_xsub($boot_perlname, $boot_func, $so_file)->(); } 1; Devel-CallParser-0.006/t/WriteHeader.pm000555000000000024 100315261001057 17164 0ustar00rootstaff000000000000package t::WriteHeader; use warnings; use strict; use File::Spec (); use IO::File 1.03 (); our @todelete; END { unlink @todelete; } sub write_header($$$) { my($basename, $outdir, $prefix) = @_; require Devel::CallParser; no strict "refs"; my $content = &{"Devel::CallParser::${basename}_h"}(); my $h_file = File::Spec->catfile($outdir, "${prefix}_${basename}.h"); push @todelete, $h_file; my $fh = IO::File->new($h_file, "w") or die $!; $fh->printflush($content) or die $!; $fh->close or die $!; } 1; Devel-CallParser-0.006/t/blockscope.t000444000000000024 306615261001057 16744 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; use Test::More tests => 7; # Loading this module must not change how "my" scopes. With the keyword # plugin installed, every keyword it declines (if, while, print, my # itself) has allocated and freed a pad slot; a block opened right after # one must still close the lexicals declared inside it. Before 0.005 the # first "my" of such a block stayed visible after the block on ithreads # perls, masking an outer lexical of the same name. use Devel::CallParser (); # the shadowing warning is a compile-time one: catch it from here on our @warnings; BEGIN { $SIG{__WARN__} = sub { push @warnings, $_[0] } } my $if = "outer"; if (1) { my $if = "inner"; } is $if, "outer", "a my inside an if block ends with the block"; my $bare = "outer"; { my $bare = "inner"; } is $bare, "outer", "and inside a bare block"; my @seen; my @l = ("a", "b"); while (my $x = shift @l) { if (1) { my $x = "inner"; } push @seen, $x; } is_deeply \@seen, ["a", "b"], "the loop variable survives an inner block"; my $ok = 0; sub tsub { my $v = "outer"; if (1) { my $v = "inner"; } $ok = $v eq "outer"; } tsub(); ok $ok, "the same inside a sub"; my $nested = "outer"; if (1) { if (1) { my $nested = "inner"; } } is $nested, "outer", "and two blocks deep"; # a second declaration of the same name after the block is in a new # scope relative to the block's, not the same one my $again = 1; if (1) { my $again = 2; } { my $again = 3; is $again, 3, "a later block declares its own"; } is scalar(@warnings), 0, "no shadowing warning was emitted" or diag @warnings; 1; Devel-CallParser-0.006/t/dataalias.t000555000000000024 54215261001057 16522 0ustar00rootstaff000000000000use warnings; no warnings "void"; use strict; use lib '.'; BEGIN { eval { require Data::Alias; Data::Alias->VERSION(1.13); }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "good Data::Alias unavailable"); } } use Test::More tests => 2; use Devel::CallParser (); use Data::Alias; is alias(42), 42; is alias{42}, 42; 1; Devel-CallParser-0.006/t/develdeclare.t000555000000000024 116115261001057 17234 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; BEGIN { eval { require Devel::Declare; Devel::Declare->VERSION(0.006004); }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "good Devel::Declare unavailable"); } } use Test::More tests => 1; use Devel::CallParser (); sub method { my ($usepack, $name, $inpack, $sub) = @_; no strict "refs"; *{"${inpack}::${name}"} = $sub; } use Devel::Declare method => sub { my ($usepack, $use, $inpack, $name) = @_; return sub (&) { ($usepack, $name, $inpack, $_[0]); }; }; method bar { return join(",", @_); }; is +__PACKAGE__->bar(qw(x y)), "main,x,y"; 1; Devel-CallParser-0.006/t/getset0.t000555000000000024 53315261001057 16152 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; use Test::More tests => 4; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callparser0", "t", "getset0"); ok 1; require_ok "Devel::CallParser"; t::LoadXS::load_xs("getset0", "t", [Devel::CallParser::callparser_linkable()]); ok 1; t::getset0::test_cv_getset_call_parser(); ok 1; 1; Devel-CallParser-0.006/t/getset0.xs000555000000000024 416515261001057 16366 0ustar00rootstaff000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "getset0_callparser0.h" #include "XSUB.h" static OP *THX_parse_args_a(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(psobj); PERL_UNUSED_ARG(flags_p); return newOP(OP_NULL, 0); } static OP *THX_parse_args_b(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(flags_p); return newSVOP(OP_CONST, 0, SvREFCNT_inc(psobj)); } MODULE = t::getset0 PACKAGE = t::getset0 PROTOTYPES: DISABLE void test_cv_getset_call_parser() PROTOTYPE: PREINIT: CV *t0_cv, *t1_cv; Perl_call_parser psfun; SV *psobj; CODE: #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__) #define croak_fail_ne(h, w) \ croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) #define check_cp(cv, xpsfun, xpsobj) \ do { \ cv_get_call_parser((cv), &psfun, &psobj); \ if (psfun != (xpsfun)) \ croak_fail_ne(FPTR2DPTR(void *, psfun), xpsfun); \ if (psobj != (xpsobj)) \ croak_fail_ne(FPTR2DPTR(void *, psobj), xpsobj); \ } while(0) t0_cv = get_cv("t::getset0::t0", 0); t1_cv = get_cv("t::getset0::t1", 0); check_cp(t0_cv, (Perl_call_parser)NULL, (SV*)NULL); check_cp(t1_cv, (Perl_call_parser)NULL, (SV*)NULL); cv_set_call_parser(t1_cv, THX_parse_args_a, &PL_sv_yes); check_cp(t0_cv, (Perl_call_parser)NULL, (SV*)NULL); check_cp(t1_cv, THX_parse_args_a, &PL_sv_yes); cv_set_call_parser(t0_cv, THX_parse_args_b, &PL_sv_no); check_cp(t0_cv, THX_parse_args_b, &PL_sv_no); check_cp(t1_cv, THX_parse_args_a, &PL_sv_yes); cv_set_call_parser(t1_cv, (Perl_call_parser)NULL, (SV*)NULL); check_cp(t0_cv, THX_parse_args_b, &PL_sv_no); check_cp(t1_cv, (Perl_call_parser)NULL, (SV*)NULL); cv_set_call_parser(t0_cv, (Perl_call_parser)NULL, (SV*)NULL); check_cp(t0_cv, (Perl_call_parser)NULL, (SV*)NULL); check_cp(t1_cv, (Perl_call_parser)NULL, (SV*)NULL); if (SvMAGICAL((SV*)t0_cv) || SvMAGIC((SV*)t0_cv)) croak_fail(); if (SvMAGICAL((SV*)t1_cv) || SvMAGIC((SV*)t1_cv)) croak_fail(); #undef check_cp #undef croak_fail_ne #undef croak_fail void t0() PROTOTYPE: CODE: ; void t1() PROTOTYPE: CODE: ; Devel-CallParser-0.006/t/getset1.t000555000000000024 74315261001057 16156 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; BEGIN { if("$]" < 5.013008) { require Test::More; Test::More::plan(skip_all => "parse_*expr not available on this Perl"); } } use Test::More tests => 4; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callparser1", "t", "getset1"); ok 1; require_ok "Devel::CallParser"; t::LoadXS::load_xs("getset1", "t", [Devel::CallParser::callparser_linkable()]); ok 1; t::getset1::test_cv_getset_call_parser(); ok 1; 1; Devel-CallParser-0.006/t/getset1.xs000555000000000024 404715261001057 16366 0ustar00rootstaff000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "getset1_callparser1.h" #include "XSUB.h" static OP *THX_parse_args_b(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(flags_p); return newSVOP(OP_CONST, 0, SvREFCNT_inc(psobj)); } MODULE = t::getset1 PACKAGE = t::getset1 PROTOTYPES: DISABLE void test_cv_getset_call_parser() PROTOTYPE: PREINIT: CV *t0_cv, *t1_cv; Perl_call_parser psfun; SV *psobj; CODE: #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__) #define croak_fail_ne(h, w) \ croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) #define check_cp(cv, xpsfun, xpsobj) \ do { \ cv_get_call_parser((cv), &psfun, &psobj); \ if (psfun != (xpsfun)) \ croak_fail_ne(FPTR2DPTR(void *, psfun), xpsfun); \ if (psobj != (xpsobj)) \ croak_fail_ne(FPTR2DPTR(void *, psobj), xpsobj); \ } while(0) t0_cv = get_cv("t::getset1::t0", 0); t1_cv = get_cv("t::getset1::t1", 0); check_cp(t0_cv, Perl_parse_args_proto_or_list, (SV*)t0_cv); check_cp(t1_cv, Perl_parse_args_proto_or_list, (SV*)t1_cv); cv_set_call_parser(t1_cv, Perl_parse_args_proto_or_list, &PL_sv_yes); check_cp(t0_cv, Perl_parse_args_proto_or_list, (SV*)t0_cv); check_cp(t1_cv, Perl_parse_args_proto_or_list, &PL_sv_yes); cv_set_call_parser(t0_cv, THX_parse_args_b, &PL_sv_no); check_cp(t0_cv, THX_parse_args_b, &PL_sv_no); check_cp(t1_cv, Perl_parse_args_proto_or_list, &PL_sv_yes); cv_set_call_parser(t1_cv, Perl_parse_args_proto_or_list, (SV*)t1_cv); check_cp(t0_cv, THX_parse_args_b, &PL_sv_no); check_cp(t1_cv, Perl_parse_args_proto_or_list, (SV*)t1_cv); cv_set_call_parser(t0_cv, Perl_parse_args_proto_or_list, (SV*)t0_cv); check_cp(t0_cv, Perl_parse_args_proto_or_list, (SV*)t0_cv); check_cp(t1_cv, Perl_parse_args_proto_or_list, (SV*)t1_cv); if (SvMAGICAL((SV*)t0_cv) || SvMAGIC((SV*)t0_cv)) croak_fail(); if (SvMAGICAL((SV*)t1_cv) || SvMAGIC((SV*)t1_cv)) croak_fail(); #undef check_cp #undef croak_fail_ne #undef croak_fail void t0() PROTOTYPE: CODE: ; void t1() PROTOTYPE: CODE: ; Devel-CallParser-0.006/t/indirect.t000555000000000024 46715261001057 16406 0ustar00rootstaff000000000000use warnings; no warnings "void"; use strict; use lib '.'; BEGIN { eval { require indirect; indirect->VERSION(0.27); }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "good indirect unavailable"); } } use Test::More tests => 1; use Devel::CallParser (); no indirect; ok 1; 1; Devel-CallParser-0.006/t/leximport.t000555000000000024 231615261001057 16643 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; BEGIN { eval { require Lexical::Sub; Lexical::Sub->VERSION(0.004); }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "good Lexical::Sub unavailable"); } } use File::Spec (); use IO::File (); use Test::More tests => 5; use t::LoadXS (); use t::WriteHeader (); { my $infn = File::Spec->catfile("t", "listquote.xs"); my $outfn = File::Spec->catfile("t", "leximport.xs"); END { unlink $outfn if defined $outfn; } my $in = IO::File->new($infn, "r") or die "$infn: $!"; my $out = IO::File->new($outfn, "w") or die "$outfn: $!"; local $/ = undef; my $xs = do { local $/ = undef; $in->getline }; $xs =~ s/(?<=t::)listquote|listquote(?=_call)/leximport/g; $out->printflush($xs) or die "$outfn: $!"; $out->close or die "$outfn: $!"; } t::WriteHeader::write_header("callparser0", "t", "leximport"); ok 1; require_ok "Devel::CallParser"; t::LoadXS::load_xs("leximport", "t", [Devel::CallParser::callparser_linkable()]); ok 1; use Lexical::Sub foo => sub { [ "aaa", @_, "zzz" ] }; t::leximport::cv_set_call_parser_listquote(\&foo, "xyz"); my $ret; eval q{$ret = foo:ab cd:;}; is $@, ""; is_deeply $ret, [ "aaa", "xyz", "a", "b", " ", "c", "d", "zzz" ]; 1; Devel-CallParser-0.006/t/listquote.t000555000000000024 471615261001057 16657 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; use Test::More tests => 47; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callparser0", "t", "listquote"); ok 1; require_ok "Devel::CallParser"; t::LoadXS::load_xs("listquote", "t", [Devel::CallParser::callparser_linkable()]); ok 1; my($foo_got, $foo_ret); sub foo { $foo_got = [ @_ ]; return "z"; } $foo_got = undef; eval q{$foo_ret = foo 1231;}; is $@, ""; is_deeply $foo_got, [ 1231 ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = &foo(1231);}; is $@, ""; is_deeply $foo_got, [ 1231 ]; is $foo_ret, "z"; t::listquote::cv_set_call_parser_listquote(\&foo, "xyz"); $foo_got = undef; eval q{$foo_ret = foo 1231;}; is $@, ""; is_deeply $foo_got, [ "xyz", "2", "3" ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = &foo(1231);}; is $@, ""; is_deeply $foo_got, [ 1231 ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = foo:ab cd:;}; is $@, ""; is_deeply $foo_got, [ "xyz", "a", "b", " ", "c", "d" ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = foo!ab cd!;}; isnt $@, ""; is $foo_got, undef; $foo_got = undef; eval q{foo!ab cd!;}; is $@, ""; is_deeply $foo_got, [ "xyz", "a", "b", " ", "c", "d" ]; $foo_got = undef; $foo_ret = undef; eval q{foo!ab cd! package main; $foo_ret = "z";}; is $@, ""; is_deeply $foo_got, [ "xyz", "a", "b", " ", "c", "d" ]; is $foo_ret, "z"; $foo_got = undef; $foo_ret = undef; eval q{foo:ab cd: package main; $foo_ret = "z";}; isnt $@, ""; is $foo_got, undef; *bar = \&foo; *bar = \&foo; $foo_got = undef; eval q{$foo_ret = bar:ab cd:;}; is $@, ""; is_deeply $foo_got, [ "xyz", "a", "b", " ", "c", "d" ]; is $foo_ret, "z"; *wibble::baz = \&foo; *wibble::baz = \&foo; $foo_got = undef; eval q{package wibble; $foo_ret = baz:ab cd:;}; is $@, ""; is_deeply $foo_got, [ "xyz", "a", "b", " ", "c", "d" ]; is $foo_ret, "z"; sub bin($$) { $foo_got = [ @_ ]; return "z"; } $foo_got = undef; eval q{$foo_ret = bin 1, 2;}; is $@, ""; is_deeply $foo_got, [ 1, 2 ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = bin 1;}; isnt $@, ""; is $foo_got, undef; $foo_got = undef; eval q{$foo_ret = bin 1, 2, 3;}; isnt $@, ""; is $foo_got, undef; t::listquote::cv_set_call_parser_listquote(\&bin, "aaa"); $foo_got = undef; eval q{$foo_ret = bin|b|;}; is $@, ""; is_deeply $foo_got, [ "aaa", "b" ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = bin||;}; isnt $@, ""; is $foo_got, undef; $foo_got = undef; eval q{$foo_ret = bin|bc|;}; isnt $@, ""; is $foo_got, undef; 1; Devel-CallParser-0.006/t/listquote.xs000555000000000024 306115261001057 17036 0ustar00rootstaff000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "listquote_callparser0.h" #include "XSUB.h" #ifndef op_append_elem # define op_append_elem(t, f, l) THX_op_append_elem(aTHX_ t, f, l) static OP *THX_op_append_elem(pTHX_ I32 type, OP *first, OP *last) { if(!first) return last; if(!last) return first; if(first->op_type != (unsigned)type || (type == OP_LIST && (first->op_flags & OPf_PARENS))) return newLISTOP(type, 0, first, last); if(first->op_flags & OPf_KIDS) { cLISTOPx(first)->op_last->op_sibling = last; } else { first->op_flags |= OPf_KIDS; cLISTOPx(first)->op_first = last; } cLISTOPx(first)->op_last = last; return first; } #endif /* !op_append_elem */ static OP *THX_parse_args_listquote(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { I32 qc; OP *argsop; PERL_UNUSED_ARG(namegv); argsop = newLISTOP(OP_LIST, 0, newSVOP(OP_CONST, 0, SvREFCNT_inc(psobj)), NULL); lex_read_space(0); qc = lex_read_unichar(0); if(qc == -1) croak("unexpected EOF"); while(1) { I32 c = lex_read_unichar(0); char cc; SV *csv; if(c == -1) croak("unexpected EOF"); if(c == qc) break; if(c > 0xff) croak("can't handle non-Latin-1 character"); cc = (char)c; csv = newSVpvn(&cc, 1); argsop = op_append_elem(OP_LIST, argsop, newSVOP(OP_CONST, 0, csv)); } if(qc == '!') *flags_p |= CALLPARSER_STATEMENT; return argsop; } MODULE = t::listquote PACKAGE = t::listquote PROTOTYPES: DISABLE void cv_set_call_parser_listquote(CV *cv, SV *psobj) PROTOTYPE: $$ CODE: cv_set_call_parser(cv, THX_parse_args_listquote, psobj); Devel-CallParser-0.006/t/multiblock.t000555000000000024 366015261001057 16770 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; BEGIN { if("$]" < 5.013007) { require Test::More; Test::More::plan(skip_all => "parse_block not available on this Perl"); } } use Test::More tests => 17; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callparser0", "t", "multiblock"); ok 1; require_ok "Devel::CallParser"; t::LoadXS::load_xs("multiblock", "t", [Devel::CallParser::callparser_linkable()]); ok 1; my @events; sub my_if($$$) { $_[0]->() ? $_[1]->() : $_[2]->() } t::multiblock::cv_set_call_parser_multiblock(\&my_if); @events = (); eval q{ push @events, "a"; my $x = "x".my_if({ 1; } { "c"; } { "d"; })."z"; push @events, $x; push @events, "e"; }; is $@, ""; is_deeply \@events, [ qw(a xcz e) ]; @events = (); eval q{ push @events, "a"; my $x = "x".my_if({ 0; } { "c"; } { "d"; })."z"; push @events, $x; push @events, "e"; }; is $@, ""; is_deeply \@events, [ qw(a xdz e) ]; @events = (); eval q{ push @events, "a"; my_if { push @events, "b"; 1; } { push @events, "c"; } { push @events, "d"; } package main; push @events, "e"; }; is $@, ""; is_deeply \@events, [ qw(a b c e) ]; @events = (); eval q{ push @events, "a"; my_if { push @events, "b"; 0; } { push @events, "c"; } { push @events, "d"; } package main; push @events, "e"; }; is $@, ""; is_deeply \@events, [ qw(a b d e) ]; @events = (); eval q{ push @events, "a"; my $x = "x".my_if { 1; } { "c"; } { "d"; }."z"; push @events, $x; push @events, "e"; }; isnt $@, ""; is_deeply \@events, []; @events = (); eval q{ push @events, "a"; my_if { push @events, "b"; 0; } { push @events, "c"; } { push @events, "d"; } { 123; } package main; push @events, "e"; }; isnt $@, ""; is_deeply \@events, []; @events = (); eval q{ push @events, "a"; my_if { push @events, "b"; 0; } { push @events, "c"; } package main; push @events, "e"; }; isnt $@, ""; is_deeply \@events, []; 1; Devel-CallParser-0.006/t/multiblock.xs000555000000000024 222015261001057 17146 0ustar00rootstaff000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "multiblock_callparser0.h" #include "XSUB.h" static OP *THX_parse_args_multiblock(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { OP *argsop = NULL; I32 c; bool is_expr; PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(psobj); lex_read_space(0); c = lex_peek_unichar(0); is_expr = c == '('/*)*/; if(is_expr) { lex_read_unichar(0); lex_read_space(0); c = lex_peek_unichar(0); } while(c == '{'/*}*/) { I32 floor = start_subparse(0, CVf_ANON); OP *blkop; SAVEFREESV(PL_compcv); blkop = parse_block(0); SvREFCNT_inc_simple_void((SV*)PL_compcv); blkop = newANONATTRSUB(floor, NULL, NULL, blkop); argsop = op_append_elem(OP_LIST, argsop, blkop); lex_read_space(0); c = lex_peek_unichar(0); } if(is_expr) { if(c != /*(*/')') croak("syntax error"); lex_read_unichar(0); *flags_p |= CALLPARSER_PARENS; } else { *flags_p |= CALLPARSER_STATEMENT; } return argsop; } MODULE = t::multiblock PACKAGE = t::multiblock PROTOTYPES: DISABLE void cv_set_call_parser_multiblock(CV *cv) PROTOTYPE: $ CODE: cv_set_call_parser(cv, THX_parse_args_multiblock, &PL_sv_undef); Devel-CallParser-0.006/t/no_hdr.t000555000000000024 44015261001057 16045 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; use Test::More tests => 2; require_ok "Devel::CallParser"; SKIP: { skip "callparser1.h available", 1 if "$]" >= 5.013008; eval { &Devel::CallParser::callparser1_h() }; like $@, qr/\Acallparser1\.h not available on this version of Perl/; } 1; Devel-CallParser-0.006/t/padrange.t000555000000000024 31115261001057 16352 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; use Test::More tests => 2; use Devel::CallParser (); sub tpad { my($a, $b, $c, $d); my($e, $f, $g, $h); my $i; is $i, undef; $i = 3; } tpad(); tpad(); 1; Devel-CallParser-0.006/t/pod_cvg.t000555000000000024 31015261001057 16211 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; 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; Devel-CallParser-0.006/t/pod_syn.t000555000000000024 25315261001057 16251 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; 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; Devel-CallParser-0.006/t/proto.t000555000000000024 1430515261001057 16004 0ustar00rootstaff000000000000use warnings; no warnings "syntax"; no warnings "void"; use strict; use lib '.'; BEGIN { if("$]" < 5.013008) { require Test::More; Test::More::plan(skip_all => "parse_*expr not available on this Perl"); } } use Test::More tests => 3 + 8*13; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callparser1", "t", "proto"); ok 1; require_ok "Devel::CallParser"; t::LoadXS::load_xs("proto", "t", [Devel::CallParser::callparser_linkable()]); ok 1; my @three = qw(a b c); sub unary($) { } sub noproto { } sub foo { [ map { ref($_) || $_ } @_ ] } is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1,2,3]]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c),4]]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH",1]]; t::proto::cv_set_call_parser_proto(\&foo, ""); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), undef; is_deeply scalar(eval(q{[ foo @three,4 ]})), undef; is_deeply scalar(eval(q{[ foo {} ]})), undef; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), undef; t::proto::cv_set_call_parser_proto(\&foo, "\$"); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1],2,3]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c)],4]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH"],1]; t::proto::cv_set_call_parser_proto(\&foo, ";\$"); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1],2,3]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c)],4]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH"],1]; t::proto::cv_set_call_parser_proto(\&foo, \&unary); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1],2,3]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c)],4]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH"],1]; t::proto::cv_set_call_parser_proto(\&foo, "\@"); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1,2,3]]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c),4]]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH",1]]; t::proto::cv_set_call_parser_proto(\&foo, "&\@"); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1,2,3]]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c),4]]; is_deeply scalar(eval(q{[ foo {} ]})), [["CODE"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), [["CODE",1]]; is_deeply scalar(eval(q{[ foo {}, 1 ]})), undef; t::proto::cv_set_call_parser_proto(\&foo, undef); is_deeply scalar(eval(q{foo()})), undef; is_deeply scalar(eval(q{foo(1,2,3)})), undef; is_deeply scalar(eval(q{[ foo ]})), undef; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), undef; is_deeply scalar(eval(q{[ foo @three,4 ]})), undef; is_deeply scalar(eval(q{[ foo {} ]})), undef; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), undef; t::proto::cv_set_call_parser_proto(\&foo, \&noproto); is_deeply scalar(eval(q{foo()})), undef; is_deeply scalar(eval(q{foo(1,2,3)})), undef; is_deeply scalar(eval(q{[ foo ]})), undef; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), undef; is_deeply scalar(eval(q{[ foo @three,4 ]})), undef; is_deeply scalar(eval(q{[ foo {} ]})), undef; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), undef; t::proto::cv_set_call_parser_proto_or_list(\&foo, ";\$"); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1],2,3]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c)],4]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH"],1]; t::proto::cv_set_call_parser_proto_or_list(\&foo, \&unary); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1],2,3]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c)],4]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH"],1]; t::proto::cv_set_call_parser_proto_or_list(\&foo, undef); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1,2,3]]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c),4]]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH",1]]; t::proto::cv_set_call_parser_proto_or_list(\&foo, \&noproto); is_deeply scalar(eval(q{foo()})), []; is_deeply scalar(eval(q{foo(1,2,3)})), [1,2,3]; is_deeply scalar(eval(q{[ foo ]})), [[]]; is_deeply scalar(eval(q{[ foo 1,2,3 ]})), [[1,2,3]]; is_deeply scalar(eval(q{[ foo @three,4 ]})), [[qw(a b c),4]]; is_deeply scalar(eval(q{[ foo {} ]})), [["HASH"]]; is_deeply scalar(eval(q{[ foo {} 1 ]})), undef; is_deeply scalar(eval(q{[ foo {}, 1 ]})), [["HASH",1]]; 1; Devel-CallParser-0.006/t/proto.xs000555000000000024 101015261001057 16140 0ustar00rootstaff000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "proto_callparser1.h" #include "XSUB.h" MODULE = t::proto PACKAGE = t::proto PROTOTYPES: DISABLE void cv_set_call_parser_proto(CV *cv, SV *proto) PROTOTYPE: $$ CODE: if(SvROK(proto)) proto = SvRV(proto); cv_set_call_parser(cv, Perl_parse_args_proto, proto); void cv_set_call_parser_proto_or_list(CV *cv, SV *proto) PROTOTYPE: $$ CODE: if(SvROK(proto)) proto = SvRV(proto); cv_set_call_parser(cv, Perl_parse_args_proto_or_list, proto); Devel-CallParser-0.006/t/stdargs.t000555000000000024 4035215261001057 16311 0ustar00rootstaff000000000000use warnings; no warnings "syntax"; no warnings "void"; use strict; use lib '.'; BEGIN { if("$]" < 5.013008) { require Test::More; Test::More::plan(skip_all => "parse_*expr not available on this Perl"); } } use Test::More tests => 3 + 12*4*5 + 7*5; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callparser1", "t", "stdargs"); ok 1; require_ok "Devel::CallParser"; t::LoadXS::load_xs("stdargs", "t", [Devel::CallParser::callparser_linkable()]); ok 1; my @three = qw(a b c); my @five = qw(a b c d e); sub par_() { [@_] } sub par_s($) { [@_] } sub par_ss($$) { [@_] } sub par_l(@) { [@_] } t::stdargs::cv_set_call_parser_parenthesised(\&par_); t::stdargs::cv_set_call_parser_parenthesised(\&par_s); t::stdargs::cv_set_call_parser_parenthesised(\&par_ss); t::stdargs::cv_set_call_parser_parenthesised(\&par_l); is_deeply scalar(eval(q{par_()})), []; is_deeply scalar(eval(q{par_(1)})), undef; is_deeply scalar(eval(q{par_(@three)})), undef; is_deeply scalar(eval(q{par_(@three, @five)})), undef; is_deeply scalar(eval(q{par_((9,8,7))})), undef; is_deeply scalar(eval(q{par_((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{par_})), undef; is_deeply scalar(eval(q{par_ 1})), undef; is_deeply scalar(eval(q{[ par_ 1, 2 ]})), undef; is_deeply scalar(eval(q{[ par_ @three, @five ]})), undef; is_deeply scalar(eval(q{[ par_ +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ par_ +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{par_s()})), undef; is_deeply scalar(eval(q{par_s(1)})), [1]; is_deeply scalar(eval(q{par_s(@three)})), [3]; is_deeply scalar(eval(q{par_s(@three, @five)})), undef; is_deeply scalar(eval(q{par_s((9,8,7))})), [7]; is_deeply scalar(eval(q{par_s((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{par_s})), undef; is_deeply scalar(eval(q{par_s 1})), undef; is_deeply scalar(eval(q{[ par_s 1, 2 ]})), undef; is_deeply scalar(eval(q{[ par_s @three, @five ]})), undef; is_deeply scalar(eval(q{[ par_s +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ par_s +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{par_ss()})), undef; is_deeply scalar(eval(q{par_ss(1)})), undef; is_deeply scalar(eval(q{par_ss(@three)})), undef; is_deeply scalar(eval(q{par_ss(@three, @five)})), [3,5]; is_deeply scalar(eval(q{par_ss((9,8,7))})), undef; is_deeply scalar(eval(q{par_ss((9,8,7), (6,5,4))})), [7,4]; is_deeply scalar(eval(q{par_ss})), undef; is_deeply scalar(eval(q{par_ss 1})), undef; is_deeply scalar(eval(q{[ par_ss 1, 2 ]})), undef; is_deeply scalar(eval(q{[ par_ss @three, @five ]})), undef; is_deeply scalar(eval(q{[ par_ss +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ par_ss +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{par_l()})), []; is_deeply scalar(eval(q{par_l(1)})), [1]; is_deeply scalar(eval(q{par_l(@three)})), [qw(a b c)]; is_deeply scalar(eval(q{par_l(@three, @five)})), [qw(a b c a b c d e)]; is_deeply scalar(eval(q{par_l((9,8,7))})), [9,8,7]; is_deeply scalar(eval(q{par_l((9,8,7), (6,5,4))})), [9,8,7,6,5,4]; is_deeply scalar(eval(q{par_l})), undef; is_deeply scalar(eval(q{par_l 1})), undef; is_deeply scalar(eval(q{[ par_l 1, 2 ]})), undef; is_deeply scalar(eval(q{[ par_l @three, @five ]})), undef; is_deeply scalar(eval(q{[ par_l +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ par_l +(9,8,7), (6,5,4) ]})), undef; sub nul_() { [@_] } sub nul_s($) { [@_] } sub nul_ss($$) { [@_] } sub nul_l(@) { [@_] } t::stdargs::cv_set_call_parser_nullary(\&nul_); t::stdargs::cv_set_call_parser_nullary(\&nul_s); t::stdargs::cv_set_call_parser_nullary(\&nul_ss); t::stdargs::cv_set_call_parser_nullary(\&nul_l); is_deeply scalar(eval(q{nul_()})), []; is_deeply scalar(eval(q{nul_(1)})), undef; is_deeply scalar(eval(q{nul_(@three)})), undef; is_deeply scalar(eval(q{nul_(@three, @five)})), undef; is_deeply scalar(eval(q{nul_((9,8,7))})), undef; is_deeply scalar(eval(q{nul_((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{nul_})), []; is_deeply scalar(eval(q{nul_ 1})), undef; is_deeply scalar(eval(q{[ nul_ 1, 2 ]})), undef; is_deeply scalar(eval(q{[ nul_ @three, @five ]})), undef; is_deeply scalar(eval(q{[ nul_ !(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ nul_ !(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{nul_s()})), undef; is_deeply scalar(eval(q{nul_s(1)})), [1]; is_deeply scalar(eval(q{nul_s(@three)})), [3]; is_deeply scalar(eval(q{nul_s(@three, @five)})), undef; is_deeply scalar(eval(q{nul_s((9,8,7))})), [7]; is_deeply scalar(eval(q{nul_s((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{nul_s})), undef; is_deeply scalar(eval(q{nul_s 1})), undef; is_deeply scalar(eval(q{[ nul_s 1, 2 ]})), undef; is_deeply scalar(eval(q{[ nul_s @three, @five ]})), undef; is_deeply scalar(eval(q{[ nul_s !(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ nul_s !(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{nul_ss()})), undef; is_deeply scalar(eval(q{nul_ss(1)})), undef; is_deeply scalar(eval(q{nul_ss(@three)})), undef; is_deeply scalar(eval(q{nul_ss(@three, @five)})), [3,5]; is_deeply scalar(eval(q{nul_ss((9,8,7))})), undef; is_deeply scalar(eval(q{nul_ss((9,8,7), (6,5,4))})), [7,4]; is_deeply scalar(eval(q{nul_ss})), undef; is_deeply scalar(eval(q{nul_ss 1})), undef; is_deeply scalar(eval(q{[ nul_ss 1, 2 ]})), undef; is_deeply scalar(eval(q{[ nul_ss @three, @five ]})), undef; is_deeply scalar(eval(q{[ nul_ss !(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ nul_ss !(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{nul_l()})), []; is_deeply scalar(eval(q{nul_l(1)})), [1]; is_deeply scalar(eval(q{nul_l(@three)})), [qw(a b c)]; is_deeply scalar(eval(q{nul_l(@three, @five)})), [qw(a b c a b c d e)]; is_deeply scalar(eval(q{nul_l((9,8,7))})), [9,8,7]; is_deeply scalar(eval(q{nul_l((9,8,7), (6,5,4))})), [9,8,7,6,5,4]; is_deeply scalar(eval(q{nul_l})), []; is_deeply scalar(eval(q{nul_l 1})), undef; is_deeply scalar(eval(q{[ nul_l 1, 2 ]})), undef; is_deeply scalar(eval(q{[ nul_l @three, @five ]})), undef; is_deeply scalar(eval(q{[ nul_l !(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ nul_l !(9,8,7), (6,5,4) ]})), undef; sub una_() { [@_] } sub una_s($) { [@_] } sub una_ss($$) { [@_] } sub una_l(@) { [@_] } t::stdargs::cv_set_call_parser_unary(\&una_); t::stdargs::cv_set_call_parser_unary(\&una_s); t::stdargs::cv_set_call_parser_unary(\&una_ss); t::stdargs::cv_set_call_parser_unary(\&una_l); is_deeply scalar(eval(q{una_()})), []; is_deeply scalar(eval(q{una_(1)})), undef; is_deeply scalar(eval(q{una_(@three)})), undef; is_deeply scalar(eval(q{una_(@three, @five)})), undef; is_deeply scalar(eval(q{una_((9,8,7))})), undef; is_deeply scalar(eval(q{una_((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{una_})), []; is_deeply scalar(eval(q{una_ 1})), undef; is_deeply scalar(eval(q{[ una_ 1, 2 ]})), undef; is_deeply scalar(eval(q{[ una_ @three, @five ]})), undef; is_deeply scalar(eval(q{[ una_ +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ una_ +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{una_s()})), undef; is_deeply scalar(eval(q{una_s(1)})), [1]; is_deeply scalar(eval(q{una_s(@three)})), [3]; is_deeply scalar(eval(q{una_s(@three, @five)})), undef; is_deeply scalar(eval(q{una_s((9,8,7))})), [7]; is_deeply scalar(eval(q{una_s((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{una_s})), undef; is_deeply scalar(eval(q{una_s 1})), [1]; is_deeply scalar(eval(q{[ una_s 1, 2 ]})), [[1],2]; is_deeply scalar(eval(q{[ una_s @three, @five ]})), [[3],qw(a b c d e)]; is_deeply scalar(eval(q{[ una_s +(9,8,7) ]})), [[7]]; is_deeply scalar(eval(q{[ una_s +(9,8,7), (6,5,4) ]})), [[7],6,5,4]; is_deeply scalar(eval(q{una_ss()})), undef; is_deeply scalar(eval(q{una_ss(1)})), undef; is_deeply scalar(eval(q{una_ss(@three)})), undef; is_deeply scalar(eval(q{una_ss(@three, @five)})), [3,5]; is_deeply scalar(eval(q{una_ss((9,8,7))})), undef; is_deeply scalar(eval(q{una_ss((9,8,7), (6,5,4))})), [7,4]; is_deeply scalar(eval(q{una_ss})), undef; is_deeply scalar(eval(q{una_ss 1})), undef; is_deeply scalar(eval(q{[ una_ss 1, 2 ]})), undef; is_deeply scalar(eval(q{[ una_ss @three, @five ]})), undef; is_deeply scalar(eval(q{[ una_ss +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ una_ss +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{una_l()})), []; is_deeply scalar(eval(q{una_l(1)})), [1]; is_deeply scalar(eval(q{una_l(@three)})), [qw(a b c)]; is_deeply scalar(eval(q{una_l(@three, @five)})), [qw(a b c a b c d e)]; is_deeply scalar(eval(q{una_l((9,8,7))})), [9,8,7]; is_deeply scalar(eval(q{una_l((9,8,7), (6,5,4))})), [9,8,7,6,5,4]; is_deeply scalar(eval(q{una_l})), []; is_deeply scalar(eval(q{una_l 1})), [1]; is_deeply scalar(eval(q{[ una_l 1, 2 ]})), [[1],2]; is_deeply scalar(eval(q{[ una_l @three, @five ]})), [[qw(a b c)],qw(a b c d e)]; is_deeply scalar(eval(q{[ una_l +(9,8,7) ]})), [[9,8,7]]; is_deeply scalar(eval(q{[ una_l +(9,8,7), (6,5,4) ]})), [[9,8,7],6,5,4]; sub lis_() { [@_] } sub lis_s($) { [@_] } sub lis_ss($$) { [@_] } sub lis_l(@) { [@_] } t::stdargs::cv_set_call_parser_list(\&lis_); t::stdargs::cv_set_call_parser_list(\&lis_s); t::stdargs::cv_set_call_parser_list(\&lis_ss); t::stdargs::cv_set_call_parser_list(\&lis_l); is_deeply scalar(eval(q{lis_()})), []; is_deeply scalar(eval(q{lis_(1)})), undef; is_deeply scalar(eval(q{lis_(@three)})), undef; is_deeply scalar(eval(q{lis_(@three, @five)})), undef; is_deeply scalar(eval(q{lis_((9,8,7))})), undef; is_deeply scalar(eval(q{lis_((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{lis_})), []; is_deeply scalar(eval(q{lis_ 1})), undef; is_deeply scalar(eval(q{[ lis_ 1, 2 ]})), undef; is_deeply scalar(eval(q{[ lis_ @three, @five ]})), undef; is_deeply scalar(eval(q{[ lis_ +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ lis_ +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{lis_s()})), undef; is_deeply scalar(eval(q{lis_s(1)})), [1]; is_deeply scalar(eval(q{lis_s(@three)})), [3]; is_deeply scalar(eval(q{lis_s(@three, @five)})), undef; is_deeply scalar(eval(q{lis_s((9,8,7))})), [7]; is_deeply scalar(eval(q{lis_s((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{lis_s})), undef; is_deeply scalar(eval(q{lis_s 1})), [1]; is_deeply scalar(eval(q{[ lis_s 1, 2 ]})), undef; is_deeply scalar(eval(q{[ lis_s @three, @five ]})), undef; is_deeply scalar(eval(q{[ lis_s +(9,8,7) ]})), [[7]]; is_deeply scalar(eval(q{[ lis_s +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{lis_ss()})), undef; is_deeply scalar(eval(q{lis_ss(1)})), undef; is_deeply scalar(eval(q{lis_ss(@three)})), undef; is_deeply scalar(eval(q{lis_ss(@three, @five)})), [3,5]; is_deeply scalar(eval(q{lis_ss((9,8,7))})), undef; is_deeply scalar(eval(q{lis_ss((9,8,7), (6,5,4))})), [7,4]; is_deeply scalar(eval(q{lis_ss})), undef; is_deeply scalar(eval(q{lis_ss 1})), undef; is_deeply scalar(eval(q{[ lis_ss 1, 2 ]})), [[1,2]]; is_deeply scalar(eval(q{[ lis_ss @three, @five ]})), [[3,5]]; is_deeply scalar(eval(q{[ lis_ss +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ lis_ss +(9,8,7), (6,5,4) ]})), [[7,4]]; is_deeply scalar(eval(q{lis_l()})), []; is_deeply scalar(eval(q{lis_l(1)})), [1]; is_deeply scalar(eval(q{lis_l(@three)})), [qw(a b c)]; is_deeply scalar(eval(q{lis_l(@three, @five)})), [qw(a b c a b c d e)]; is_deeply scalar(eval(q{lis_l((9,8,7))})), [9,8,7]; is_deeply scalar(eval(q{lis_l((9,8,7), (6,5,4))})), [9,8,7,6,5,4]; is_deeply scalar(eval(q{lis_l})), []; is_deeply scalar(eval(q{lis_l 1})), [1]; is_deeply scalar(eval(q{[ lis_l 1, 2 ]})), [[1,2]]; is_deeply scalar(eval(q{[ lis_l @three, @five ]})), [[qw(a b c),qw(a b c d e)]]; is_deeply scalar(eval(q{[ lis_l +(9,8,7) ]})), [[9,8,7]]; is_deeply scalar(eval(q{[ lis_l +(9,8,7), (6,5,4) ]})), [[9,8,7,6,5,4]]; sub blo_() { [@_] } sub blo_s($) { [@_] } sub blo_ss($$) { [@_] } sub blo_l(@) { [@_] } t::stdargs::cv_set_call_parser_block_list(\&blo_); t::stdargs::cv_set_call_parser_block_list(\&blo_s); t::stdargs::cv_set_call_parser_block_list(\&blo_ss); t::stdargs::cv_set_call_parser_block_list(\&blo_l); is_deeply scalar(eval(q{blo_()})), []; is_deeply scalar(eval(q{blo_(1)})), undef; is_deeply scalar(eval(q{blo_(@three)})), undef; is_deeply scalar(eval(q{blo_(@three, @five)})), undef; is_deeply scalar(eval(q{blo_((9,8,7))})), undef; is_deeply scalar(eval(q{blo_((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{blo_})), []; is_deeply scalar(eval(q{blo_ 1})), undef; is_deeply scalar(eval(q{[ blo_ 1, 2 ]})), undef; is_deeply scalar(eval(q{[ blo_ @three, @five ]})), undef; is_deeply scalar(eval(q{[ blo_ +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ blo_ +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{blo_s()})), undef; is_deeply scalar(eval(q{blo_s(1)})), [1]; is_deeply scalar(eval(q{blo_s(@three)})), [3]; is_deeply scalar(eval(q{blo_s(@three, @five)})), undef; is_deeply scalar(eval(q{blo_s((9,8,7))})), [7]; is_deeply scalar(eval(q{blo_s((9,8,7), (6,5,4))})), undef; is_deeply scalar(eval(q{blo_s})), undef; is_deeply scalar(eval(q{blo_s 1})), [1]; is_deeply scalar(eval(q{[ blo_s 1, 2 ]})), undef; is_deeply scalar(eval(q{[ blo_s @three, @five ]})), undef; is_deeply scalar(eval(q{[ blo_s +(9,8,7) ]})), [[7]]; is_deeply scalar(eval(q{[ blo_s +(9,8,7), (6,5,4) ]})), undef; is_deeply scalar(eval(q{blo_ss()})), undef; is_deeply scalar(eval(q{blo_ss(1)})), undef; is_deeply scalar(eval(q{blo_ss(@three)})), undef; is_deeply scalar(eval(q{blo_ss(@three, @five)})), [3,5]; is_deeply scalar(eval(q{blo_ss((9,8,7))})), undef; is_deeply scalar(eval(q{blo_ss((9,8,7), (6,5,4))})), [7,4]; is_deeply scalar(eval(q{blo_ss})), undef; is_deeply scalar(eval(q{blo_ss 1})), undef; is_deeply scalar(eval(q{[ blo_ss 1, 2 ]})), [[1,2]]; is_deeply scalar(eval(q{[ blo_ss @three, @five ]})), [[3,5]]; is_deeply scalar(eval(q{[ blo_ss +(9,8,7) ]})), undef; is_deeply scalar(eval(q{[ blo_ss +(9,8,7), (6,5,4) ]})), [[7,4]]; is_deeply scalar(eval(q{blo_l()})), []; is_deeply scalar(eval(q{blo_l(1)})), [1]; is_deeply scalar(eval(q{blo_l(@three)})), [qw(a b c)]; is_deeply scalar(eval(q{blo_l(@three, @five)})), [qw(a b c a b c d e)]; is_deeply scalar(eval(q{blo_l((9,8,7))})), [9,8,7]; is_deeply scalar(eval(q{blo_l((9,8,7), (6,5,4))})), [9,8,7,6,5,4]; is_deeply scalar(eval(q{blo_l})), []; is_deeply scalar(eval(q{blo_l 1})), [1]; is_deeply scalar(eval(q{[ blo_l 1, 2 ]})), [[1,2]]; is_deeply scalar(eval(q{[ blo_l @three, @five ]})), [[qw(a b c),qw(a b c d e)]]; is_deeply scalar(eval(q{[ blo_l +(9,8,7) ]})), [[9,8,7]]; is_deeply scalar(eval(q{[ blo_l +(9,8,7), (6,5,4) ]})), [[9,8,7,6,5,4]]; sub par_r { [ map { ref } @_ ] } sub nul_r { [ map { ref } @_ ] } sub una_r { [ map { ref } @_ ] } sub lis_r { [ map { ref } @_ ] } sub blo_r { [ map { ref } @_ ] } t::stdargs::cv_set_call_parser_parenthesised(\&par_r); t::stdargs::cv_set_call_parser_nullary(\&nul_r); t::stdargs::cv_set_call_parser_unary(\&una_r); t::stdargs::cv_set_call_parser_list(\&lis_r); t::stdargs::cv_set_call_parser_block_list(\&blo_r); is_deeply scalar(eval(q{par_r({})})), ["HASH"]; is_deeply scalar(eval(q{par_r(sub{})})), ["CODE"]; is_deeply scalar(eval(q{par_r {}})), undef; is_deeply scalar(eval(q{par_r {} 1})), undef; is_deeply scalar(eval(q{par_r {} 1, 2})), undef; is_deeply scalar(eval(q{[ par_r {}, 1 ]})), undef; is_deeply scalar(eval(q{[ par_r {}, 1, 2 ]})), undef; is_deeply scalar(eval(q{nul_r({})})), ["HASH"]; is_deeply scalar(eval(q{nul_r(sub{})})), ["CODE"]; is_deeply scalar(eval(q{nul_r {}})), undef; is_deeply scalar(eval(q{nul_r {} 1})), undef; is_deeply scalar(eval(q{nul_r {} 1, 2})), undef; is_deeply scalar(eval(q{[ nul_r {}, 1 ]})), undef; is_deeply scalar(eval(q{[ nul_r {}, 1, 2 ]})), undef; is_deeply scalar(eval(q{una_r({})})), ["HASH"]; is_deeply scalar(eval(q{una_r(sub{})})), ["CODE"]; is_deeply scalar(eval(q{una_r {}})), ["HASH"]; is_deeply scalar(eval(q{una_r {} 1})), undef; is_deeply scalar(eval(q{una_r {} 1, 2})), undef; is_deeply scalar(eval(q{[ una_r {}, 1 ]})), [["HASH"],1]; is_deeply scalar(eval(q{[ una_r {}, 1, 2 ]})), [["HASH"],1,2]; is_deeply scalar(eval(q{lis_r({})})), ["HASH"]; is_deeply scalar(eval(q{lis_r(sub{})})), ["CODE"]; is_deeply scalar(eval(q{lis_r {}})), ["HASH"]; is_deeply scalar(eval(q{lis_r {} 1})), undef; is_deeply scalar(eval(q{lis_r {} 1, 2})), undef; is_deeply scalar(eval(q{[ lis_r {}, 1 ]})), [["HASH",""]]; is_deeply scalar(eval(q{[ lis_r {}, 1, 2 ]})), [["HASH","",""]]; is_deeply scalar(eval(q{blo_r({})})), ["HASH"]; is_deeply scalar(eval(q{blo_r(sub{})})), ["CODE"]; is_deeply scalar(eval(q{blo_r {}})), ["CODE"]; is_deeply scalar(eval(q{blo_r {} 1})), ["CODE",""]; is_deeply scalar(eval(q{blo_r {} 1, 2})), ["CODE","",""]; is_deeply scalar(eval(q{[ blo_r {}, 1 ]})), undef; is_deeply scalar(eval(q{[ blo_r {}, 1, 2 ]})), undef; 1; Devel-CallParser-0.006/t/stdargs.xs000555000000000024 305715261001057 16461 0ustar00rootstaff000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "stdargs_callparser1.h" #include "XSUB.h" static OP *THX_pa_parenthesised(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(psobj); return parse_args_parenthesised(flags_p); } static OP *THX_pa_nullary(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(psobj); return parse_args_nullary(flags_p); } static OP *THX_pa_unary(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(psobj); return parse_args_unary(flags_p); } static OP *THX_pa_list(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(psobj); return parse_args_list(flags_p); } static OP *THX_pa_block_list(pTHX_ GV *namegv, SV *psobj, U32 *flags_p) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(psobj); return parse_args_block_list(flags_p); } MODULE = t::stdargs PACKAGE = t::stdargs PROTOTYPES: DISABLE void cv_set_call_parser_parenthesised(CV *cv) PROTOTYPE: $ CODE: cv_set_call_parser(cv, THX_pa_parenthesised, &PL_sv_undef); void cv_set_call_parser_nullary(CV *cv) PROTOTYPE: $ CODE: cv_set_call_parser(cv, THX_pa_nullary, &PL_sv_undef); void cv_set_call_parser_unary(CV *cv) PROTOTYPE: $ CODE: cv_set_call_parser(cv, THX_pa_unary, &PL_sv_undef); void cv_set_call_parser_list(CV *cv) PROTOTYPE: $ CODE: cv_set_call_parser(cv, THX_pa_list, &PL_sv_undef); void cv_set_call_parser_block_list(CV *cv) PROTOTYPE: $ CODE: cv_set_call_parser(cv, THX_pa_block_list, &PL_sv_undef); Devel-CallParser-0.006/t/substrictdecl.t000555000000000024 101515261001057 17465 0ustar00rootstaff000000000000use warnings; use strict; use lib '.'; BEGIN { eval { require Sub::StrictDecl; Sub::StrictDecl->VERSION(0.001); }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "good Sub::StrictDecl unavailable"); } } use Test::More tests => 4; use Devel::CallParser (); my $r; $r = eval(q{ use Sub::StrictDecl; if(0) { foo0(); } 1; }); is $r, undef; like $@, qr/\AUndeclared subroutine &main::foo0/; $r = eval(q{ use Sub::StrictDecl; sub foo1; if(0) { foo1(); } 1; }); is $r, 1; is $@, ""; 1;