factor out env check from file check

[p5sagit/strictures.git] / lib / strictures.pm

diff --git a/lib/strictures.pm b/lib/strictures.pm
index c7ee8fb..f14f7e9 100644 (file)
--- a/lib/strictures.pm
+++ b/lib/strictures.pm
@@ -11,63 +11,108 @@ our $VERSION = '1.005006';
 $VERSION = eval $VERSION;
 
 sub VERSION {
-  my ($class, $version) = @_;
-  for ($version) {
-    last unless defined && !ref && int != 1;
-    die "Major version specified as $_ - this is strictures version 1";
+  no warnings;
+  local $@;
+  if (defined $_[1] && eval { $_[0]->UNIVERSAL::VERSION($_[1]); 1}) {
+    $^H |= 0x20000
+      unless _PERL_LT_5_8_4;
+    $^H{strictures_enable} = int $_[1];
   }
-  # passing undef here may either warn or die depending on the version of perl.
-  # we can't match the caller's warning state in this case, so just disable the
-  # warning.
-  no warnings 'uninitialized';
-  shift->SUPER::VERSION(@_);
+  goto &UNIVERSAL::VERSION;
 }
 
-our $extra_load_states;
+our %extra_load_states;
 
 our $Smells_Like_VCS;
 
 sub import {
+  my $class = shift;
+  my %opts = ref $_[0] ? %{$_[0]} : @_;
+  if (!exists $opts{version}) {
+    $opts{version}
+      = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
+      : int $VERSION;
+  }
+  $opts{file} = (caller)[1];
+  $class->_enable(\%opts);
+}
+
+sub _enable {
+  my ($class, $opts) = @_;
+  my $version = $opts->{version};
+  $version = 'undef'
+    if !defined $version;
+  my $method = "_enable_$version";
+  if (!$class->can($method)) {
+    die "Major version specified as $version - not supported!";
+  }
+  $class->$method($opts);
+}
+
+sub _enable_1 {
+  my ($class, $opts) = @_;
   strict->import;
   warnings->import(FATAL => 'all');
 
-  my $extra_tests = do {
-    if (exists $ENV{PERL_STRICTURES_EXTRA}) {
-      if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
-        die 'PERL_STRICTURES_EXTRA checks are not available on perls older than 5.8.4: '
-          . "please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
-      }
-      $ENV{PERL_STRICTURES_EXTRA};
-    } elsif (! _PERL_LT_5_8_4) {
-      (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
-        and defined $Smells_Like_VCS ? $Smells_Like_VCS
-          : ( $Smells_Like_VCS = !!(
-            -e '.git' || -e '.svn' || -e '.hg'
-            || (-e '../../dist.ini'
-              && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' ))
-          ))
+  if (_want_extra($opts->{file})) {
+    _load_extras(qw(indirect multidimensional bareword::filehandles));
+    indirect->unimport(':fatal')
+      if $extra_load_states{indirect};
+    multidimensional->unimport
+      if $extra_load_states{multidimensional};
+    bareword::filehandles->unimport
+      if $extra_load_states{'bareword::filehandles'};
+  }
+}
+
+sub _want_extra_env {
+  if (exists $ENV{PERL_STRICTURES_EXTRA}) {
+    if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
+      die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
+        . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
     }
-  };
-  if ($extra_tests) {
-    $extra_load_states ||= do {
-
-      my (%rv, @failed);
-      foreach my $mod (qw(indirect multidimensional bareword::filehandles)) {
-        eval "require $mod; \$rv{'$mod'} = 1;" or do {
-          push @failed, $mod;
-
-          # courtesy of the 5.8 require bug
-          # (we do a copy because 5.16.2 at least uses the same read-only
-          # scalars for the qw() list and it doesn't seem worth a $^V check)
-
-          (my $file = $mod) =~ s|::|/|g;
-          delete $INC{"${file}.pm"};
-        };
-      }
-
-      if (@failed) {
-        my $failed = join ' ', @failed;
-        print STDERR <<EOE;
+    return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
+  }
+  return undef;
+}
+
+sub _want_extra {
+  my $file = shift;
+  my $want_env = _want_extra_env();
+  return $want_env
+    if defined $want_env;
+  return (
+    !_PERL_LT_5_8_4
+    and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
+    and defined $Smells_Like_VCS ? $Smells_Like_VCS
+      : ( $Smells_Like_VCS = !!(
+        -e '.git' || -e '.svn' || -e '.hg'
+        || (-e '../../dist.ini'
+          && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' ))
+      ))
+  );
+}
+
+sub _load_extras {
+  my @extras = @_;
+  my @failed;
+  foreach my $mod (@extras) {
+    next
+      if exists $extra_load_states{$mod};
+
+    $extra_load_states{$mod} = eval "require $mod; 1;" or do {
+      push @failed, $mod;
+
+      #work around 5.8 require bug
+      (my $file = $mod) =~ s|::|/|g;
+      delete $INC{"${file}.pm"};
+    };
+  }
+
+  if (@failed) {
+    my $failed = join ' ', @failed;
+    my $extras = join ' ', @extras;
+    print STDERR <<EOE;
 strictures.pm extra testing active but couldn't load all modules. Missing were:
 
   $failed
@@ -75,18 +120,10 @@ strictures.pm extra testing active but couldn't load all modules. Missing were:
 Extra testing is auto-enabled in checkouts only, so if you're the author
 of a strictures-using module you need to run:
 
-  cpan indirect multidimensional bareword::filehandles
+  cpan $extras
 
 but these modules are not required by your users.
 EOE
-      }
-
-      \%rv;
-    };
-
-    indirect->unimport(':fatal') if $extra_load_states->{indirect};
-    multidimensional->unimport if $extra_load_states->{multidimensional};
-    bareword::filehandles->unimport if $extra_load_states->{'bareword::filehandles'};
   }
 }