Pureperlize
Peter Rabbitson [Mon, 2 Apr 2012 16:23:36 +0000 (18:23 +0200)]
Changes
Makefile.PL
lib/Devel/GlobalDestruction.pm
t/01_basic.t
t/02_thread.t
t/10_pure-perl.t [new file with mode: 0644]

diff --git a/Changes b/Changes
index 44e7e88..43b9663 100644 (file)
--- 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).
index 34baa98..caafb55 100644 (file)
-#!/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;
+}
index cbfd5aa..f807d0e 100644 (file)
@@ -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 E<lt>rafl@debian.orgE<gt>
 
 Jesse Luehrs E<lt>doy@tozt.netE<gt>
 
+Peter Rabbitson E<lt>ribasushi@cpan.orgE<gt>
+
 =head1 COPYRIGHT
 
     Copyright (c) 2008 Yuval Kogman. All rights reserved
@@ -92,5 +136,3 @@ Jesse Luehrs E<lt>doy@tozt.netE<gt>
     it and/or modify it under the same terms as Perl itself.
 
 =cut
-
-
index 8584247..5a6bdcf 100644 (file)
@@ -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;
index 0f26b0a..ee4cf33 100644 (file)
@@ -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 (file)
index 0000000..841073a
--- /dev/null
@@ -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");
+}
+