From: Peter Rabbitson Date: Mon, 2 Apr 2012 16:23:36 +0000 (+0200) Subject: Pureperlize X-Git-Tag: Devel-GlobalDestruction-0.05~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9aaf36461a79c118c35f3bf546933fefbd9bfd35;p=p5sagit%2FDevel-GlobalDestruction.git Pureperlize --- diff --git a/Changes b/Changes index 44e7e88..43b9663 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,6 @@ + * 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). diff --git a/Makefile.PL b/Makefile.PL index 34baa98..caafb55 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,20 +1,170 @@ -#!/usr/bin/perl -w - use strict; +use warnings; + require 5.006000; use ExtUtils::MakeMaker; +BEGIN { if ( $^O eq 'cygwin' ) { + require ExtUtils::MM_Cygwin; + require ExtUtils::MM_Win32; + if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { + *ExtUtils::MM_Cygwin::maybe_command = sub { + my ($self, $file) = @_; + if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { + ExtUtils::MM_Win32->maybe_command($file); + } else { + ExtUtils::MM_Unix->maybe_command($file); + } + } + } +}} + +my $mymeta_works = eval { ExtUtils::MakeMaker->VERSION('6.5707'); 1 }; +my $mymeta = $mymeta_works || eval { ExtUtils::MakeMaker->VERSION('6.5702'); 1 }; + +my %META_BITS = ( +); +my %RUN_DEPS = ( + 'Sub::Exporter' => 0, +); -WriteMakefile( - NAME => 'Devel::GlobalDestruction', - VERSION_FROM => 'lib/Devel/GlobalDestruction.pm', - INSTALLDIRS => 'site', - SIGN => 1, - PL_FILES => { }, - MIN_PERL_VERSION => '5.006000', - PREREQ_PM => { - 'Sub::Exporter' => 0, +my %WriteMakefileArgs = ( + NAME => 'Devel::GlobalDestruction', + VERSION_FROM => 'lib/Devel/GlobalDestruction.pm', + LICENSE => 'perl', + INSTALLDIRS => 'site', + PL_FILES => { }, + MIN_PERL_VERSION => '5.006000', + PREREQ_PM => \%RUN_DEPS, + CONFIGURE_REQUIRES => { 'ExtUtils::CBuilder' => 0.27 }, + META_ADD => { + resources => { + homepage => 'http://search.cpan.org/dist/Devel-Globaldestruction', + repository => 'git://git.shadowcat.co.uk/p5sagit/Devel-Globaldestruction.git', + bugtracker => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Globaldestruction', }, - (defined ${^GLOBAL_PHASE} ? (XS => {}, C => []) : ()), + requires => \%RUN_DEPS, + }, + ($mymeta and !$mymeta_works) ? ( 'NO_MYMETA' => 1 ) : (), + ( (defined ${^GLOBAL_PHASE} or !can_xs() ) + ? (XS => {}, C => []) + : () + ), ); +unless ( eval { ExtUtils::MakeMaker->VERSION('6.56') } ) { + my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; + my $pp = $WriteMakefileArgs{PREREQ_PM}; + for my $mod ( keys %$br ) { + if ( exists $pp->{$mod} ) { + $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; + } + else { + $pp->{$mod} = $br->{$mod}; + } + } +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION('6.52') }; + +WriteMakefile(%WriteMakefileArgs); + +# can we locate a (the) C compiler +sub can_cc { + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# check if we can run some command +sub can_run { + my ($cmd) = @_; + + return $cmd if -x $cmd; + if (my $found_cmd = MM->maybe_command($cmd)) { + return $found_cmd; + } + + require File::Spec; + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + next if $dir eq ''; + my $abs = File::Spec->catfile($dir, $cmd); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +# Can our C compiler environment build XS files +sub can_xs { + # Do we have the configure_requires checker? + local $@; + eval "require ExtUtils::CBuilder; ExtUtils::CBuilder->VERSION(0.27)"; + if ( $@ ) { + # They don't obey configure_requires, so it is + # someone old and delicate. Try to avoid hurting + # them by falling back to an older simpler test. + return can_cc(); + } + + # Do we have a working C compiler + my $builder = ExtUtils::CBuilder->new( + quiet => 1, + ); + unless ( $builder->have_compiler ) { + # No working C compiler + return 0; + } + + # Write a C file representative of what XS becomes + require File::Temp; + my ( $FH, $tmpfile ) = File::Temp::tempfile( + "compilexs-XXXXX", + SUFFIX => '.c', + ); + binmode $FH; + print $FH <<'END_C'; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +int main(int argc, char **argv) { + return 0; +} + +int boot_sanexs() { + return 1; +} + +END_C + close $FH; + + # Can the C compiler access the same headers XS does + my @libs = (); + my $object = undef; + eval { + local $^W = 0; + $object = $builder->compile( + source => $tmpfile, + ); + @libs = $builder->link( + objects => $object, + module_name => 'sanexs', + ); + }; + my $result = $@ ? 0 : 1; + + # Clean up all the build files + foreach ( $tmpfile, $object, @libs ) { + next unless defined $_; + 1 while unlink; + } + + return $result; +} diff --git a/lib/Devel/GlobalDestruction.pm b/lib/Devel/GlobalDestruction.pm index cbfd5aa..f807d0e 100644 --- a/lib/Devel/GlobalDestruction.pm +++ b/lib/Devel/GlobalDestruction.pm @@ -1,12 +1,8 @@ -#!/usr/bin/perl - package Devel::GlobalDestruction; use strict; use warnings; -use XSLoader; - our $VERSION = '0.04'; use Sub::Exporter -setup => { @@ -17,15 +13,61 @@ use Sub::Exporter -setup => { if (defined ${^GLOBAL_PHASE}) { eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }'; } -else { +elsif (eval { + require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); + 1; +}) { + # the eval already installed everything, nothing to do } +else { + eval <<'PP_IGD' or die $@; -__PACKAGE__ +my ($in_global_destruction, $before_is_installed); -__END__ +sub in_global_destruction { $in_global_destruction } + +END { + # SpeedyCGI runs END blocks every cycle but somehow keeps object instances + # hence lying about it seems reasonable...ish + $in_global_destruction = 1 unless $CGI::SpeedyCGI::i_am_speedy; +} + +# threads do not execute the global ENDs (it would be stupid). However +# one can register a new END via simple string eval within a thread, and +# achieve the same result. A logical place to do this would be CLONE, which +# is claimed to run in the context of the new thread. However this does +# not really seem to be the case - any END evaled in a CLONE is ignored :( +# Hence blatantly hooking threads::create + +if ($INC{'threads.pm'}) { + my $orig_create = threads->can('create'); + no warnings 'redefine'; + *threads::create = sub { + { local $@; eval 'END { $in_global_destruction = 1 }' }; + goto $orig_create; + }; + $before_is_installed = 1; +} + +# just in case threads got loaded after us (silly) +sub CLONE { + unless ($before_is_installed) { + require Carp; + Carp::croak("You must load the 'threads' module before @{[ __PACKAGE__ ]}"); + } +} -=pod +1; # keep eval happy + +PP_IGD + +} + +1; # keep require happy + + +__END__ =head1 NAME @@ -85,6 +127,8 @@ Florian Ragwitz Erafl@debian.orgE Jesse Luehrs Edoy@tozt.netE +Peter Rabbitson Eribasushi@cpan.orgE + =head1 COPYRIGHT Copyright (c) 2008 Yuval Kogman. All rights reserved @@ -92,5 +136,3 @@ Jesse Luehrs Edoy@tozt.netE it and/or modify it under the same terms as Perl itself. =cut - - diff --git a/t/01_basic.t b/t/01_basic.t index 8584247..5a6bdcf 100644 --- a/t/01_basic.t +++ b/t/01_basic.t @@ -1,9 +1,17 @@ use strict; use warnings; -# we need to run a test in GD and this fails -# use Test::More tests => 3; -# use ok 'Devel::GlobalDestruction'; +BEGIN { + if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { + require DynaLoader; + no warnings 'redefine'; + my $orig = \&DynaLoader::bootstrap; + *DynaLoader::bootstrap = sub { + die 'no XS' if $_[0] eq 'Devel::GlobalDestruction'; + goto $orig; + }; + } +} BEGIN { package Test::Scope::Guard; diff --git a/t/02_thread.t b/t/02_thread.t index 0f26b0a..ee4cf33 100644 --- a/t/02_thread.t +++ b/t/02_thread.t @@ -17,6 +17,18 @@ use threads; use warnings; use strict; +BEGIN { + if ($ENV{DEVEL_GLOBALDESTRUCTION_PP_TEST}) { + require DynaLoader; + no warnings 'redefine'; + my $orig = \&DynaLoader::bootstrap; + *DynaLoader::bootstrap = sub { + die 'no XS' if $_[0] eq 'Devel::GlobalDestruction'; + goto $orig; + }; + } +} + my $t = threads->create(sub { do 't/01_basic.t' }); $t->join; diff --git a/t/10_pure-perl.t b/t/10_pure-perl.t new file mode 100644 index 0000000..841073a --- /dev/null +++ b/t/10_pure-perl.t @@ -0,0 +1,38 @@ +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__); + +my @tests = grep { $_ !~ /${this_file}$/ } glob("$Bin/*.t"); +print "1..@{[ scalar @tests ]}\n"; + +sub ok ($$) { + 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"); +} +