Devel-CallChecker-0.009000755001750001750 014415027465 14662 5ustar00zeframzefram000000000000Devel-CallChecker-0.009/.gitignore000444001750001750 70014415027456 16764 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 /t/callck_callchecker0.h /t/callck.c /t/callck.o /t/callck.so /t/rv2cvopcv_callchecker0.h /t/rv2cvopcv.c /t/rv2cvopcv.o /t/rv2cvopcv.so /t/threads1_callchecker0.h /t/threads1.c /t/threads1.o /t/threads1.so /t/threads2_callchecker0.h /t/threads2.c /t/threads2.o /t/threads2.so Devel-CallChecker-0.009/Build.PL000444001750001750 624114415027456 16316 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" }, meta_merge => { "meta-spec" => { version => "2" }, resources => { bugtracker => { mailto => "bug-Devel-CallChecker\@rt.cpan.org", web => "https://rt.cpan.org/Public/Dist/". "Display.html?Name=Devel-CallChecker", }, }, }, sign => 1, )->create_build_script; 1; Devel-CallChecker-0.009/Changes000444001750001750 772714415027456 16327 0ustar00zeframzefram000000000000version 0.009; 2023-04-10 * port to Perl 5.33.1, which defines a PERL_VERSION_GE() macro that clashes with the one this module previously had * skip thread tests on some old versions of Perl (around 5.10.0) where a core bug makes thread creation violate an internal assertion and causes crashes * skip thread tests on pre-5.8.9 Perls where a core bug makes thread creation corrupt memory * skip thread tests on pre-5.8.3 Perls where a core bug makes thread completion break the global PL_sv_placeholder * put whitespace around C string literals being pasted, for C++11 compatibility * avoid using C preprocessor directives inside a macro argument list (which is not valid) * in XS code in the test suite, when croaking, avoid using __FILE__ as part of a format string, in case it includes a metacharacter * document the intended scope of this module's backporting effort * fix a documentation wording glitch * in XS declare as const some data that never changes * refactor thread tests * in XS, refactor Perl version comparisons * in XS, rename some macros for better style * in XS, better argument parenthesisation in some macros * avoid some compiler warnings * in .gitignore, list temporary files produced by test XS compilation version 0.008; 2017-07-26 * update test suite to not rely on . in @INC, which is no longer necessarily there from Perl 5.25.7 * no longer include a Makefile.PL in the distribution * in documentation, use four-column indentation for all verbatim material * in META.{yml,json}, point to public bug tracker * update op-munging code to the PERL_OP_PARENT-compatible style (though none of it is actually used on Perls new enough to support PERL_OP_PARENT) * in tests, revise PERL_OP_PARENT reserve definitions to simpler form, accommodating only Perl 5.21.11 or later * consistently use THX_ prefix on internal function names version 0.007; 2015-03-21 * update tests for PERL_OP_PARENT builds of Perl 5.21.2 or later 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.009/MANIFEST000444001750001750 47714415027456 16140 0ustar00zeframzefram000000000000.gitignore Build.PL Changes MANIFEST META.json META.yml README lib/Devel/CallChecker.pm lib/Devel/CallChecker.xs t/callck.t t/callck.xs t/lib/t/LoadXS.pm t/lib/t/WriteHeader.pm 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.009/META.json000444001750001750 353714415027456 16450 0ustar00zeframzefram000000000000{ "abstract" : "custom op checking attached to subroutines", "author" : [ "Andrew Main (Zefram) " ], "dynamic_config" : 0, "generated_by" : "Module::Build version 0.4232", "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.009" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Devel-CallChecker@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-CallChecker" }, "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.009", "x_serialization_backend" : "JSON::PP version 2.93" } Devel-CallChecker-0.009/META.yml000444001750001750 213614415027456 16272 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.4232, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Devel-CallChecker provides: Devel::CallChecker: file: lib/Devel/CallChecker.pm version: '0.009' requires: DynaLoader: '0' DynaLoader::Functions: '0.001' Exporter: '0' parent: '0' perl: '5.006' strict: '0' warnings: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-CallChecker license: http://dev.perl.org/licenses/ version: '0.009' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Devel-CallChecker-0.009/README000444001750001750 425614415027456 15706 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). It also, at compile time, supplies the C header file and link library which provide access to the functions. In normal use, callchecker0_h and callchecker_linkable should be called at build time (not authoring time) for the module that wishes to use the C functions. The purpose of this module is specifically to provide the Perl 5.14.0 version of the "cv_set_call_checker" API to earlier Perl versions where the core doesn't have "cv_set_call_checker" at all. This module does not attempt to backport later refinements of the "cv_set_call_checker" API. Thus an XS module that uses this module can be sure of having at least the Perl 5.14.0 version of "cv_set_call_checker" available, regardless of which Perl version it is running on, but cannot be sure of having any more refined version of the API available. Such a module will have access to the core's version of the API as normal on Perl versions where the core supplies it, and is free to use the ordinary mechanisms of Perl version portability to manage the differences between versions of the API. INSTALLATION perl Build.PL ./Build ./Build test ./Build install AUTHOR Andrew Main (Zefram) COPYRIGHT Copyright (C) 2011, 2012, 2013, 2015, 2017, 2023 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.009/SIGNATURE000644001750001750 467414415027465 16320 0ustar00zeframzefram000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.88. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: RIPEMD160 SHA256 93b7de35e3b9e01825354d186737790db4426434b89d67b9b5d4bc416cebf13c .gitignore SHA256 793a6920cfd3a554077dbe33d6e19f75e7eb02c1664f2533cd745fb500c757e0 Build.PL SHA256 7653e00a89460baa8b794c18786f472efb658d3836e7e403dd457512b14361ed Changes SHA256 7c3461cd24be7bf774a9b8f41b35ef4d4cfdf36b9c81b948ec59c7696be2b294 MANIFEST SHA256 e92aeb67143f8f19b996339fbd564880b8fd3005904aee2e674aaccf325d6201 META.json SHA256 34731ba8d0a5e567300b06a11464c228d9ee85f2d3e00e3e3c6e0cea0cdced27 META.yml SHA256 17fb06e3c2d6f62dbfada360f19834cb31453a3fdda5a566955b0882597b5cb0 README SHA256 2a36b7fb95c5e7386d2af3957071305eca00655fd7300629f04f0cba53314afb lib/Devel/CallChecker.pm SHA256 53a0f1f0e3b5c9cdacf3f9285da63c7731a269d0cdca768ee5290995a3c0259a lib/Devel/CallChecker.xs SHA256 b164d049c4c4f717270c59c5b46645990acde922e995b5f575d10831b9cc738f t/callck.t SHA256 cc4d18d8c070d7545aa078792fab45bd43dfd32ec74ffe11c9f16ae5229dce64 t/callck.xs SHA256 47a6b7a7b9201a6d33a8d11310b80ac13e9be60c5e809899e7232b7e05217860 t/lib/t/LoadXS.pm SHA256 459c6f1151a22bfcbc921c248196995028e4a4282884c19471edbe6d80c26397 t/lib/t/WriteHeader.pm SHA256 3679257bdfb4a07658e98a41325f82c1744f7dae6d1d0151f1b216af0c1df5c9 t/pod_cvg.t SHA256 e16860066c4ca9b2ee9e7d4604297def8a58b53bf0ca03eed863b5d9c5a2ac91 t/pod_syn.t SHA256 7df417659f64a5286437d0968a0a51f95fefe38fbeb857eed0a7dd6db7dd6137 t/rv2cvopcv.t SHA256 a188c6122309825246990a856dee98478d640270338675c2b0d0aadef137a55b t/rv2cvopcv.xs SHA256 e677e276eb8d17ebb5d4aff66808e38fcaeaeff23c369a7404d624684e98d3d5 t/threads.t SHA256 1ae17126136a115d97b7587de72588b998bde50b1632ffb949e02e574217e115 t/threads1.xs SHA256 59f9347a5cb3e9ab86a35fc9bc60a394b55b0f3414f5f615dee870f6041f3d1a t/threads2.xs SHA256 7c78b44035627c9b84b6c8e065aed9c3389865a58698d97a3b8324d576d47df5 typemap -----BEGIN PGP SIGNATURE----- iEYEAREDAAYFAmQ0Ly8ACgkQOV9mt2VyAVET5ACfdjEjeFljQRXcBpSPMk3bd+vF xRwAn2g2KEXdy5UlgTawF6hjk+8/8cqT =lX94 -----END PGP SIGNATURE----- Devel-CallChecker-0.009/typemap000444001750001750 51414415027456 16401 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.009/lib000755001750001750 014415027456 15430 5ustar00zeframzefram000000000000Devel-CallChecker-0.009/lib/Devel000755001750001750 014415027456 16467 5ustar00zeframzefram000000000000Devel-CallChecker-0.009/lib/Devel/CallChecker.pm000444001750001750 2716314415027456 21353 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. The purpose of this module is specifically to provide the Perl 5.14.0 version of the C API to earlier Perl versions where the core doesn't have C at all. This module does not attempt to backport later refinements of the C API. Thus an XS module that uses this module can be sure of having at least the Perl 5.14.0 version of C available, regardless of which Perl version it is running on, but cannot be sure of having any more refined version of the API available. Such a module will have access to the core's version of the API as normal on Perl versions where the core supplies it, and is free to use the ordinary mechanisms of Perl version portability to manage the differences between versions of the API. =cut package Devel::CallChecker; { use 5.006; } use warnings; use strict; our $VERSION = "0.009"; 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 is 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, 2017, 2023 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.009/lib/Devel/CallChecker.xs000444001750001750 3742114415027456 21367 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define Q_PERL_VERSION_DECIMAL(r,v,s) ((r)*1000000 + (v)*1000 + (s)) #define Q_PERL_DECIMAL_VERSION \ Q_PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define Q_PERL_VERSION_GE(r,v,s) \ (Q_PERL_DECIMAL_VERSION >= Q_PERL_VERSION_DECIMAL(r,v,s)) #define Q_PERL_VERSION_LT(r,v,s) \ (Q_PERL_DECIMAL_VERSION < Q_PERL_VERSION_DECIMAL(r,v,s)) #if (Q_PERL_VERSION_GE(5,17,6) && Q_PERL_VERSION_LT(5,17,11)) || \ (Q_PERL_VERSION_GE(5,19,3) && Q_PERL_VERSION_LT(5,21,1)) PERL_STATIC_INLINE void suppress_unused_warning(void) { (void) S_croak_memory_wrap; } #endif /* (>=5.17.6 && <5.17.11) || (>=5.19.3 && <5.21.1) */ #if Q_PERL_VERSION_LT(5,7,2) # undef dNOOP # define dNOOP extern int Perl___notused_func(void) #endif /* <5.7.2 */ #ifndef cBOOL # define cBOOL(x) ((bool)!!(x)) #endif /* !cBOOL */ #ifndef newSVpvs # define newSVpvs(s) newSVpvn("" s "", (sizeof("" s "")-1)) #endif /* !newSVpvs */ #ifndef OpMORESIB_set # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif /* !OpMORESIB_set */ #ifndef OpSIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) # define OpSIBLING(o) (0 + (o)->op_sibling) #endif /* !OpSIBLING */ #if Q_PERL_VERSION_GE(5,7,3) # define PERL_UNUSED_THX() NOOP #else /* <5.7.3 */ # define PERL_UNUSED_THX() ((void)(aTHX+0)) #endif /* <5.7.3 */ #define Q_PFX xAd8NP3gxZglovQRL5Hn_ #define Q_PFXS STRINGIFY(Q_PFX) #define Q_CONCAT0(a,b) a##b #define Q_CONCAT1(a,b) Q_CONCAT0(a,b) #define Q_PFXD(name) Q_CONCAT1(Q_PFX, name) #if defined(WIN32) && Q_PERL_VERSION_GE(5,13,6) # define Q_BASE_CALLCONV EXTERN_C # define Q_BASE_CALLCONV_S "EXTERN_C" #else /* !(WIN32 && >= 5.13.6) */ # define Q_BASE_CALLCONV PERL_CALLCONV # define Q_BASE_CALLCONV_S "PERL_CALLCONV" #endif /* !(WIN32 && >= 5.13.6) */ #define Q_EXPORT_CALLCONV Q_BASE_CALLCONV #if defined(WIN32) || defined(__CYGWIN__) # define Q_IMPORT_CALLCONV_S Q_BASE_CALLCONV_S " __declspec(dllimport)" #else # define Q_IMPORT_CALLCONV_S Q_BASE_CALLCONV_S #endif #ifndef rv2cv_op_cv # define Q_RV2CV_CONST_REF_RESOLVES Q_PERL_VERSION_GE(5,11,2) # define RV2CVOPCV_MARK_EARLY 0x00000001 # define RV2CVOPCV_RETURN_NAME_GV 0x00000002 # define Perl_rv2cv_op_cv Q_PFXD(roc0) # define rv2cv_op_cv(cvop, flags) Perl_rv2cv_op_cv(aTHX_ cvop, flags) Q_EXPORT_CALLCONV CV *Q_PFXD(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 Q_RV2CV_CONST_REF_RESOLVES case OP_CONST: { SV *rv = cSVOPx_sv(rvop); if(!SvROK(rv)) return NULL; cv = (CV*)SvRV(rv); gv = NULL; } break; # endif /* Q_RV2CV_CONST_REF_RESOLVES */ 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; PERL_UNUSED_THX(); if(!(entersubop->op_flags & OPf_KIDS)) return NULL; pushop = cUNOPx(entersubop)->op_first; if(!OpHAS_SIBLING(pushop)) { if(!(pushop->op_flags & OPf_KIDS)) return NULL; pushop = cUNOPx(pushop)->op_first; if(!OpHAS_SIBLING(pushop)) return NULL; } for(bop = pushop; (cop = OpSIBLING(bop), OpHAS_SIBLING(cop)); bop = cop) ; if(bop == pushop) return NULL; aop = OpSIBLING(pushop); OpMORESIB_set(pushop, cop); OpLASTSIB_set(bop, 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 = OpSIBLING(aop); op_free(aop); aop = bop; } return; } pushop = cUNOPx(entersubop)->op_first; if(!OpHAS_SIBLING(pushop)) { if(!(pushop->op_flags & OPf_KIDS)) goto abort; pushop = cUNOPx(pushop)->op_first; if(!OpHAS_SIBLING(pushop)) goto abort; } for(bop = aop; (cop = OpSIBLING(bop)); bop = cop) ; OpMORESIB_set(bop, OpSIBLING(pushop)); OpMORESIB_set(pushop, 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 Q_PFXD(eal0) # define ck_entersub_args_list(o) Perl_ck_entersub_args_list(aTHX_ o) Q_EXPORT_CALLCONV OP *Q_PFXD(eal0)(pTHX_ OP *entersubop) { return ck_entersub_args_stalk(entersubop, newOP(OP_PADANY, 0)); } # define Perl_ck_entersub_args_proto Q_PFXD(eap0) # define ck_entersub_args_proto(o, gv, sv) \ Perl_ck_entersub_args_proto(aTHX_ o, gv, sv) Q_EXPORT_CALLCONV OP *Q_PFXD(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 Q_PFXD(ean0) # define ck_entersub_args_proto_or_list(o, gv, sv) \ Perl_ck_entersub_args_proto_or_list(aTHX_ o, gv, sv) Q_EXPORT_CALLCONV OP *Q_PFXD(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) { PERL_UNUSED_THX(); 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; PERL_UNUSED_THX(); 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 Q_PERL_VERSION_LT(5,9,3) typedef OP *(*Perl_check_t)(pTHX_ OP *); # endif /* <5.9.3 */ # if Q_PERL_VERSION_LT(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) { PERL_UNUSED_THX(); 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 const mgvtbl_checkcall; typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *); # define Perl_cv_get_call_checker Q_PFXD(gcc0) # define cv_get_call_checker(cv, THX_ckfun_p, ckobj_p) \ Perl_cv_get_call_checker(aTHX_ cv, THX_ckfun_p, ckobj_p) Q_EXPORT_CALLCONV void Q_PFXD(gcc0)(pTHX_ CV *cv, Perl_call_checker *THX_ckfun_p, SV **ckobj_p) { MAGIC *callmg = SvMAGICAL((SV*)cv) ? mg_findext((SV*)cv, PERL_MAGIC_ext, (MGVTBL*)&mgvtbl_checkcall) : NULL; if(callmg) { *THX_ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; } else { *THX_ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; } } # define Perl_cv_set_call_checker Q_PFXD(scc0) # define cv_set_call_checker(cv, THX_ckfun, ckobj) \ Perl_cv_set_call_checker(aTHX_ cv, THX_ckfun, ckobj) Q_EXPORT_CALLCONV void Q_PFXD(scc0)(pTHX_ CV *cv, Perl_call_checker THX_ckfun, SV *ckobj) { if(THX_ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if(SvMAGICAL((SV*)cv)) sv_unmagicext((SV*)cv, PERL_MAGIC_ext, (MGVTBL*)&mgvtbl_checkcall); } else { MAGIC *callmg = mg_findext((SV*)cv, PERL_MAGIC_ext, (MGVTBL*)&mgvtbl_checkcall); if(!callmg) callmg = sv_magicext((SV*)cv, &PL_sv_undef, PERL_MAGIC_ext, (MGVTBL*)&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 *, THX_ckfun); callmg->mg_obj = ckobj; if(ckobj != (SV*)cv) { SvREFCNT_inc(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } } } static OP *(*THX_nxck_entersub)(pTHX_ OP *); static OP *THX_myck_entersub(pTHX_ OP *entersubop) { OP *aop, *cvop; CV *cv; GV *namegv; Perl_call_checker THX_ckfun; SV *ckobj; aop = cUNOPx(entersubop)->op_first; if(!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; aop = OpSIBLING(aop); for(cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ; if(!(cv = rv2cv_op_cv(cvop, 0))) return THX_nxck_entersub(aTHX_ entersubop); cv_get_call_checker(cv, &THX_ckfun, &ckobj); if(THX_ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) return THX_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 THX_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, THX_myck_entersub, &THX_nxck_entersub); #endif /* Q_PROVIDE_CV_SET_CALL_CHECKER */ SV * callchecker0_h() CODE: #if PERL_VERSION & 1 # define Q_CODE_PERL_SUBVERSION_CRITERION \ " && PERL_SUBVERSION == " STRINGIFY(PERL_SUBVERSION) # define Q_TEXT_PERL_SUBVERSION_CRITERION "." STRINGIFY(PERL_SUBVERSION) #else /* !(PERL_VERSION & 1) */ # define Q_CODE_PERL_SUBVERSION_CRITERION "" # define Q_TEXT_PERL_SUBVERSION_CRITERION "" #endif /* !(PERL_VERSION & 1) */ #define Q_DEFFN(RETTYPE, PUBNAME, PRIVNAME, ARGTYPES, ARGNAMES) \ Q_IMPORT_CALLCONV_S " " RETTYPE " " \ Q_PFXS PRIVNAME "(pTHX_ " ARGTYPES ");\n" \ "#define Perl_" PUBNAME " " Q_PFXS PRIVNAME "\n" \ "#define " PUBNAME "(" ARGNAMES ") " \ "Perl_" PUBNAME "(aTHX_ " ARGNAMES ")\n" #if Q_PROVIDE_RV2CV_OP_CV # define Q_CODE_PROVIDE_RV2CV_OP_CV \ "#define RV2CVOPCV_MARK_EARLY 0x00000001\n" \ "#define RV2CVOPCV_RETURN_NAME_GV 0x00000002\n" \ Q_DEFFN("CV *", "rv2cv_op_cv", "roc0", "OP *, U32", "cvop, flags") #else /* !Q_PROVIDE_RV2CV_OP_CV */ # define Q_CODE_PROVIDE_RV2CV_OP_CV "" #endif /* !Q_PROVIDE_RV2CV_OP_CV */ #if Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST # define Q_CODE_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST \ Q_DEFFN("OP *", "ck_entersub_args_list", "eal0", "OP *", "o") \ Q_DEFFN("OP *", "ck_entersub_args_proto", "eap0", \ "OP *, GV *, SV *", "o, gv, sv") \ Q_DEFFN("OP *", "ck_entersub_args_proto_or_list", "ean0", \ "OP *, GV *, SV *", "o, gv, sv") #else /* !Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST */ # define Q_CODE_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST "" #endif /* !Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST */ #if Q_PROVIDE_CV_SET_CALL_CHECKER # define Q_CODE_PROVIDE_CV_SET_CALL_CHECKER \ "typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);\n" \ Q_DEFFN("void", "cv_get_call_checker", "gcc0", \ "CV *, Perl_call_checker *, SV **", "cv, fp, op") \ Q_DEFFN("void", "cv_set_call_checker", "scc0", \ "CV *, Perl_call_checker, SV *", "cv, f, o") #else /* !Q_PROVIDE_CV_SET_CALL_CHECKER */ # define Q_CODE_PROVIDE_CV_SET_CALL_CHECKER "" #endif /* !Q_PROVIDE_CV_SET_CALL_CHECKER */ RETVAL = newSVpvs( "/* DO NOT EDIT -- generated " "by Devel::CallChecker version " XS_VERSION " */\n" "#ifndef " Q_PFXS "INCLUDED\n" "#define " Q_PFXS "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) Q_CODE_PERL_SUBVERSION_CRITERION ")\n" " #error this callchecker0.h is for Perl " STRINGIFY(PERL_REVISION) "." STRINGIFY(PERL_VERSION) Q_TEXT_PERL_SUBVERSION_CRITERION " only\n" "#endif /* Perl version mismatch */\n" Q_CODE_PROVIDE_RV2CV_OP_CV Q_CODE_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST Q_CODE_PROVIDE_CV_SET_CALL_CHECKER "#endif /* !" Q_PFXS "INCLUDED */\n" ); OUTPUT: RETVAL Devel-CallChecker-0.009/t000755001750001750 014415027456 15125 5ustar00zeframzefram000000000000Devel-CallChecker-0.009/t/callck.t000444001750001750 1043014415027456 16716 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { unshift @INC, "./t/lib"; } 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.009/t/callck.xs000444001750001750 1371714415027456 17120 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "callck_callchecker0.h" #include "XSUB.h" #define Q_PERL_VERSION_DECIMAL(r,v,s) ((r)*1000000 + (v)*1000 + (s)) #define Q_PERL_DECIMAL_VERSION \ Q_PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define Q_PERL_VERSION_GE(r,v,s) \ (Q_PERL_DECIMAL_VERSION >= Q_PERL_VERSION_DECIMAL(r,v,s)) #define Q_PERL_VERSION_LT(r,v,s) \ (Q_PERL_DECIMAL_VERSION < Q_PERL_VERSION_DECIMAL(r,v,s)) #if (Q_PERL_VERSION_GE(5,17,6) && Q_PERL_VERSION_LT(5,17,11)) || \ (Q_PERL_VERSION_GE(5,19,3) && Q_PERL_VERSION_LT(5,21,1)) PERL_STATIC_INLINE void suppress_unused_warning(void) { (void) S_croak_memory_wrap; } #endif /* (>=5.17.6 && <5.17.11) || (>=5.19.3 && <5.21.1) */ #if Q_PERL_VERSION_LT(5,7,2) # undef dNOOP # define dNOOP extern int Perl___notused_func(void) #endif /* <5.7.2 */ #ifndef cBOOL # define cBOOL(x) ((bool)!!(x)) #endif /* !cBOOL */ #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)(x)) #endif /* !PERL_UNUSED_VAR */ #ifndef PERL_UNUSED_ARG # define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x) #endif /* !PERL_UNUSED_ARG */ #ifndef FPTR2DPTR # define FPTR2DPTR(t,x) ((t)(UV)(x)) #endif /* !FPTR2DPTR */ #ifndef OpMORESIB_set # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif /* !OpMORESIB_set */ #ifndef OpSIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) # define OpSIBLING(o) (0 + (o)->op_sibling) #endif /* !OpSIBLING */ #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 %s line %d", __FILE__, __LINE__) #define croak_fail_ne(h, w) \ croak("fail %p!=%p at %s line %d", (h), (w), __FILE__, __LINE__) #define check_cc(pcv, xckfun, xckobj) \ do { \ cv_get_call_checker((pcv), &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 *pcv) PROTOTYPE: $ CODE: cv_set_call_checker(pcv, THX_ck_entersub_args_lists, &PL_sv_undef); void cv_set_call_checker_scalars(CV *pcv) PROTOTYPE: $ CODE: cv_set_call_checker(pcv, THX_ck_entersub_args_scalars, &PL_sv_undef); void cv_set_call_checker_proto(CV *pcv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(pcv, Perl_ck_entersub_args_proto, proto); void cv_set_call_checker_proto_or_list(CV *pcv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(pcv, Perl_ck_entersub_args_proto_or_list, proto); void cv_set_call_checker_multi_sum(CV *pcv) PROTOTYPE: $ CODE: cv_set_call_checker(pcv, THX_ck_entersub_multi_sum, &PL_sv_undef); Devel-CallChecker-0.009/t/pod_cvg.t000444001750001750 27314415027456 17052 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.009/t/pod_syn.t000444001750001750 23614415027456 17103 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.009/t/rv2cvopcv.t000444001750001750 56214415027456 17364 0ustar00zeframzefram000000000000use warnings; use strict; BEGIN { unshift @INC, "./t/lib"; } 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.009/t/rv2cvopcv.xs000444001750001750 764014415027456 17577 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "rv2cvopcv_callchecker0.h" #include "XSUB.h" #define Q_PERL_VERSION_DECIMAL(r,v,s) ((r)*1000000 + (v)*1000 + (s)) #define Q_PERL_DECIMAL_VERSION \ Q_PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define Q_PERL_VERSION_GE(r,v,s) \ (Q_PERL_DECIMAL_VERSION >= Q_PERL_VERSION_DECIMAL(r,v,s)) #define Q_PERL_VERSION_LT(r,v,s) \ (Q_PERL_DECIMAL_VERSION < Q_PERL_VERSION_DECIMAL(r,v,s)) #if (Q_PERL_VERSION_GE(5,17,6) && Q_PERL_VERSION_LT(5,17,11)) || \ (Q_PERL_VERSION_GE(5,19,3) && Q_PERL_VERSION_LT(5,21,1)) PERL_STATIC_INLINE void suppress_unused_warning(void) { (void) S_croak_memory_wrap; } #endif /* (>=5.17.6 && <5.17.11) || (>=5.19.3 && <5.21.1) */ #if Q_PERL_VERSION_LT(5,7,2) # undef dNOOP # define dNOOP extern int Perl___notused_func(void) #endif /* <5.7.2 */ #define Q_RV2CV_CONST_REF_RESOLVES Q_PERL_VERSION_GE(5,11,2) 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 %s line %d", __FILE__, __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 Q_RV2CV_CONST_REF_RESOLVES 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 /* !Q_RV2CV_CONST_REF_RESOLVES */ if (rv2cv_op_cv(o, 0)) croak_fail(); if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail(); #endif /* !Q_RV2CV_CONST_REF_RESOLVES */ 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 Q_RV2CV_CONST_REF_RESOLVES if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail(); #else /* !Q_RV2CV_CONST_REF_RESOLVES */ if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail(); #endif /* !Q_RV2CV_CONST_REF_RESOLVES */ 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.009/t/threads.t000444001750001750 511414415027456 17102 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"); } if("$]" < 5.008003) { require Test::More; Test::More::plan(skip_all => "threading breaks PL_sv_placeholder on this Perl"); } if("$]" < 5.008009) { require Test::More; Test::More::plan(skip_all => "threading corrupts memory on this Perl"); } if("$]" >= 5.009005 && "$]" < 5.010001) { require Test::More; Test::More::plan(skip_all => "threading breaks assertions on this Perl"); } 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 my(@exit_sems, @threads); sub test_in_thread($) { my($test_code) = @_; my $done_sem = Thread::Semaphore->new(0); my $exit_sem = Thread::Semaphore->new(0); push @exit_sems, $exit_sem; my $ok :shared; push @threads, threads->create(sub { $ok = !!$test_code->(); $done_sem->up; $exit_sem->down; }); $done_sem->down; ok $ok; } BEGIN { unshift @INC, "./t/lib"; } sub tsub1 (@) { $_[0] } sub tsub2 (@) { $_[0] } sub nsub (@) { $_[0] } our @three = (3); test_in_thread(sub { 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 return 0; eval(q{tsub1(@three)}) == 3 or return 0; t::threads1::cv_set_call_checker_proto(\&tsub1, "\$"); eval(q{nsub(@three)}) == 3 or return 0; eval(q{tsub1(@three)}) == 1 or return 0; return 1; }); test_in_thread(sub { 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 return 0; eval(q{tsub2(@three)}) == 3 or return 0; t::threads2::cv_set_call_checker_proto(\&tsub2, "\$"); eval(q{nsub(@three)}) == 3 or return 0; eval(q{tsub2(@three)}) == 1 or return 0; return 1; }); $_->up foreach @exit_sems; $_->join foreach @threads; ok 1; 1; Devel-CallChecker-0.009/t/threads1.xs000444001750001750 212714415027456 17353 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "threads1_callchecker0.h" #include "XSUB.h" #define Q_PERL_VERSION_DECIMAL(r,v,s) ((r)*1000000 + (v)*1000 + (s)) #define Q_PERL_DECIMAL_VERSION \ Q_PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define Q_PERL_VERSION_GE(r,v,s) \ (Q_PERL_DECIMAL_VERSION >= Q_PERL_VERSION_DECIMAL(r,v,s)) #define Q_PERL_VERSION_LT(r,v,s) \ (Q_PERL_DECIMAL_VERSION < Q_PERL_VERSION_DECIMAL(r,v,s)) #if (Q_PERL_VERSION_GE(5,17,6) && Q_PERL_VERSION_LT(5,17,11)) || \ (Q_PERL_VERSION_GE(5,19,3) && Q_PERL_VERSION_LT(5,21,1)) PERL_STATIC_INLINE void suppress_unused_warning(void) { (void) S_croak_memory_wrap; } #endif /* (>=5.17.6 && <5.17.11) || (>=5.19.3 && <5.21.1) */ #if Q_PERL_VERSION_LT(5,7,2) # undef dNOOP # define dNOOP extern int Perl___notused_func(void) #endif /* <5.7.2 */ MODULE = t::threads1 PACKAGE = t::threads1 PROTOTYPES: DISABLE void cv_set_call_checker_proto(CV *pcv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(pcv, Perl_ck_entersub_args_proto, proto); Devel-CallChecker-0.009/t/threads2.xs000444001750001750 212714415027456 17354 0ustar00zeframzefram000000000000#define PERL_NO_GET_CONTEXT 1 #include "EXTERN.h" #include "perl.h" #include "threads2_callchecker0.h" #include "XSUB.h" #define Q_PERL_VERSION_DECIMAL(r,v,s) ((r)*1000000 + (v)*1000 + (s)) #define Q_PERL_DECIMAL_VERSION \ Q_PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #define Q_PERL_VERSION_GE(r,v,s) \ (Q_PERL_DECIMAL_VERSION >= Q_PERL_VERSION_DECIMAL(r,v,s)) #define Q_PERL_VERSION_LT(r,v,s) \ (Q_PERL_DECIMAL_VERSION < Q_PERL_VERSION_DECIMAL(r,v,s)) #if (Q_PERL_VERSION_GE(5,17,6) && Q_PERL_VERSION_LT(5,17,11)) || \ (Q_PERL_VERSION_GE(5,19,3) && Q_PERL_VERSION_LT(5,21,1)) PERL_STATIC_INLINE void suppress_unused_warning(void) { (void) S_croak_memory_wrap; } #endif /* (>=5.17.6 && <5.17.11) || (>=5.19.3 && <5.21.1) */ #if Q_PERL_VERSION_LT(5,7,2) # undef dNOOP # define dNOOP extern int Perl___notused_func(void) #endif /* <5.7.2 */ MODULE = t::threads2 PACKAGE = t::threads2 PROTOTYPES: DISABLE void cv_set_call_checker_proto(CV *pcv, SV *proto) PROTOTYPE: $$ CODE: if (SvROK(proto)) proto = SvRV(proto); cv_set_call_checker(pcv, Perl_ck_entersub_args_proto, proto); Devel-CallChecker-0.009/t/lib000755001750001750 014415027456 15673 5ustar00zeframzefram000000000000Devel-CallChecker-0.009/t/lib/t000755001750001750 014415027456 16136 5ustar00zeframzefram000000000000Devel-CallChecker-0.009/t/lib/t/LoadXS.pm000444001750001750 225414415027456 17766 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.009/t/lib/t/WriteHeader.pm000444001750001750 100514415027456 21030 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;