X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2Fstrictures.git;a=blobdiff_plain;f=lib%2Fstrictures.pm;h=f14f7e9e0daea9309b5555bbef363992e3e7e63c;hp=63ce90e2f79700e812073c05e206ff3fb4c39bae;hb=9d763997aceafbe007f36a847780a2d0293f3468;hpb=9668cbf1426fdd545095e1e4a691ab9b917a4bb3 diff --git a/lib/strictures.pm b/lib/strictures.pm index 63ce90e..f14f7e9 100644 --- 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 <unimport(':fatal') if $extra_load_states->{indirect}; - multidimensional->unimport if $extra_load_states->{multidimensional}; - bareword::filehandles->unimport if $extra_load_states->{'bareword::filehandles'}; } } @@ -110,11 +147,12 @@ except when called from a file which matches: (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/ -and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory (with -the intention of only forcing extra tests on the author side) -- or when C<.git>, -C<.svn>, or C<.hg> is present two directories up along with C (which would -indicate we are in a C operation, via L) -- -or when the C environment variable is set, in which case +and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory +(with the intention of only forcing extra tests on the author side) -- or when +C<.git>, C<.svn>, or C<.hg> is present two directories up along with +C (which would indicate we are in a C operation, via +L) -- or when the C environment variable is +set, in which case use strictures 1; @@ -126,9 +164,9 @@ is equivalent to no multidimensional; no bareword::filehandles; -Note that C may at some point add even more tests, with only a minor -version increase, but any changes to the effect of C in -normal mode will involve a major version bump. +Note that C may at some point add even more tests, with +only a minor version increase, but any changes to the effect of C in normal mode will involve a major version bump. If any of the extra testing modules are not present, L will complain loudly, once, via C, and then shut up. But you really @@ -159,10 +197,10 @@ undesired behaviour this can be overridden by setting the C environment variable. If additional useful author side checks come to mind, I'll add them to the -C code path only -- this will result in a minor version increase (e.g. -1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the mechanism of -this code will result in a sub-version increase (e.g. 1.000000 to 1.000001 -(1.0.1)). +C code path only -- this will result in a minor version +increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the +mechanism of this code will result in a sub-version increase (e.g. 1.000000 to +1.000001 (1.0.1)). If the behaviour of C in normal mode changes in any way, that will constitute a major version increase -- and the code already checks @@ -234,9 +272,9 @@ significantly over time, especially for 1.004 where we changed things to ensure it only fires on files in your checkout (rather than L-using modules you happened to have installed, which was just silly). However, I hope the above clarifies why a heuristic approach is not only necessary but -desirable from a point of view of providing new users with as much safety as possible, -and will allow any future discussion on the subject to focus on "how do we -minimise annoyance to people deploying from checkouts intentionally". +desirable from a point of view of providing new users with as much safety as +possible, and will allow any future discussion on the subject to focus on "how +do we minimise annoyance to people deploying from checkouts intentionally". =head1 SEE ALSO