From f32316822712b6396354491ef7d8dd4f57d06caa Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 11:38:13 +0000 Subject: perl-Devel-GlobalDestruction-0.14 base --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..40d3b47 --- /dev/null +++ b/Changes @@ -0,0 +1,59 @@ +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. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..2f6d6be --- /dev/null +++ b/MANIFEST @@ -0,0 +1,16 @@ +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) diff --git a/META.json b/META.json new file mode 100644 index 0000000..4c9285f --- /dev/null +++ b/META.json @@ -0,0 +1,61 @@ +{ + "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" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..d17c84c --- /dev/null +++ b/META.yml @@ -0,0 +1,34 @@ +--- +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' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..c96b972 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,118 @@ +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 ########################################################### diff --git a/README b/README new file mode 100644 index 0000000..d6114b1 --- /dev/null +++ b/README @@ -0,0 +1,56 @@ +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. + diff --git a/inc/ExtUtils/HasCompiler.pm b/inc/ExtUtils/HasCompiler.pm new file mode 100644 index 0000000..7eba9fd --- /dev/null +++ b/inc/ExtUtils/HasCompiler.pm @@ -0,0 +1,217 @@ +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 diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm new file mode 100644 index 0000000..2468b45 --- /dev/null +++ b/lib/Devel/GlobalDestruction.pm @@ -0,0 +1,110 @@ +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 diff --git a/maint/Makefile.PL.include b/maint/Makefile.PL.include new file mode 100644 index 0000000..ce8f2e2 --- /dev/null +++ b/maint/Makefile.PL.include @@ -0,0 +1,19 @@ +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; diff --git a/t/01_basic.t b/t/01_basic.t new file mode 100644 index 0000000..c8d847f --- /dev/null +++ b/t/01_basic.t @@ -0,0 +1,79 @@ +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 } diff --git a/t/02_thread.t b/t/02_thread.t new file mode 100644 index 0000000..196cd0a --- /dev/null +++ b/t/02_thread.t @@ -0,0 +1,51 @@ +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++; diff --git a/t/03_minusc.t b/t/03_minusc.t new file mode 100644 index 0000000..0bb43ff --- /dev/null +++ b/t/03_minusc.t @@ -0,0 +1,48 @@ +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); + }; + }); +} diff --git a/t/04_phases.t b/t/04_phases.t new file mode 100644 index 0000000..db54492 --- /dev/null +++ b/t/04_phases.t @@ -0,0 +1,57 @@ +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') } diff --git a/t/05_thread_clone.t b/t/05_thread_clone.t new file mode 100644 index 0000000..f2c939f --- /dev/null +++ b/t/05_thread_clone.t @@ -0,0 +1,78 @@ +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++; diff --git a/t/06_load-in-gd.t b/t/06_load-in-gd.t new file mode 100644 index 0000000..574c29d --- /dev/null +++ b/t/06_load-in-gd.t @@ -0,0 +1,33 @@ +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"); +} diff --git a/t/10_pure-perl.t b/t/10_pure-perl.t new file mode 100644 index 0000000..3246c03 --- /dev/null +++ b/t/10_pure-perl.t @@ -0,0 +1,40 @@ +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"); +}