Devel-CallParser-0.002000755001750001750 012217370704 14536 5ustar00zeframzefram000000000000Devel-CallParser-0.002/.gitignore000444001750001750 30312217370675 16646 0ustar00zeframzefram000000000000/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.002/MANIFEST000444001750001750 73112217370675 16014 0ustar00zeframzefram000000000000.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/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.002/Makefile.PL000444001750001750 233612217370675 16660 0ustar00zeframzefram000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4007 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.002/META.json000444001750001750 350312217370675 16324 0ustar00zeframzefram000000000000{ "abstract" : "custom parsing attached to subroutines", "author" : [ "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4007, CPAN::Meta::Converter version 2.131560", "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.002" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.002" } Devel-CallParser-0.002/Build.PL000444001750001750 1017112217370675 16216 0ustar00zeframzefram000000000000{ use 5.006; } use warnings; use strict; use Module::Build; Module::Build->subclass(code => q{ unless(__PACKAGE__->can("cbuilder")) { *cbuilder = sub { $_[0]->_cbuilder or die "no C support" }; } 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.002/META.yml000444001750001750 201012217370675 16144 0ustar00zeframzefram000000000000--- 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.4007, CPAN::Meta::Converter version 2.131560' 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.002 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.002 Devel-CallParser-0.002/README000444001750001750 201512217370675 15560 0ustar00zeframzefram000000000000NAME 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.002/Changes000444001750001750 216512217370675 16201 0ustar00zeframzefram000000000000version 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.002/SIGNATURE000644001750001750 517212217370704 16166 0ustar00zeframzefram000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.73. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 5af20cd5dd4a4b5a9470fe042b378add2749e3bc .gitignore SHA1 68fc7d292201509b83ae7a9b45b741f599d471cd Build.PL SHA1 820e6b5713f56163dcb8e34e86da3d9266325307 Changes SHA1 61a42866a305d8fb294db15766c749f687e61c39 MANIFEST SHA1 fefba5c9005b268c467b615b22598d6b39fba2e1 META.json SHA1 93ad53fb0d2a5bc04045b8d0e0d617ffb707085a META.yml SHA1 a0cb26eb58b674f73ab65fd46edd9c39c6d37b82 Makefile.PL SHA1 4f6dbda0b8ca140a54e9443fd8d77ff02c3bdacc README SHA1 6b5b11b1ea249f2172c98bd1cb2fcd1aed9ac1a3 lib/Devel/CallParser.pm SHA1 1f4e6eac6a7586eacfa2d636cb013bd67010e57a lib/Devel/CallParser.xs SHA1 f02cae7124e7060dbd03f4b62113532e08b289d9 t/LoadXS.pm SHA1 43fd1537f25d73895173b56955777d1a73487e22 t/WriteHeader.pm SHA1 4888ce181df3a80c4a9d3aba10bded84863b0cf7 t/dataalias.t SHA1 d9af41342c613b1c11664eaa668dcd54be44ce5a t/develdeclare.t SHA1 5748d664bc5165fd5121d003eb4470b50cc5f3c1 t/getset0.t SHA1 013fb6c465e97a1170839702328e7a06503ca43e t/getset0.xs SHA1 3c377558349112ea66ec944233898312cd4835a9 t/getset1.t SHA1 930079ece11b2c84b51f3c01a0a6c0b8d834192c t/getset1.xs SHA1 c221ec270184b93c0a8b299f90055911f8ca3bac t/indirect.t SHA1 ee466f8dce73755e159218d75854f2689b6aa27b t/leximport.t SHA1 e113e52473b5c256758f047260a71495fe6a16f5 t/listquote.t SHA1 39d9ea22b913c0f83258380f27cf1fc1e70b5725 t/listquote.xs SHA1 d3ba2dd095ffad5c682601f048a3e708abf0fe31 t/multiblock.t SHA1 592699ddf4bbac76dc20981f03d89ae6738eb8a4 t/multiblock.xs SHA1 92391f864c0d06017566d3de564b635ce995bb7e t/no_hdr.t SHA1 8f8e7017cc0756c80f6f26f33575c8f07f2bd4b9 t/padrange.t SHA1 904d9a4f76525e2303e4b0c168c68230f223c8de t/pod_cvg.t SHA1 65c75abdef6f01a5d1588a307f2ddfe2333dc961 t/pod_syn.t SHA1 158022b222d469c159c555fb91f66406593bc745 t/proto.t SHA1 f58180dfb854241815f9fe14c94b35c2ccb46165 t/proto.xs SHA1 2b8289efacf2459406d33960db1434753f3b711e t/stdargs.t SHA1 531f4880789472ad90659594eec8085601a6f8f3 t/stdargs.xs SHA1 dc9f48165c5b9b330f2d327a378342de541ad472 t/substrictdecl.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.12 (GNU/Linux) iEYEARECAAYFAlI98b0ACgkQOV9mt2VyAVEC0wCeIMqxGgnT+K2AK1ONV6FCj9j7 7OQAn081s+zWiu1PYkKInuJbEuojFWrO =wINz -----END PGP SIGNATURE----- Devel-CallParser-0.002/lib000755001750001750 012217370675 15313 5ustar00zeframzefram000000000000Devel-CallParser-0.002/lib/Devel000755001750001750 012217370675 16352 5ustar00zeframzefram000000000000Devel-CallParser-0.002/lib/Devel/CallParser.xs000444001750001750 3416212217370675 21141 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "callchecker0.h" #include "XSUB.h" #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #define PERL_DECIMAL_VERSION \ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #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 # 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 */ 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; /* * 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. */ #define MUST_RESTORE_PAD_FILL PERL_VERSION_GE(5,17,6) #if MUST_RESTORE_PAD_FILL I32 padfill = av_len(PL_comppad); #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); #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.002/lib/Devel/CallParser.pm000444001750001750 3472612217370675 21131 0ustar00zeframzefram000000000000=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.002"; 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.002/t000755001750001750 012217370675 15010 5ustar00zeframzefram000000000000Devel-CallParser-0.002/t/getset1.t000444001750001750 72612217370675 16673 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/stdargs.xs000444001750001750 305712217370675 17175 0ustar00zeframzefram000000000000#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.002/t/pod_syn.t000444001750001750 23612217370675 16766 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod not available" unless eval "use Test::Pod 1.00; 1"; Test::Pod::all_pod_files_ok(); 1; Devel-CallParser-0.002/t/dataalias.t000444001750001750 52512217370675 17237 0ustar00zeframzefram000000000000use warnings; no warnings "void"; use strict; 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.002/t/no_hdr.t000444001750001750 42312217370675 16562 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/LoadXS.pm000444001750001750 225412217370675 16640 0ustar00zeframzefram000000000000package t::LoadXS; use warnings; use strict; 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; 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.002/t/listquote.xs000444001750001750 306112217370675 17552 0ustar00zeframzefram000000000000#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.002/t/getset0.xs000444001750001750 416512217370675 17102 0ustar00zeframzefram000000000000#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.002/t/stdargs.t000444001750001750 4033512217370675 17026 0ustar00zeframzefram000000000000use warnings; no warnings "syntax"; no warnings "void"; use strict; 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.002/t/develdeclare.t000444001750001750 114412217370675 17751 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/pod_cvg.t000444001750001750 27312217370675 16735 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More; plan skip_all => "Test::Pod::Coverage not available" unless eval "use Test::Pod::Coverage; 1"; Test::Pod::Coverage::all_pod_coverage_ok(); 1; Devel-CallParser-0.002/t/proto.xs000444001750001750 101012217370675 16654 0ustar00zeframzefram000000000000#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.002/t/leximport.t000444001750001750 230112217370675 17351 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/indirect.t000444001750001750 45212217370675 17114 0ustar00zeframzefram000000000000use warnings; no warnings "void"; use strict; 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.002/t/getset0.t000444001750001750 51612217370675 16667 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/WriteHeader.pm000444001750001750 100312217370675 17700 0ustar00zeframzefram000000000000package 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.002/t/multiblock.t000444001750001750 364312217370675 17505 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/proto.t000444001750001750 1427012217370675 16521 0ustar00zeframzefram000000000000use warnings; no warnings "syntax"; no warnings "void"; use strict; 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.002/t/listquote.t000444001750001750 470112217370675 17365 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/substrictdecl.t000444001750001750 100012217370675 20173 0ustar00zeframzefram000000000000use warnings; use strict; 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; Devel-CallParser-0.002/t/padrange.t000444001750001750 27412217370675 17076 0ustar00zeframzefram000000000000use warnings; use strict; 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.002/t/getset1.xs000444001750001750 404712217370675 17102 0ustar00zeframzefram000000000000#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.002/t/multiblock.xs000444001750001750 222012217370675 17662 0ustar00zeframzefram000000000000#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);