Devel-GlobalDestruction-0.14/000755 000765 000024 00000000000 13005742353 016402 5ustar00gknopstaff000000 000000 Devel-GlobalDestruction-0.14/Changes000644 000765 000024 00000003757 13005742333 017707 0ustar00gknopstaff000000 000000 Revision history for Devel-GlobalDestruction 0.14 - 2016-10-31 - stop relying on . being in @INC - switch to ExtUtils::HasCompiler to detect presence of a compiler 0.13 - 2014-08-16 * include README * include minimum perl version 5.6 in metadata 0.12 Fri, 01 Nov 2013 * Fix detection when loaded during global destruction by checking B::main_cv instead of B::main_start * Bump Sub::Exporter::Progressive dependency to fix loading in global destruction 0.11 Wed, 03 Apr 2013 * Fix upgrading from version 0.09 or older 0.10 Tue, 26 Mar 2013 * Rewrite pure-perl implementation in terms of B::main_start (greatly simplifies code) * Fix pure-perl behavior under $^C (RT#78619)) * Separate XS portion into a compiler-optional dependency Devel::GlobalDestruction::XS 0.09 Wed, 08 Aug 2012 * Rewrite completely broken pure-perl GD detection under threads * Fix pure-perl implementation incorrectly reporting GD during END phase 0.08 Tue, 31 Jul 2012 * Switch to Sub::Exporter::Progressive 0.07 Wed, 25 Jul 2012 * Actually detect errors in pure-perl test * Add prototype to pure-perl pre-5.14 version 0.06 Thu, 14 Jun 2012 * De-retardize XS-less behavior under SpeedyCGI * Test suite now works from within space-containing paths 0.05 Thu, 26 Apr 2012 * Pure-perl implementation for situations where neither ${^GLOBAL_PHASE} nor XS are available 0.04 Sun, 03 Jul 2011 11:28:51 +0200 * To detect a perl with ${^GLOBAL_PHASE}, check for the feature itself instead of a specific perl version (doy). * Update the documentation to reflect the use of ${^GLOBAL_PHASE} if available (doy). * Stop depending on Scope::Guard for the tests (doy). * Upgrade ppport.h from version 3.13 to 3.19. 0.03 * Drop the XS code on perl versions recent enough to have ${^GLOBAL_PHASE}. * Drop code to support perls older than 5.6. We've always been depending on 5.6 anyway. + Use XSLoader without a fallback to DynaLoader. + Use our instead of use vars. Devel-GlobalDestruction-0.14/inc/000755 000765 000024 00000000000 13005742352 017152 5ustar00gknopstaff000000 000000 Devel-GlobalDestruction-0.14/lib/000755 000765 000024 00000000000 13005742352 017147 5ustar00gknopstaff000000 000000 Devel-GlobalDestruction-0.14/maint/000755 000765 000024 00000000000 13005742352 017511 5ustar00gknopstaff000000 000000 Devel-GlobalDestruction-0.14/Makefile.PL000644 000765 000024 00000006737 13005742211 020362 0ustar00gknopstaff000000 000000 use strict; use warnings FATAL => 'all'; use 5.006; use lib 'inc'; use ExtUtils::HasCompiler qw(can_compile_loadable_object); use ExtUtils::MakeMaker; my %META = ( name => 'Devel-GlobalDestruction', license => 'perl_5', prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, } }, runtime => { requires => { 'Sub::Exporter::Progressive' => '0.001011', 'perl' => 5.006, }, }, }, resources => { homepage => 'https://metacpan.org/release/Devel-GlobalDestruction', repository => { url => 'git://git.shadowcat.co.uk/p5sagit/Devel-GlobalDestruction.git', web => 'http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/Devel-GlobalDestruction.git', type => 'git', }, bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-GlobalDestruction', mailto => 'bug-Devel-GlobalDestruction@rt.cpan.org', }, license => [ 'http://dev.perl.org/licenses/' ], }, no_index => { directory => [ 't', 'xt' ] }, ); my %MM_ARGS = ( PREREQ_PM => { ( (defined ${^GLOBAL_PHASE} or parse_args()->{PUREPERL_ONLY} or !can_compile_loadable_object(quiet => 1) ) ? () : ('Devel::GlobalDestruction::XS' => 0) ), }, ); use Text::ParseWords; sub parse_args { # copied from EUMM ExtUtils::MakeMaker::parse_args( my $tmp = {}, Text::ParseWords::shellwords($ENV{PERL_MM_OPT} || ''), @ARGV, ); return $tmp->{ARGS} || {}; } if (eval { require Devel::GlobalDestruction } && Devel::GlobalDestruction->VERSION < 0.10) { package MY; no warnings 'once'; *install = sub { my $self = shift; return ' pure_site_install :: $(NOECHO) $(RM_F) ' . $self->quote_literal( $self->catfile('$(DESTINSTALLSITEARCH)', 'Devel', 'GlobalDestruction.pm') ) . "\n" . $self->SUPER::install; }; } ## BOILERPLATE ############################################################### require ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; # have to do this since old EUMM dev releases miss the eval $VERSION line my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; my $mymeta = $eumm_version >= 6.57_02; my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; $META{license} = [ $META{license} ] if $META{license} && !ref $META{license}; $MM_ARGS{LICENSE} = $META{license}[0] if $META{license} && $eumm_version >= 6.30; $MM_ARGS{NO_MYMETA} = 1 if $mymeta_broken; $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } unless -f 'META.yml'; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; my $r = $MM_ARGS{$key} = { %{$META{prereqs}{$_}{requires} || {}}, %{delete $MM_ARGS{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } $MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; delete $MM_ARGS{MIN_PERL_VERSION} if $eumm_version < 6.47_01; $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; delete $MM_ARGS{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); ## END BOILERPLATE ########################################################### Devel-GlobalDestruction-0.14/MANIFEST000644 000765 000024 00000000744 13005742353 017540 0ustar00gknopstaff000000 000000 Changes inc/ExtUtils/HasCompiler.pm lib/Devel/GlobalDestruction.pm maint/Makefile.PL.include Makefile.PL MANIFEST This list of files t/01_basic.t t/02_thread.t t/03_minusc.t t/04_phases.t t/05_thread_clone.t t/06_load-in-gd.t t/10_pure-perl.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Devel-GlobalDestruction-0.14/META.json000644 000765 000024 00000003522 13005742353 020025 0ustar00gknopstaff000000 000000 { "abstract" : "Provides function returning the equivalent of C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls.", "author" : [ "Yuval Kogman ", "Florian Ragwitz ", "Jesse Luehrs ", "Peter Rabbitson ", "Arthur Axel 'fREW' Schmidt ", "Elizabeth Mattijsen ", "Graham Knop " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Devel-GlobalDestruction", "no_index" : { "directory" : [ "t", "xt" ] }, "prereqs" : { "build" : {}, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Sub::Exporter::Progressive" : "0.001011", "perl" : "5.006" } }, "test" : {} }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Devel-GlobalDestruction@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-GlobalDestruction" }, "homepage" : "https://metacpan.org/release/Devel-GlobalDestruction", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://git.shadowcat.co.uk/p5sagit/Devel-GlobalDestruction.git", "web" : "http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/Devel-GlobalDestruction.git" } }, "version" : "0.14", "x_serialization_backend" : "JSON::PP version 2.27300" } Devel-GlobalDestruction-0.14/META.yml000644 000765 000024 00000002241 13005742353 017652 0ustar00gknopstaff000000 000000 --- abstract: "Provides function returning the equivalent of C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls." author: - 'Yuval Kogman ' - 'Florian Ragwitz ' - 'Jesse Luehrs ' - 'Peter Rabbitson ' - "Arthur Axel 'fREW' Schmidt " - 'Elizabeth Mattijsen ' - 'Graham Knop ' build_requires: {} configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Devel-GlobalDestruction no_index: directory: - t - xt requires: Sub::Exporter::Progressive: '0.001011' perl: '5.006' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-GlobalDestruction homepage: https://metacpan.org/release/Devel-GlobalDestruction license: http://dev.perl.org/licenses/ repository: git://git.shadowcat.co.uk/p5sagit/Devel-GlobalDestruction.git version: '0.14' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Devel-GlobalDestruction-0.14/README000644 000765 000024 00000003343 13005742353 017265 0ustar00gknopstaff000000 000000 NAME Devel::GlobalDestruction - Provides function returning the equivalent of "${^GLOBAL_PHASE} eq 'DESTRUCT'" for older perls. SYNOPSIS package Foo; use Devel::GlobalDestruction; use namespace::clean; # to avoid having an "in_global_destruction" method sub DESTROY { return if in_global_destruction; do_something_a_little_tricky(); } DESCRIPTION Perl's global destruction is a little tricky to deal with WRT finalizers because it's not ordered and objects can sometimes disappear. Writing defensive destructors is hard and annoying, and usually if global destruction is happening you only need the destructors that free up non process local resources to actually execute. For these constructors you can avoid the mess by simply bailing out if global destruction is in effect. EXPORTS This module uses Sub::Exporter::Progressive so the exports may be renamed, aliased, etc. if Sub::Exporter is present. in_global_destruction Returns true if the interpreter is in global destruction. In perl 5.14+, this returns "${^GLOBAL_PHASE} eq 'DESTRUCT'", and on earlier perls, detects it using the value of "PL_main_cv" or "PL_dirty". AUTHORS Yuval Kogman Florian Ragwitz Jesse Luehrs Peter Rabbitson Arthur Axel 'fREW' Schmidt Elizabeth Mattijsen Greham Knop COPYRIGHT Copyright (c) 2008 Yuval Kogman. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Devel-GlobalDestruction-0.14/t/000755 000765 000024 00000000000 13005742352 016644 5ustar00gknopstaff000000 000000 Devel-GlobalDestruction-0.14/t/01_basic.t000644 000765 000024 00000004074 12302165577 020426 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { unshift @INC, sub { die 'no XS' if $_[1] eq 'Devel/GlobalDestruction/XS.pm'; }; } } BEGIN { package Test::Scope::Guard; sub new { my ($class, $code) = @_; bless [$code], $class; } sub DESTROY { my $self = shift; $self->[0]->() } } print "1..9\n"; our $had_error; # try to ensure this is the last-most END so we capture future tests # running in other ENDs if ($] >= 5.008) { require B; my $reinject_retries = my $max_retry = 5; my $end_worker; $end_worker = sub { my $tail = (B::end_av()->ARRAY)[-1]; if (!defined $tail or $tail == $end_worker) { $? = $had_error || 0; $reinject_retries = 0; } elsif ($reinject_retries--) { push @{B::end_av()->object_2svref}, $end_worker; } else { print STDERR "\n\nSomething is racing with @{[__FILE__]} for final END block definition - can't win after $max_retry iterations :(\n\n"; require POSIX; POSIX::_exit( 255 ); } }; eval 'END { push @{B::end_av()->object_2svref}, $end_worker }'; } # B::end_av isn't available on 5.6, so just use a basic end block else { eval 'END { $? = $had_error || 0 }'; } sub ok ($$) { $had_error++, print "not " if !$_[0]; print "ok"; print " - $_[1]" if defined $_[1]; print "\n"; } END { ok( ! in_global_destruction(), 'Not yet in GD while in END block 2' ) } ok( eval "use Devel::GlobalDestruction; 1", "use Devel::GlobalDestruction" ); ok( defined &in_global_destruction, "exported" ); ok( defined prototype \&in_global_destruction, "defined prototype" ); ok( prototype \&in_global_destruction eq "", "empty prototype" ); ok( ! in_global_destruction(), "Runtime is not GD" ); our $sg1; $sg1 = Test::Scope::Guard->new(sub { ok( in_global_destruction(), "Final cleanup object destruction properly in GD" ) }); END { ok( ! in_global_destruction(), 'Not yet in GD while in END block 1' ) } our $sg2 = Test::Scope::Guard->new(sub { ok( ! in_global_destruction(), "Object destruction in END not considered GD" ) }); END { undef $sg2 } Devel-GlobalDestruction-0.14/t/02_thread.t000644 000765 000024 00000001615 13000660603 020575 0ustar00gknopstaff000000 000000 use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } } BEGIN { unless (eval { require threads }) { print "1..0 # SKIP threads.pm not installed\n"; exit 0; } } use threads; use threads::shared; our $had_error :shared; END { $? = $had_error||0 } use strict; use warnings; BEGIN { if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { unshift @INC, sub { die 'no XS' if $_[1] eq 'Devel/GlobalDestruction/XS.pm'; }; } } # load it before spawning a thread, that's the whole point require Devel::GlobalDestruction; sub do_test { # just die so we don't need to deal with testcount skew unless ( ($_[0]||'') eq 'arg' ) { $had_error++; die "Argument passing failed!"; } delete $INC{'./t/01_basic.t'}; do './t/01_basic.t'; 1; } threads->create('do_test', 'arg')->join or $had_error++; Devel-GlobalDestruction-0.14/t/03_minusc.t000644 000765 000024 00000001550 12217032374 020632 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { unshift @INC, sub { die 'no XS' if $_[1] eq 'Devel/GlobalDestruction/XS.pm'; }; } } { package Test::Scope::Guard; sub new { my ($class, $code) = @_; bless [$code], $class; } sub DESTROY { my $self = shift; $self->[0]->() } } sub ok ($$) { print "not " if !$_[0]; print "ok"; print " - $_[1]" if defined $_[1]; print "\n"; !!$_[0] } BEGIN { require B; B::minus_c(); print "1..3\n"; ok( $^C, "Test properly running under minus-c" ); } use Devel::GlobalDestruction; BEGIN { ok !in_global_destruction(), "BEGIN is not GD with -c"; } our $foo; BEGIN { $foo = Test::Scope::Guard->new( sub { ok( in_global_destruction(), "Final cleanup object destruction properly in GD" ) or do { require POSIX; POSIX::_exit(1); }; }); } Devel-GlobalDestruction-0.14/t/04_phases.t000644 000765 000024 00000002203 12217032374 020614 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { unshift @INC, sub { die 'no XS' if $_[1] eq 'Devel/GlobalDestruction/XS.pm'; }; } } { package Test::Scope::Guard; sub new { my ($class, $code) = @_; bless [$code], $class; } sub DESTROY { my $self = shift; $self->[0]->() } } my $had_error = 0; END { $? = $had_error } sub ok ($$) { $had_error++, print "not " if !$_[0]; print "ok"; print " - $_[1]" if defined $_[1]; print "\n"; !!$_[0] } use Devel::GlobalDestruction; sub check_not_global { my $phase = shift; ok !in_global_destruction(), "$phase is not GD"; Test::Scope::Guard->new( sub { ok( !in_global_destruction(), "DESTROY in $phase still not GD" ); }); } BEGIN { print "1..10\n"; } BEGIN { check_not_global('BEGIN') } BEGIN { if (eval 'UNITCHECK {}; 1') { eval q[ UNITCHECK { check_not_global('UNITCHECK') }; 1 ] or die $@; } else { print "ok # UNITCHECK not supported in perl < 5.10\n" x 2; } } CHECK { check_not_global('CHECK') } sub CLONE { check_not_global('CLONE') }; INIT { check_not_global('INIT') } END { check_not_global('END') } Devel-GlobalDestruction-0.14/t/05_thread_clone.t000644 000765 000024 00000003334 12465706774 022010 0ustar00gknopstaff000000 000000 use strict; use warnings; use Config; BEGIN { unless ($Config{useithreads}) { print "1..0 # SKIP your perl does not support ithreads\n"; exit 0; } } BEGIN { unless (eval { require threads }) { print "1..0 # SKIP threads.pm not installed\n"; exit 0; } } BEGIN { if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { unshift @INC, sub { die 'no XS' if $_[1] eq 'Devel/GlobalDestruction/XS.pm'; }; } } BEGIN { package Test::Scope::Guard; sub new { my ($class, $code) = @_; bless [$code], $class; } sub DESTROY { my $self = shift; $self->[0]->() } } BEGIN { package Test::Thread::Clone; my @code; sub new { my ($class, $code) = @_; push @code, $code; bless [$code], $class; } sub CLONE { $_->() for @code } } use threads; use threads::shared; print "1..4\n"; our $had_error :shared; END { $? = $had_error||0 } sub ok ($$) { $had_error++, print "not " if !$_[0]; print "ok"; print " - $_[1]" if defined $_[1]; print "\n"; } # load it before spawning a thread, that's the whole point use Devel::GlobalDestruction; our $cloner = Test::Thread::Clone->new(sub { ok( ! in_global_destruction(), "CLONE is not GD" ); my $guard = Test::Scope::Guard->new(sub { ok( ! in_global_destruction(), "DESTROY during CLONE is not GD"); }); }); our $global = Test::Scope::Guard->new(sub { ok( in_global_destruction(), "Final cleanup object destruction properly in GD in " . (threads->tid ? 'thread' : 'main program') ); }); sub do_test { # just die so we don't need to deal with testcount skew unless ( ($_[0]||'') eq 'arg' ) { $had_error++; die "Argument passing failed!"; } # nothing really to do in here 1; } threads->create('do_test', 'arg')->join or $had_error++; Devel-GlobalDestruction-0.14/t/06_load-in-gd.t000644 000765 000024 00000001402 12234750344 021251 0ustar00gknopstaff000000 000000 use strict; use warnings; BEGIN { if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { unshift @INC, sub { die 'no XS' if $_[1] eq 'Devel/GlobalDestruction/XS.pm'; }; } } { package Test::Scope::Guard; sub new { my ($class, $code) = @_; bless [$code], $class; } sub DESTROY { my $self = shift; $self->[0]->() } } use POSIX qw(_exit); $|++; print "1..3\n"; our $alive = Test::Scope::Guard->new(sub { require Devel::GlobalDestruction; my $gd = Devel::GlobalDestruction::in_global_destruction(); print(($gd ? '' : 'not ') . "ok 3 - global destruct detected when loaded during GD\n"); _exit($gd ? 0 : 1); }); print(($alive ? '' : 'not ') . "ok 1 - alive during runtime\n"); END { print(($alive ? '' : 'not ') . "ok 2 - alive during END\n"); } Devel-GlobalDestruction-0.14/t/10_pure-perl.t000644 000765 000024 00000002024 12217032374 021242 0ustar00gknopstaff000000 000000 use strict; use warnings; use FindBin qw($Bin); use Config; use IPC::Open2; # rerun the tests under the assumption of pure-perl # for the $^X-es $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); $ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST} = 1; my $this_file = quotemeta(__FILE__); opendir(my $dh, $Bin); my @tests = grep { $_ !~ /${this_file}$/ } map { "$Bin/$_" } grep { /\.t$/ } readdir $dh; print "1..@{[ scalar @tests ]}\n"; my $had_error = 0; END { $? = $had_error } sub ok ($$) { $had_error++, print "not " if !$_[0]; print "ok"; print " - $_[1]" if defined $_[1]; print "\n"; } for my $fn (@tests) { # this is cheating, and may even hang here and there (testing on windows passed fine) # if it does - will have to fix it somehow (really *REALLY* don't want to pull # in IPC::Cmd just for a fucking test) # the alternative would be to have an ENV check in each test to force a subtest open2(my $out, my $in, $^X, $fn ); while (my $ln = <$out>) { print " $ln"; } wait; ok (! $?, "Exit $? from: $^X $fn"); } Devel-GlobalDestruction-0.14/maint/Makefile.PL.include000644 000765 000024 00000000771 12613736515 023122 0ustar00gknopstaff000000 000000 BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar 0.001; use ExtUtils::MakeMaker 6.57_10 (); author [ 'Yuval Kogman ', 'Florian Ragwitz ', 'Jesse Luehrs ', 'Peter Rabbitson ', 'Arthur Axel \'fREW\' Schmidt ', 'Elizabeth Mattijsen ', 'Graham Knop ', ]; manifest_include inc => '.pm'; 1; Devel-GlobalDestruction-0.14/lib/Devel/000755 000765 000024 00000000000 13005742352 020206 5ustar00gknopstaff000000 000000 Devel-GlobalDestruction-0.14/lib/Devel/GlobalDestruction.pm000644 000765 000024 00000005327 13005742316 024177 0ustar00gknopstaff000000 000000 package Devel::GlobalDestruction; use strict; use warnings; our $VERSION = '0.14'; use Sub::Exporter::Progressive -setup => { exports => [ qw(in_global_destruction) ], groups => { default => [ -all ] }, }; # we run 5.14+ - everything is in core # if (defined ${^GLOBAL_PHASE}) { eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1' or die $@; } # try to load the xs version if it was compiled # elsif (eval { require Devel::GlobalDestruction::XS; no warnings 'once'; *in_global_destruction = \&Devel::GlobalDestruction::XS::in_global_destruction; 1; }) { # the eval already installed everything, nothing to do } else { # internally, PL_main_cv is set to Nullcv immediately before entering # global destruction and we can use B to detect that. B::main_cv will # only ever be a B::CV or a B::SPECIAL that is a reference to 0 require B; eval 'sub in_global_destruction () { ${B::main_cv()} == 0 }; 1' or die $@; } 1; # keep require happy __END__ =head1 NAME Devel::GlobalDestruction - Provides function returning the equivalent of C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls. =head1 SYNOPSIS package Foo; use Devel::GlobalDestruction; use namespace::clean; # to avoid having an "in_global_destruction" method sub DESTROY { return if in_global_destruction; do_something_a_little_tricky(); } =head1 DESCRIPTION Perl's global destruction is a little tricky to deal with WRT finalizers because it's not ordered and objects can sometimes disappear. Writing defensive destructors is hard and annoying, and usually if global destruction is happening you only need the destructors that free up non process local resources to actually execute. For these constructors you can avoid the mess by simply bailing out if global destruction is in effect. =head1 EXPORTS This module uses L so the exports may be renamed, aliased, etc. if L is present. =over 4 =item in_global_destruction Returns true if the interpreter is in global destruction. In perl 5.14+, this returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, detects it using the value of C or C. =back =head1 AUTHORS Yuval Kogman Enothingmuch@woobling.orgE Florian Ragwitz Erafl@debian.orgE Jesse Luehrs Edoy@tozt.netE Peter Rabbitson Eribasushi@cpan.orgE Arthur Axel 'fREW' Schmidt Efrioux@gmail.comE Elizabeth Mattijsen Eliz@dijkmat.nlE Greham Knop Ehaarg@haarg.orgE =head1 COPYRIGHT Copyright (c) 2008 Yuval Kogman. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Devel-GlobalDestruction-0.14/inc/ExtUtils/000755 000765 000024 00000000000 13005742352 020733 5ustar00gknopstaff000000 000000 Devel-GlobalDestruction-0.14/inc/ExtUtils/HasCompiler.pm000644 000765 000024 00000014301 13000274577 023502 0ustar00gknopstaff000000 000000 package ExtUtils::HasCompiler; $ExtUtils::HasCompiler::VERSION = '0.016'; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw/can_compile_loadable_object/; our %EXPORT_TAGS = (all => \@EXPORT_OK); use Config; use Carp 'carp'; use File::Basename 'basename'; use File::Spec::Functions qw/catfile catdir rel2abs/; use File::Temp qw/tempdir tempfile/; my $tempdir = tempdir('HASCOMPILERXXXX', CLEANUP => 1, DIR => '.'); my $loadable_object_format = <<'END'; #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef PERL_UNUSED_VAR #define PERL_UNUSED_VAR(var) #endif XS(exported) { #ifdef dVAR dVAR; #endif dXSARGS; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ XSRETURN_IV(42); } #ifndef XS_EXTERNAL #define XS_EXTERNAL(foo) XS(foo) #endif /* we don't want to mess with .def files on mingw */ #if defined(WIN32) && defined(__GNUC__) # define EXPORT __declspec(dllexport) #else # define EXPORT #endif EXPORT XS_EXTERNAL(boot_%s) { #ifdef dVAR dVAR; #endif dXSARGS; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ newXS("%s::exported", exported, __FILE__); } END my $counter = 1; my %prelinking = map { $_ => 1 } qw/MSWin32 VMS aix/; sub can_compile_loadable_object { my %args = @_; my $output = $args{output} || \*STDOUT; my $config = $args{config} || 'ExtUtils::HasCompiler::Config'; return if not $config->get('usedl'); my ($source_handle, $source_name) = tempfile('TESTXXXX', DIR => $tempdir, SUFFIX => '.c', UNLINK => 1); my $basename = basename($source_name, '.c'); my $shortname = '_Loadable' . $counter++; my $package = "ExtUtils::HasCompiler::$shortname"; printf $source_handle $loadable_object_format, $basename, $package or do { carp "Couldn't write to $source_name: $!"; return }; close $source_handle or do { carp "Couldn't close $source_name: $!"; return }; my $abs_basename = catfile($tempdir, $basename); my $object_file = $abs_basename . $config->get('_o'); my $loadable_object = $abs_basename . '.' . $config->get('dlext'); my $incdir = catdir($config->get('archlibexp'), 'CORE'); my ($cc, $ccflags, $optimize, $cccdlflags, $ld, $ldflags, $lddlflags, $libperl, $perllibs) = map { $config->get($_) } qw/cc ccflags optimize cccdlflags ld ldflags lddlflags libperl perllibs/; if ($prelinking{$^O}) { require ExtUtils::Mksymlists; ExtUtils::Mksymlists::Mksymlists(NAME => $basename, FILE => $abs_basename, IMPORTS => {}); } my @commands; if ($^O eq 'MSWin32' && $cc =~ /^cl/) { push @commands, qq{$cc $ccflags $cccdlflags $optimize /I "$incdir" /c $source_name /Fo$object_file}; push @commands, qq{$ld $object_file $lddlflags $libperl $perllibs /out:$loadable_object /def:$abs_basename.def /pdb:$abs_basename.pdb}; } elsif ($^O eq 'VMS') { # Mksymlists is only the beginning of the story. open my $opt_fh, '>>', "$abs_basename.opt" or do { carp "Couldn't append to '$abs_basename.opt'"; return }; print $opt_fh "PerlShr/Share\n"; close $opt_fh; my $incdirs = $ccflags =~ s{ /inc[^=]+ (?:=)+ (?:\()? ( [^\/\)]* ) }{}xi ? "$1,$incdir" : $incdir; push @commands, qq{$cc $ccflags $optimize /include=($incdirs) $cccdlflags $source_name /obj=$object_file}; push @commands, qq{$ld $ldflags $lddlflags=$loadable_object $object_file,$abs_basename.opt/OPTIONS,${incdir}perlshr_attr.opt/OPTIONS' $perllibs}; } else { my @extra; if ($^O eq 'MSWin32') { my $lib = '-l' . ($libperl =~ /lib([^.]+)\./)[0]; push @extra, "$abs_basename.def", $lib, $perllibs; } elsif ($^O eq 'cygwin') { push @extra, catfile($incdir, $config->get('useshrplib') ? 'libperl.dll.a' : 'libperl.a'); } elsif ($^O eq 'aix') { $lddlflags =~ s/\Q$(BASEEXT)\E/$abs_basename/; $lddlflags =~ s/\Q$(PERL_INC)\E/$incdir/; } elsif ($^O eq 'android') { push @extra, qq{"-L$incdir"}, '-lperl', $perllibs; } push @commands, qq{$cc $ccflags $optimize "-I$incdir" $cccdlflags -c $source_name -o $object_file}; push @commands, qq{$ld $optimize $object_file -o $loadable_object $lddlflags @extra}; } for my $command (@commands) { print $output "$command\n" if not $args{quiet}; system $command and do { carp "Couldn't execute $command: $!"; return }; } # Skip loading when cross-compiling return 1 if exists $args{skip_load} ? $args{skip_load} : $config->get('usecrosscompile'); require DynaLoader; local @DynaLoader::dl_require_symbols = "boot_$basename"; my $handle = DynaLoader::dl_load_file(rel2abs($loadable_object), 0); if ($handle) { my $symbol = DynaLoader::dl_find_symbol($handle, "boot_$basename") or do { carp "Couldn't find boot symbol for $basename"; return }; my $compilet = DynaLoader::dl_install_xsub('__ANON__::__ANON__', $symbol, $source_name); my $ret = eval { $compilet->(); $package->exported } or carp $@; delete $ExtUtils::HasCompiler::{"$shortname\::"}; eval { DynaLoader::dl_unload_file($handle) } or carp $@; return defined $ret && $ret == 42; } else { carp "Couldn't load $loadable_object: " . DynaLoader::dl_error(); return; } } sub ExtUtils::HasCompiler::Config::get { my (undef, $key) = @_; return $ENV{uc $key} || $Config{$key}; } 1; # ABSTRACT: Check for the presence of a compiler __END__ =pod =encoding UTF-8 =head1 NAME ExtUtils::HasCompiler - Check for the presence of a compiler =head1 VERSION version 0.016 =head1 DESCRIPTION This module tries to check if the current system is capable of compiling, linking and loading an XS module. B: this is an early release, interface stability isn't guaranteed yet. =head1 FUNCTIONS =head2 can_compile_loadable_object(%opts) This checks if the system can compile, link and load a perl loadable object. It may take the following options: =over 4 =item * quiet Do not output the executed compilation commands. =item * config An L (compatible) object for configuration. =item * skip_load This causes can_compile_loadable_object to not try to load the generated object. This defaults to true on a cross-compiling perl. =back =head1 AUTHOR Leon Timmermans =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014 by Leon Timmermans. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut