Devel-CallChecker-0.007000755001750001750 012503257324 14653 5ustar00zeframzefram000000000000Devel-CallChecker-0.007/.gitignore000444001750001750 25412503257316 16762 0ustar00zeframzefram000000000000/Build /Makefile /_build /blib /META.json /META.yml /MYMETA.json /MYMETA.yml /Makefile.PL /SIGNATURE /Devel-CallChecker-* /lib/Devel/CallChecker.c /lib/Devel/CallChecker.o Devel-CallChecker-0.007/MANIFEST000444001750001750 47712503257316 16132 0ustar00zeframzefram000000000000.gitignore Build.PL Changes MANIFEST META.json META.yml Makefile.PL README lib/Devel/CallChecker.pm lib/Devel/CallChecker.xs t/LoadXS.pm t/WriteHeader.pm t/callck.t t/callck.xs t/pod_cvg.t t/pod_syn.t t/rv2cvopcv.t t/rv2cvopcv.xs t/threads.t t/threads1.xs t/threads2.xs typemap SIGNATURE Added here by Module::Build Devel-CallChecker-0.007/Makefile.PL000444001750001750 233312503257316 16764 0ustar00zeframzefram000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4205 require 5.006; 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-CallChecker-0.007/META.json000444001750001750 317112503257316 16434 0ustar00zeframzefram000000000000{ "abstract" : "custom op checking attached to subroutines", "author" : [ "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4205", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Devel-CallChecker", "prereqs" : { "build" : { "requires" : { "DynaLoader" : "0", "ExtUtils::CBuilder" : "0.15", "ExtUtils::ParseXS" : "0", "File::Spec" : "0", "IO::File" : "1.03", "Module::Build" : "0", "Test::More" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "runtime" : { "conflicts" : { "B::Hooks::OP::Check" : "< 0.19" }, "requires" : { "DynaLoader" : "0", "DynaLoader::Functions" : "0.001", "Exporter" : "0", "parent" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } } }, "provides" : { "Devel::CallChecker" : { "file" : "lib/Devel/CallChecker.pm", "version" : "0.007" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.007" } Devel-CallChecker-0.007/Build.PL000444001750001750 571712503257316 16317 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 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::CallChecker") { $args{dl_func_list} = [ @{$args{dl_func_list}||[]}, ("$]" >= 5.013006 ? () : qw( xAd8NP3gxZglovQRL5Hn_roc0 xAd8NP3gxZglovQRL5Hn_eal0 xAd8NP3gxZglovQRL5Hn_eap0 xAd8NP3gxZglovQRL5Hn_ean0 xAd8NP3gxZglovQRL5Hn_gcc0 xAd8NP3gxZglovQRL5Hn_scc0 )), ]; $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($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::CallChecker", license => "perl", configure_requires => { "Module::Build" => 0, "perl" => "5.006", "strict" => 0, "warnings" => 0, }, build_requires => { "DynaLoader" => 0, "ExtUtils::CBuilder" => "0.15", "ExtUtils::ParseXS" => 0, "File::Spec" => 0, "IO::File" => "1.03", "Module::Build" => 0, "Test::More" => 0, "perl" => "5.006", "strict" => 0, "warnings" => 0, }, requires => { "DynaLoader" => 0, "DynaLoader::Functions" => "0.001", "Exporter" => 0, "parent" => 0, "perl" => "5.006", "strict" => 0, "warnings" => 0, }, conflicts => { "B::Hooks::OP::Check" => "< 0.19", }, dynamic_config => 0, meta_add => { distribution_type => "module" }, create_makefile_pl => "passthrough", sign => 1, )->create_build_script; 1; Devel-CallChecker-0.007/META.yml000444001750001750 172212503257316 16264 0ustar00zeframzefram000000000000--- abstract: 'custom op checking attached to subroutines' author: - 'Andrew Main (Zefram) ' build_requires: DynaLoader: '0' ExtUtils::CBuilder: '0.15' ExtUtils::ParseXS: '0' File::Spec: '0' IO::File: '1.03' Module::Build: '0' Test::More: '0' perl: '5.006' strict: '0' warnings: '0' configure_requires: Module::Build: '0' perl: '5.006' strict: '0' warnings: '0' conflicts: B::Hooks::OP::Check: '< 0.19' dynamic_config: 0 generated_by: 'Module::Build version 0.4205, 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-CallChecker provides: Devel::CallChecker: file: lib/Devel/CallChecker.pm version: '0.007' requires: DynaLoader: '0' DynaLoader::Functions: '0.001' Exporter: '0' parent: '0' perl: '5.006' strict: '0' warnings: '0' resources: license: http://dev.perl.org/licenses/ version: '0.007' Devel-CallChecker-0.007/README000444001750001750 233012503257316 15667 0ustar00zeframzefram000000000000NAME Devel::CallChecker - custom op checking attached to subroutines DESCRIPTION This module makes some new features of the Perl 5.14.0 C API available to XS modules running on older versions of Perl. The features are centred around the function "cv_set_call_checker", which allows XS code to attach a magical annotation to a Perl subroutine, resulting in resolvable calls to that subroutine being mutated at compile time by arbitrary C code. This module makes "cv_set_call_checker" and several supporting functions available. (It is possible to achieve the effect of "cv_set_call_checker" from XS code on much earlier Perl versions, but it is painful to achieve without the centralised facility.) This module provides the implementation of the functions at runtime (on Perls where they are not provided by the core), 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, 2012, 2013, 2015 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-CallChecker-0.007/Changes000444001750001750 406212503257316 16306 0ustar00zeframzefram000000000000version 0.007; 2015-03-21 * update tests for Perl 5.21.2, where the op_sibling field has changed meaning version 0.006; 2013-09-21 * bugfix: allow generated headers to work on API-compatible Perls other than the specific version under which this module was installed * fix test for thread safety, which risked false negatives * avoid a C compiler warning in a test version 0.005; 2012-02-11 * be thread-safe, by idempotence and mutex control on op check hooking * 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 * fix some C preprocessor directive indentation version 0.004; 2012-02-01 * in documentation, clarify that the header and linkable functions should be called at build time * add B::CallChecker to "see also" list * update tests to accept Perl 5.15.7's modified panic error messages * in Build.PL, declare incompatibility with pre-0.19 B::Hooks::OP::Check, which doesn't play nicely around op check hooking * convert .cvsignore to .gitignore version 0.003; 2011-05-29 * bugfix: set up CV name links correctly for error messages from prototype checkers * bugfix: don't leak temporary GVs and CVs in prototype checkers version 0.002; 2011-05-19 * add callchecker_linkable constant to help users link with this module * fully document the C functions * avoid false test failures with parallel testing * correct abstract line * add Devel::CallParser to "see also" list version 0.001; 2011-04-11 * bugfix: use PERL_CALLCONV to achieve consistent ABI across compilers * port to Windows (GCC toolchain) and Cygwin, where additional linker magic is required to make importation from shared object work (MSVC and BCC on Windows presumably still don't generate the linkable version of the shared library) version 0.000; 2011-04-03 * initial released version Devel-CallChecker-0.007/SIGNATURE000644001750001750 374612503257324 16310 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 28471ed9c62bbfb12a2afac9911c6dd919b7f9f5 .gitignore SHA1 b858dab2430fd53a60a5895b4374c673f1dcb095 Build.PL SHA1 f74968a5d0f477df6f1acebfd89713f070bece09 Changes SHA1 74e8d30b29251efd2bf67be0d974b42a98d0f7bc MANIFEST SHA1 60cf6988f144940db77ff994bc9840bafe587ad7 META.json SHA1 bec5ea233d3a7cb1d58a88f5823ff6b2be2ebd6c META.yml SHA1 01014dbee096cf5abd3f05069cefa9c907a4aea1 Makefile.PL SHA1 60b559265b5003a0fa3954e4a09c986b10c2e4fb README SHA1 4ae36c4da847924c90a9a7df7d7a854be675f237 lib/Devel/CallChecker.pm SHA1 5f4d18b80839f76105e70d2c6028e8a439835e7c lib/Devel/CallChecker.xs SHA1 f02cae7124e7060dbd03f4b62113532e08b289d9 t/LoadXS.pm SHA1 3652419516be8528af3d5e7cb45d06f7ccbb7237 t/WriteHeader.pm SHA1 100b0d3535a699b416b323ed33ced33153d031a9 t/callck.t SHA1 adbce051c92b1e16bd5d607c902b7c0865aef63c t/callck.xs SHA1 904d9a4f76525e2303e4b0c168c68230f223c8de t/pod_cvg.t SHA1 65c75abdef6f01a5d1588a307f2ddfe2333dc961 t/pod_syn.t SHA1 fe2dc3514b3f7c123f075779da779e7e869fb00c t/rv2cvopcv.t SHA1 c8ddecbc62112ef846d14ebdaf91b50156d80ed5 t/rv2cvopcv.xs SHA1 3bab8adfd90d8e7629ec9e86d3a53dd0b5fad227 t/threads.t SHA1 1ad7681a845fdecc219ce5b0ced752ec084beb1d t/threads1.xs SHA1 30e0563165e2583c63ec573887503a8ce8e5a643 t/threads2.xs SHA1 80af1f40b1054da5c48fe7b3d22f1796cd24d3d8 typemap -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.12 (GNU/Linux) iEYEARECAAYFAlUNXs4ACgkQOV9mt2VyAVHtjgCeOi26ybrtTJtnmVGqJ/dC7uNK F2oAnAzr1sJ7Jso5XwnrCYttuPO7M1Pa =cN+Q -----END PGP SIGNATURE----- Devel-CallChecker-0.007/typemap000444001750001750 51412503257316 16373 0ustar00zeframzefram000000000000TYPEMAP CV * T_CVREF INPUT # The Perl core already has a typemap entry for CV*, but empirically the # one in 5.6 is broken. This is essentially a copy of the one in 5.8, # which also works for 5.6. T_CVREF if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV) $var = (CV*)SvRV($arg); else croak(\"$var is not a code reference\") Devel-CallChecker-0.007/lib000755001750001750 012503257316 15422 5ustar00zeframzefram000000000000Devel-CallChecker-0.007/lib/Devel000755001750001750 012503257316 16461 5ustar00zeframzefram000000000000Devel-CallChecker-0.007/lib/Devel/CallChecker.pm000444001750001750 2543012503257316 21340 0ustar00zeframzefram000000000000=head1 NAME Devel::CallChecker - custom op checking attached to subroutines =head1 SYNOPSIS # to generate header prior to XS compilation perl -MDevel::CallChecker=callchecker0_h \ -e 'print callchecker0_h' > callchecker0.h # in Perl part of module use Devel::CallChecker; /* in XS */ #include "callchecker0.h" cv_get_call_checker(cv, &ckfun, &ckobj); static OP *my_ckfun(pTHX_ OP *o, GV *namegv, SV *ckobj); cv_set_call_checker(cv, my_ckfun, ckobj); =head1 DESCRIPTION This module makes some new features of the Perl 5.14.0 C API available to XS modules running on older versions of Perl. The features are 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 being mutated at compile time by arbitrary C code. This module makes C and several supporting functions available. (It is possible to achieve the effect of C from XS code on much earlier Perl versions, but it is painful to achieve without the centralised facility.) This module provides the implementation of the functions at runtime (on Perls where they are not provided by the core). It also, at compile time, supplies the C header file and link library which provide access to the functions. In normal use, 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::CallChecker; { use 5.006; } use warnings; use strict; our $VERSION = "0.007"; use parent "Exporter"; our @EXPORT_OK = qw(callchecker0_h callchecker_linkable); { require DynaLoader; local our @ISA = qw(DynaLoader); local *dl_load_flags = sub { 1 }; __PACKAGE__->bootstrap($VERSION); } =head1 CONSTANTS =over =item callchecker0_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 Perl API functions C, C, C, C, C, and C, as defined below and in the Perl 5.14.0 API, being available to the XS code. =item callchecker_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 callchecker_linkable() { require DynaLoader::Functions; DynaLoader::Functions->VERSION(0.001); return DynaLoader::Functions::linkable_for_module(__PACKAGE__); } =back =head1 C FUNCTIONS =over =item rv2cv_op_cv Examines an op, which is expected to identify a subroutine at runtime, and attempts to determine at compile time which subroutine it identifies. This is normally used during Perl compilation to determine whether a prototype can be applied to a function call. I is the op being considered, normally an C op. A pointer to the identified subroutine is returned, if it could be determined statically, and a null pointer is returned if it was not possible to determine statically. Whether the subroutine is statically identifiable is determined in accordance with the prevailing standards of the Perl version being used. The same criteria are used that the core uses to determine whether to apply a prototype to a subroutine call. From version 5.11.2 onwards, the subroutine can be determined if the RV that the C is to operate on is provided by a suitable C or C op. Prior to 5.11.2, only a C op will do. A C op is suitable if the GV's CV slot is populated. A C op is suitable if the constant value must be an RV pointing to a CV. Details of this process may change in future versions of Perl. If the C op has the C flag set then no attempt is made to identify the subroutine statically: this flag is used to suppress compile-time magic on a subroutine call, forcing it to use default runtime behaviour. If I has the bit C set, then the handling of a GV reference is modified. If a GV was examined and its CV slot was found to be empty, then the C op has the C flag set. If the op is not optimised away, and the CV slot is later populated with a subroutine having a prototype, that flag eventually triggers the warning "called too early to check prototype". If I has the bit C set, then instead of returning a pointer to the subroutine it returns a pointer to the GV giving the most appropriate name for the subroutine in this context. Normally this is just the C of the subroutine, but for an anonymous (C) subroutine that is referenced through a GV it will be the referencing GV. The resulting C is cast to C to be returned. A null pointer is returned as usual if there is no statically-determinable subroutine. CV *rv2cv_op_cv(OP *cvop, U32 flags) =item cv_get_call_checker Retrieves the function that will be used to fix up a call to I. Specifically, the function is applied to an C op tree 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<*ckfun_p>, and an SV argument for it is returned in I<*ckobj_p>. The function is intended to be called in this manner: entersubop = (*ckfun_p)(aTHX_ entersubop, namegv, (*ckobj_p)); In this call, I is a pointer to the C op, which may be replaced by the check function, and I is a GV supplying the name that should be used by the check function to refer to the callee of the C op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. By default, the function is L, and the SV parameter is I itself. This implements standard prototype processing. It can be changed, for a particular subroutine, by L. void cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) =item cv_set_call_checker Sets the function that will be used to fix up a call to I. Specifically, the function is applied to an C op tree 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: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); In this call, I is a pointer to the C op, which may be replaced by the check function, and I is a GV supplying the name that should be used by the check function to refer to the callee of the C op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. The current setting for a particular CV can be retrieved by L. void cv_set_call_checker(CV *cv, Perl_call_checker ckfun, SV *ckobj) =item ck_entersub_args_list Performs the default fixup of the arguments part of an C op tree. This consists of applying list context to each of the argument ops. This is the standard treatment used on a call marked with C<&>, or a method call, or a call through a subroutine reference, or any other call where the callee can't be identified at compile time, or a call where the callee has no prototype. OP *ck_entersub_args_list(OP *entersubop) =item ck_entersub_args_proto Performs the fixup of the arguments part of an C op tree based on a subroutine prototype. This makes various modifications to the argument ops, from applying context up to inserting C ops, and checking the number and syntactic types of arguments, as directed by 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 prototype supplied, in whichever form, does not need to match the actual callee referenced by the op tree. If the argument ops disagree with the prototype, for example by having an unacceptable number of arguments, a valid op tree is returned anyway. The error is reflected in the parser state, normally resulting in a single exception at the top level of parsing which covers all the compilation errors that occurred. In the error message, the callee is referred to by the name defined by the I parameter. OP *ck_entersub_args_proto(OP *entersubop, GV *namegv, SV *protosv) =item ck_entersub_args_proto_or_list Performs the fixup of the arguments part of an C op tree either based on a subroutine prototype or using default list-context processing. 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 prototype (or lack thereof) supplied, in whichever form, does not need to match the actual callee referenced by the op tree. If the argument ops disagree with the prototype, for example by having an unacceptable number of arguments, a valid op tree is returned anyway. The error is reflected in the parser state, normally resulting in a single exception at the top level of parsing which covers all the compilation errors that occurred. In the error message, the callee is referred to by the name defined by the I parameter. OP *ck_entersub_args_proto_or_list(OP *entersubop, GV *namegv, SV *protosv) =back =head1 SEE ALSO L, L, L =head1 AUTHOR Andrew Main (Zefram) =head1 COPYRIGHT Copyright (C) 2011, 2012, 2013, 2015 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-CallChecker-0.007/lib/Devel/CallChecker.xs000444001750001750 3310412503257316 21353 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #define PERL_DECIMAL_VERSION \ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define PERL_VERSION_GE(r,v,s) \ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #ifndef newSVpvs # define newSVpvs(s) newSVpvn(""s"", (sizeof(""s"")-1)) #endif /* !newSVpvs */ #define QPFX xAd8NP3gxZglovQRL5Hn_ #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 #ifndef rv2cv_op_cv # define RV2CVOPCV_MARK_EARLY 0x00000001 # define RV2CVOPCV_RETURN_NAME_GV 0x00000002 # define Perl_rv2cv_op_cv QPFXD(roc0) # define rv2cv_op_cv(cvop, flags) Perl_rv2cv_op_cv(aTHX_ cvop, flags) MY_EXPORT_CALLCONV CV *QPFXD(roc0)(pTHX_ OP *cvop, U32 flags) { OP *rvop; CV *cv; GV *gv; if(!(cvop->op_type == OP_RV2CV && !(cvop->op_private & OPpENTERSUB_AMPER) && (cvop->op_flags & OPf_KIDS))) return NULL; rvop = cUNOPx(cvop)->op_first; switch(rvop->op_type) { case OP_GV: { gv = cGVOPx_gv(rvop); cv = GvCVu(gv); if(!cv) { if(flags & RV2CVOPCV_MARK_EARLY) rvop->op_private |= OPpEARLY_CV; return NULL; } } break; #if PERL_VERSION_GE(5,11,2) case OP_CONST: { SV *rv = cSVOPx_sv(rvop); if(!SvROK(rv)) return NULL; cv = (CV*)SvRV(rv); gv = NULL; } break; #endif /* >=5.11.2 */ default: { return NULL; } break; } if(SvTYPE((SV*)cv) != SVt_PVCV) return NULL; if(flags & RV2CVOPCV_RETURN_NAME_GV) { if(!CvANON(cv) || !gv) gv = CvGV(cv); return (CV*)gv; } else { return cv; } } # define Q_PROVIDE_RV2CV_OP_CV 1 #endif /* !rv2cv_op_cv */ #ifndef ck_entersub_args_proto_or_list # ifndef newSV_type # define newSV_type(type) THX_newSV_type(aTHX_ type) static SV *THX_newSV_type(pTHX_ svtype type) { SV *sv = newSV(0); (void) SvUPGRADE(sv, type); return sv; } # endif /* !newSV_type */ # ifndef GvCV_set # define GvCV_set(gv, cv) (GvCV(gv) = (cv)) # endif /* !GvCV_set */ # ifndef CvGV_set # define CvGV_set(cv, gv) (CvGV(cv) = (gv)) # endif /* !CvGV_set */ # define entersub_extract_args(eo) THX_entersub_extract_args(aTHX_ eo) static OP *THX_entersub_extract_args(pTHX_ OP *entersubop) { OP *pushop, *aop, *bop, *cop; if(!(entersubop->op_flags & OPf_KIDS)) return NULL; pushop = cUNOPx(entersubop)->op_first; if(!pushop->op_sibling) { if(!(pushop->op_flags & OPf_KIDS)) return NULL; pushop = cUNOPx(pushop)->op_first; if(!pushop->op_sibling) return NULL; } for(bop = pushop; (cop = bop->op_sibling)->op_sibling; bop = cop) ; if(bop == pushop) return NULL; aop = pushop->op_sibling; pushop->op_sibling = cop; bop->op_sibling = NULL; return aop; } # define entersub_inject_args(eo, ao) THX_entersub_inject_args(aTHX_ eo, ao) static void THX_entersub_inject_args(pTHX_ OP *entersubop, OP *aop) { OP *pushop, *bop, *cop; if(!aop) return; if(!(entersubop->op_flags & OPf_KIDS)) { abort: while(aop) { bop = aop->op_sibling; op_free(aop); aop = bop; } return; } pushop = cUNOPx(entersubop)->op_first; if(!pushop->op_sibling) { if(!(pushop->op_flags & OPf_KIDS)) goto abort; pushop = cUNOPx(pushop)->op_first; if(!pushop->op_sibling) goto abort; } for(bop = aop; (cop = bop->op_sibling); bop = cop) ; bop->op_sibling = pushop->op_sibling; pushop->op_sibling = aop; } # define ck_entersub_args_stalk(eo, so) THX_ck_entersub_args_stalk(aTHX_ eo, so) static OP *THX_ck_entersub_args_stalk(pTHX_ OP *entersubop, OP *stalkcvop) { OP *stalkenterop = newLISTOP(OP_LIST, 0, newCVREF(0, stalkcvop), NULL); entersub_inject_args(stalkenterop, entersub_extract_args(entersubop)); stalkenterop = newUNOP(OP_ENTERSUB, OPf_STACKED, stalkenterop); entersub_inject_args(entersubop, entersub_extract_args(stalkenterop)); op_free(stalkenterop); return entersubop; } # define Perl_ck_entersub_args_list QPFXD(eal0) # define ck_entersub_args_list(o) Perl_ck_entersub_args_list(aTHX_ o) MY_EXPORT_CALLCONV OP *QPFXD(eal0)(pTHX_ OP *entersubop) { return ck_entersub_args_stalk(entersubop, newOP(OP_PADANY, 0)); } # define Perl_ck_entersub_args_proto QPFXD(eap0) # define ck_entersub_args_proto(o, gv, sv) \ Perl_ck_entersub_args_proto(aTHX_ o, gv, sv) MY_EXPORT_CALLCONV OP *QPFXD(eap0)(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { const char *proto; STRLEN proto_len; CV *stalkcv; GV *stalkgv; if(SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv)) croak("panic: ck_entersub_args_proto CV with no proto"); proto = SvPV(protosv, proto_len); stalkcv = (CV*)newSV_type(SVt_PVCV); sv_setpvn((SV*)stalkcv, proto, proto_len); stalkgv = (GV*)sv_2mortal(newSV(0)); gv_init(stalkgv, GvSTASH(namegv), GvNAME(namegv), GvNAMELEN(namegv), 0); GvCV_set(stalkgv, stalkcv); CvGV_set(stalkcv, stalkgv); return ck_entersub_args_stalk(entersubop, newGVOP(OP_GV, 0, stalkgv)); } # define Perl_ck_entersub_args_proto_or_list QPFXD(ean0) # define ck_entersub_args_proto_or_list(o, gv, sv) \ Perl_ck_entersub_args_proto_or_list(aTHX_ o, gv, sv) MY_EXPORT_CALLCONV OP *QPFXD(ean0)(pTHX_ OP *entersubop, GV *namegv, SV *protosv) { if(SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv)) return ck_entersub_args_proto(entersubop, namegv, protosv); else return ck_entersub_args_list(entersubop); } # define Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST 1 #endif /* !ck_entersub_args_proto_or_list */ #ifndef cv_set_call_checker # ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) # endif /* !Newxz */ # ifndef SvMAGIC_set # define SvMAGIC_set(sv, mg) (SvMAGIC(sv) = (mg)) # endif /* !SvMAGIC_set */ # ifndef DPTR2FPTR # define DPTR2FPTR(t,x) ((t)(UV)(x)) # endif /* !DPTR2FPTR */ # ifndef FPTR2DPTR # define FPTR2DPTR(t,x) ((t)(UV)(x)) # endif /* !FPTR2DPTR */ # ifndef op_null # define op_null(o) THX_op_null(aTHX_ o) static void THX_op_null(pTHX_ OP *o) { if(o->op_type == OP_NULL) return; /* must not be used on any op requiring non-trivial clearing */ o->op_targ = o->op_type; o->op_type = OP_NULL; o->op_ppaddr = PL_ppaddr[OP_NULL]; } # endif /* !op_null */ # 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) # ifdef PERL_MAGIC_regex_global || type == PERL_MAGIC_regex_global # endif /* 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 */ # ifndef sv_magicext # define sv_magicext(sv, obj, type, vtbl, name, namlen) \ THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen) static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type, MGVTBL const *vtbl, char const *name, I32 namlen) { MAGIC *mg; if(!(obj == &PL_sv_undef && !name && !namlen)) /* exceeded intended usage of this reserve implementation */ return NULL; Newxz(mg, 1, MAGIC); mg->mg_virtual = (MGVTBL*)vtbl; mg->mg_type = type; mg->mg_obj = &PL_sv_undef; (void) SvUPGRADE(sv, SVt_PVMG); mg->mg_moremagic = SvMAGIC(sv); SvMAGIC_set(sv, mg); SvMAGICAL_off(sv); mg_magical(sv); return mg; } # endif /* !sv_magicext */ # ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' # endif /* !PERL_MAGIC_ext */ # if !PERL_VERSION_GE(5,9,3) typedef OP *(*Perl_check_t)(pTHX_ OP *); # endif /* <5.9.3 */ # if !PERL_VERSION_GE(5,10,1) typedef unsigned Optype; # endif /* <5.10.1 */ # ifndef wrap_op_checker # define wrap_op_checker(c,n,o) THX_wrap_op_checker(aTHX_ c,n,o) static void THX_wrap_op_checker(pTHX_ Optype opcode, Perl_check_t new_checker, Perl_check_t *old_checker_p) { if(*old_checker_p) return; OP_REFCNT_LOCK; if(!*old_checker_p) { *old_checker_p = PL_check[opcode]; PL_check[opcode] = new_checker; } OP_REFCNT_UNLOCK; } # endif /* !wrap_op_checker */ static MGVTBL mgvtbl_checkcall; typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *); # define Perl_cv_get_call_checker QPFXD(gcc0) # define cv_get_call_checker(cv, ckfun_p, ckobj_p) \ Perl_cv_get_call_checker(aTHX_ cv, ckfun_p, ckobj_p) MY_EXPORT_CALLCONV void QPFXD(gcc0)(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) { MAGIC *callmg = SvMAGICAL((SV*)cv) ? mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_checkcall) : NULL; if(callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; } } # define Perl_cv_set_call_checker QPFXD(scc0) # define cv_set_call_checker(cv, ckfun, ckobj) \ Perl_cv_set_call_checker(aTHX_ cv, ckfun, ckobj) MY_EXPORT_CALLCONV void QPFXD(scc0)(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { if(ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if(SvMAGICAL((SV*)cv)) sv_unmagicext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_checkcall); } else { MAGIC *callmg = mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_checkcall); if(!callmg) callmg = sv_magicext((SV*)cv, &PL_sv_undef, PERL_MAGIC_ext, &mgvtbl_checkcall, NULL, 0); if(callmg->mg_flags & MGf_REFCOUNTED) { SvREFCNT_dec(callmg->mg_obj); callmg->mg_flags &= ~MGf_REFCOUNTED; } callmg->mg_ptr = FPTR2DPTR(char *, ckfun); callmg->mg_obj = ckobj; if(ckobj != (SV*)cv) { SvREFCNT_inc(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } } } static OP *(*nxck_entersub)(pTHX_ OP *); static OP *myck_entersub(pTHX_ OP *entersubop) { OP *aop, *cvop; CV *cv; GV *namegv; Perl_call_checker ckfun; SV *ckobj; aop = cUNOPx(entersubop)->op_first; if(!aop->op_sibling) aop = cUNOPx(aop)->op_first; aop = aop->op_sibling; for(cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; if(!(cv = rv2cv_op_cv(cvop, 0))) return nxck_entersub(aTHX_ entersubop); cv_get_call_checker(cv, &ckfun, &ckobj); if(ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) return nxck_entersub(aTHX_ entersubop); namegv = (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV); entersubop->op_private |= OPpENTERSUB_HASTARG; entersubop->op_private |= (PL_hints & HINT_STRICT_REFS); if(PERLDB_SUB && PL_curstash != PL_debstash) entersubop->op_private |= OPpENTERSUB_DB; op_null(cvop); return ckfun(aTHX_ entersubop, namegv, ckobj); } # define Q_PROVIDE_CV_SET_CALL_CHECKER 1 #endif /* !cv_set_call_checker */ MODULE = Devel::CallChecker PACKAGE = Devel::CallChecker PROTOTYPES: DISABLE BOOT: #if Q_PROVIDE_CV_SET_CALL_CHECKER wrap_op_checker(OP_ENTERSUB, myck_entersub, &nxck_entersub); #endif /* Q_PROVIDE_CV_SET_CALL_CHECKER */ SV * callchecker0_h() CODE: RETVAL = newSVpvs( "/* DO NOT EDIT -- generated " "by Devel::CallChecker version "XS_VERSION" */\n" "#ifndef "QPFXS"INCLUDED\n" "#define "QPFXS"INCLUDED 1\n" "#ifndef PERL_VERSION\n" " #error you must include perl.h before callchecker0.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 callchecker0.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" #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" #if Q_PROVIDE_RV2CV_OP_CV "#define RV2CVOPCV_MARK_EARLY 0x00000001\n" "#define RV2CVOPCV_RETURN_NAME_GV 0x00000002\n" DEFFN("CV *", "rv2cv_op_cv", "roc0", "OP *, U32", "cvop, flags") #endif /* Q_PROVIDE_RV2CV_OP_CV */ #if Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST DEFFN("OP *", "ck_entersub_args_list", "eal0", "OP *", "o") DEFFN("OP *", "ck_entersub_args_proto", "eap0", "OP *, GV *, SV *", "o, gv, sv") DEFFN("OP *", "ck_entersub_args_proto_or_list", "ean0", "OP *, GV *, SV *", "o, gv, sv") #endif /* Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST */ #if Q_PROVIDE_CV_SET_CALL_CHECKER "typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);\n" DEFFN("void", "cv_get_call_checker", "gcc0", "CV *, Perl_call_checker *, SV **", "cv, fp, op") DEFFN("void", "cv_set_call_checker", "scc0", "CV *, Perl_call_checker, SV *", "cv, f, o") #endif /* Q_PROVIDE_CV_SET_CALL_CHECKER */ "#endif /* !"QPFXS"INCLUDED */\n" ); OUTPUT: RETVAL Devel-CallChecker-0.007/t000755001750001750 012503257316 15117 5ustar00zeframzefram000000000000Devel-CallChecker-0.007/t/pod_syn.t000444001750001750 23612503257316 17075 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-CallChecker-0.007/t/rv2cvopcv.t000444001750001750 51712503257316 17356 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 4; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callchecker0", "t", "rv2cvopcv"); ok 1; require_ok "Devel::CallChecker"; t::LoadXS::load_xs("rv2cvopcv", "t", [Devel::CallChecker::callchecker_linkable()]); ok 1; t::rv2cvopcv::test_rv2cv_op_cv(); ok 1; 1; Devel-CallChecker-0.007/t/rv2cvopcv.xs000444001750001750 642712503257316 17573 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "rv2cvopcv_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)) MODULE = t::rv2cvopcv PACKAGE = t::rv2cvopcv PROTOTYPES: DISABLE void test_rv2cv_op_cv() PROTOTYPE: PREINIT: GV *troc_gv; CV *troc_cv; OP *o; CODE: #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__) troc_gv = gv_fetchpv("t::rv2cvopcv::test_rv2cv_op_cv", 0, SVt_PVGV); troc_cv = get_cv("t::rv2cvopcv::test_rv2cv_op_cv", 0); (void) gv_fetchpv("t::rv2cvopcv::wibble", 0, SVt_PVGV); o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv)); if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv) croak_fail(); o->op_private |= OPpENTERSUB_AMPER; if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); o->op_private &= ~OPpENTERSUB_AMPER; if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail(); if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); op_free(o); o = newSVOP(OP_CONST, 0, newSVpv("t::rv2cvopcv::test_rv2cv_op_cv", 0)); o->op_private = OPpCONST_BARE; o = newCVREF(0, o); if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv) croak_fail(); o->op_private |= OPpENTERSUB_AMPER; if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); op_free(o); o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv))); #if PERL_VERSION_GE(5,11,2) if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv) croak_fail(); #else /* <5.11.2 */ if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); #endif /* <5.11.2 */ o->op_private |= OPpENTERSUB_AMPER; if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); o->op_private &= ~OPpENTERSUB_AMPER; if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); #if PERL_VERSION_GE(5,11,2) if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail(); #else /* <5.11.2 */ if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail(); #endif /* <5.11.2 */ if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); op_free(o); o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)))); if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); o->op_private |= OPpENTERSUB_AMPER; if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); o->op_private &= ~OPpENTERSUB_AMPER; if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail(); if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail(); op_free(o); o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))); if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); op_free(o); #undef croak_fail Devel-CallChecker-0.007/t/LoadXS.pm000444001750001750 225412503257316 16747 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-CallChecker-0.007/t/threads1.xs000444001750001750 55112503257316 17324 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "threads1_callchecker0.h" #include "XSUB.h" MODULE = t::threads1 PACKAGE = t::threads1 PROTOTYPES: DISABLE void cv_set_call_checker_proto(CV *cv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto); Devel-CallChecker-0.007/t/threads.t000444001750001750 423012503257316 17072 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { eval { require threads; }; if($@ =~ /\AThis Perl not built to support threads/) { require Test::More; Test::More::plan(skip_all => "non-threading perl build"); } if($@ ne "") { require Test::More; Test::More::plan(skip_all => "threads unavailable"); } eval { require Thread::Semaphore; }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "Thread::Semaphore unavailable"); } eval { require threads::shared; }; if($@ ne "") { require Test::More; Test::More::plan(skip_all => "threads::shared unavailable"); } } use threads; use Test::More tests => 3; use Thread::Semaphore (); use threads::shared; alarm 10; # failure mode may involve an infinite loop sub tsub1 (@) { $_[0] } sub tsub2 (@) { $_[0] } sub nsub (@) { $_[0] } our @three = (3); my $done1 = Thread::Semaphore->new(0); my $exit1 = Thread::Semaphore->new(0); my $done2 = Thread::Semaphore->new(0); my $exit2 = Thread::Semaphore->new(0); my $ok1 :shared; my $thread1 = threads->create(sub { my $ok = 1; require Devel::CallChecker; require t::LoadXS; require t::WriteHeader; t::WriteHeader::write_header("callchecker0", "t", "threads1"); t::LoadXS::load_xs("threads1", "t", [Devel::CallChecker::callchecker_linkable()]); eval(q{nsub(@three)}) == 3 or $ok = 0; eval(q{tsub1(@three)}) == 3 or $ok = 0; t::threads1::cv_set_call_checker_proto(\&tsub1, "\$"); eval(q{nsub(@three)}) == 3 or $ok = 0; eval(q{tsub1(@three)}) == 1 or $ok = 0; $ok1 = $ok; $done1->up; $exit1->down; }); $done1->down; ok $ok1; my $ok2 :shared; my $thread2 = threads->create(sub { my $ok = 1; require Devel::CallChecker; require t::LoadXS; require t::WriteHeader; t::WriteHeader::write_header("callchecker0", "t", "threads2"); t::LoadXS::load_xs("threads2", "t", [Devel::CallChecker::callchecker_linkable()]); eval(q{nsub(@three)}) == 3 or $ok = 0; eval(q{tsub2(@three)}) == 3 or $ok = 0; t::threads2::cv_set_call_checker_proto(\&tsub2, "\$"); eval(q{nsub(@three)}) == 3 or $ok = 0; eval(q{tsub2(@three)}) == 1 or $ok = 0; $ok2 = $ok; $done2->up; $exit2->down; }); $done2->down; ok $ok2; $exit1->up; $exit2->up; $thread1->join; $thread2->join; ok 1; 1; Devel-CallChecker-0.007/t/pod_cvg.t000444001750001750 27312503257316 17044 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-CallChecker-0.007/t/callck.t000444001750001750 1036512503257316 16717 0ustar00zeframzefram000000000000use warnings; use strict; use Test::More tests => 79; use t::LoadXS (); use t::WriteHeader (); t::WriteHeader::write_header("callchecker0", "t", "callck"); ok 1; require_ok "Devel::CallChecker"; t::LoadXS::load_xs("callck", "t", [Devel::CallChecker::callchecker_linkable()]); ok 1; t::callck::test_cv_getset_call_checker(); ok 1; my @z = (); my @a = qw(a); my @b = qw(a b); my @c = qw(a b c); my($foo_got, $foo_ret); sub foo($@) { $foo_got = [ @_ ]; return "z"; } sub bar (\@$) { } sub baz { } $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ 2, qw(a b c) ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = &foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ qw(a b), qw(a b c) ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_lists(\&foo); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ qw(a b), qw(a b c) ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = &foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ qw(a b), qw(a b c) ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_scalars(\&foo); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ 2, 3 ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = foo(@b, @c, @a, @c);}; is $@, ""; is_deeply $foo_got, [ 2, 3, 1, 3 ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = foo(@b);}; is $@, ""; is_deeply $foo_got, [ 2 ]; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = foo();}; is $@, ""; is_deeply $foo_got, []; is $foo_ret, "z"; $foo_got = undef; eval q{$foo_ret = &foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ qw(a b), qw(a b c) ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto(\&foo, "\\\@\$"); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ \@b, 3 ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto(\&foo, undef); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; like $@, qr/ with no proto[ ,]/; is_deeply $foo_got, undef; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto(\&foo, \&bar); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ \@b, 3 ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto(\&foo, \&baz); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; like $@, qr/ with no proto[ ,]/; is_deeply $foo_got, undef; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto(\&foo, "\$"); $foo_got = undef; eval q{$foo_ret = foo();}; like $@, qr/\ANot enough arguments for main::foo /; is_deeply $foo_got, undef; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto(\&foo, "\$"); $foo_got = undef; eval q{$foo_ret = foo(1,2);}; like $@, qr/\AToo many arguments for main::foo /; is_deeply $foo_got, undef; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto_or_list(\&foo, "\\\@\$"); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ \@b, 3 ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto_or_list(\&foo, undef); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ qw(a b), qw(a b c) ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto_or_list(\&foo, \&bar); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ \@b, 3 ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto_or_list(\&foo, \&baz); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, [ qw(a b), qw(a b c) ]; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto_or_list(\&foo, "\$"); $foo_got = undef; eval q{$foo_ret = foo();}; like $@, qr/\ANot enough arguments for main::foo /; is_deeply $foo_got, undef; is $foo_ret, "z"; t::callck::cv_set_call_checker_proto_or_list(\&foo, "\$"); $foo_got = undef; eval q{$foo_ret = foo(1,2);}; like $@, qr/\AToo many arguments for main::foo /; is_deeply $foo_got, undef; is $foo_ret, "z"; t::callck::cv_set_call_checker_multi_sum(\&foo); $foo_got = undef; eval q{$foo_ret = foo(@b, @c);}; is $@, ""; is_deeply $foo_got, undef; is $foo_ret, 5; $foo_got = undef; eval q{$foo_ret = foo(@b);}; is $@, ""; is_deeply $foo_got, undef; is $foo_ret, 2; $foo_got = undef; eval q{$foo_ret = foo();}; is $@, ""; is_deeply $foo_got, undef; is $foo_ret, 0; $foo_got = undef; eval q{$foo_ret = foo(@b, @c, @a, @c);}; is $@, ""; is_deeply $foo_got, undef; is $foo_ret, 9; 1; Devel-CallChecker-0.007/t/callck.xs000444001750001750 1500112503257316 17076 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "callck_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 PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif /* !PERL_UNUSED_VAR */ #ifndef PERL_UNUSED_ARG # define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x) #endif /* !PERL_UNUSED_ARG */ #ifndef FPTR2DPTR # define FPTR2DPTR(t,x) ((t)(UV)(x)) #endif /* !FPTR2DPTR */ #ifndef OpSIBLING # ifdef PERL_OP_PARENT # define OpHAS_SIBLING(o) (!(o)->op_lastsib) # define OpSIBLING(o) ((o)->op_lastsib ? (OP*)NULL : 0 + (o)->op_sibling) # define OpSIBLING_set(o, sib) ((o)->op_sibling = (sib)) # else /* !PERL_OP_PARENT */ # define OpHAS_SIBLING(o) (!!(o)->op_sibling) # define OpSIBLING(o) (0 + (o)->op_sibling) # define OpSIBLING_set(o, sib) ((o)->op_sibling = (sib)) # endif /* !PERL_OP_PARENT */ #endif /* !OpSIBLING */ #ifndef OpMORESIB_set # if PERL_VERSION_GE(5,21,2) # define OpMORESIB_set(o, sib) ((o)->op_lastsib = 0, (o)->op_sibling = (sib)) # else /* <5.21.2 */ # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) # endif /* <5.21.2 */ #endif /* !OpMORESIB_set */ #ifndef OpLASTSIB_set # ifdef PERL_OP_PARENT # define OpLASTSIB_set(o, parent) \ ((o)->op_lastsib = 1, (o)->op_sibling = (parent)) # elif PERL_VERSION_GE(5,21,2) # define OpLASTSIB_set(o, parent) ((o)->op_lastsib = 1, (o)->op_sibling = NULL) # else /* <5.21.2 */ # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) # endif /* <5.21.2 */ #endif /* !OpLASTSIB_set */ #ifndef OpMAYBESIB_set # ifdef PERL_OP_PARENT # define OpMAYBESIB_set(o, sib, parent) \ ((o)->op_sibling = ((o)->op_lastsib = !(sib)) ? (parent) : (sib)) # elif PERL_VERSION_GE(5,21,2) # define OpMAYBESIB_set(o, sib, parent) \ ((o)->op_lastsib = !(sib), (o)->op_sibling = (sib)) # else /* <5.21.2 */ # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) # endif /* <5.21.2 */ #endif /* !OpMAYBESIB_set */ #ifndef op_contextualize # define op_contextualize(o, c) THX_op_contextualize(aTHX_ o, c) static OP *THX_op_contextualize(pTHX_ OP *o, I32 c) { if(c == G_SCALAR) { OP *sib, *assop, *nullop; sib = o->op_sibling; o->op_sibling = NULL; assop = newASSIGNOP(0, newOP(OP_NULL, 0), 0, o); o = cBINOPx(assop)->op_first; nullop = newOP(OP_NULL, 0); nullop->op_sibling = o->op_sibling; cBINOPx(assop)->op_first = nullop; if(!nullop->op_sibling) cBINOPx(assop)->op_last = nullop; op_free(assop); o->op_sibling = sib; return o; } else { croak("reserve op_contextualize abused"); } } #endif /* !op_contextualize */ static OP *THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(ckobj); return ck_entersub_args_list(entersubop); } static OP *THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { OP *aop = cUNOPx(entersubop)->op_first; PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(ckobj); if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { op_contextualize(aop, G_SCALAR); } return entersubop; } static OP *THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) { OP *sumop = NULL; OP *pushop = cUNOPx(entersubop)->op_first; PERL_UNUSED_ARG(namegv); PERL_UNUSED_ARG(ckobj); if (!OpHAS_SIBLING(pushop)) pushop = cUNOPx(pushop)->op_first; while (1) { OP *aop = OpSIBLING(pushop); OP *as; if (!OpHAS_SIBLING(aop)) break; as = OpSIBLING(aop); OpMORESIB_set(pushop, as); OpLASTSIB_set(aop, NULL); op_contextualize(aop, G_SCALAR); if (sumop) { sumop = newBINOP(OP_ADD, 0, sumop, aop); } else { sumop = aop; } } if (!sumop) sumop = newSVOP(OP_CONST, 0, newSViv(0)); op_free(entersubop); return sumop; } MODULE = t::callck PACKAGE = t::callck PROTOTYPES: DISABLE void test_cv_getset_call_checker() PROTOTYPE: PREINIT: CV *t0_cv, *t1_cv; Perl_call_checker ckfun; SV *ckobj; 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_cc(cv, xckfun, xckobj) \ do { \ cv_get_call_checker((cv), &ckfun, &ckobj); \ if (ckfun != (xckfun)) \ croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \ if (ckobj != (xckobj)) \ croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \ } while(0) t0_cv = get_cv("t::callck::t0", 0); t1_cv = get_cv("t::callck::t1", 0); check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv); check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv); cv_set_call_checker(t1_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv); check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); cv_set_call_checker(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no); check_cc(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no); check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); cv_set_call_checker(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv); check_cc(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no); check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv); cv_set_call_checker(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv); check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv); check_cc(t1_cv, Perl_ck_entersub_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_cc #undef croak_fail_ne #undef croak_fail void t0() PROTOTYPE: CODE: ; void t1() PROTOTYPE: CODE: ; void cv_set_call_checker_lists(CV *cv) PROTOTYPE: $ CODE: cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef); void cv_set_call_checker_scalars(CV *cv) PROTOTYPE: $ CODE: cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef); void cv_set_call_checker_proto(CV *cv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto); void cv_set_call_checker_proto_or_list(CV *cv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto); void cv_set_call_checker_multi_sum(CV *cv) PROTOTYPE: $ CODE: cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef); Devel-CallChecker-0.007/t/WriteHeader.pm000444001750001750 100512503257316 20011 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::CallChecker; no strict "refs"; my $content = &{"Devel::CallChecker::${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-CallChecker-0.007/t/threads2.xs000444001750001750 55112503257316 17325 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "threads2_callchecker0.h" #include "XSUB.h" MODULE = t::threads2 PACKAGE = t::threads2 PROTOTYPES: DISABLE void cv_set_call_checker_proto(CV *cv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);