X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fstrictures.pm;h=a715c60b7184f231ab3f2e79ae890345fca136e7;hb=07dc8b03715dd0cb8236a75d52481e21344e36df;hp=a865d7736aff1ddf789d20a27d3d8d1a32653255;hpb=8f0df510535f01d82740865bf25e3fc29631c772;p=p5sagit%2Fstrictures.git diff --git a/lib/strictures.pm b/lib/strictures.pm index a865d77..a715c60 100644 --- a/lib/strictures.pm +++ b/lib/strictures.pm @@ -7,8 +7,80 @@ BEGIN { *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0}; } -our $VERSION = '1.005006'; +our $VERSION = '1.999_001'; $VERSION = eval $VERSION; +$VERSION = 2; # a bit of a cheat, but requesting v2 needs to be possible + +our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw( + closure + deprecated + exiting + experimental + experimental::autoderef + experimental::const_attr + experimental::lexical_subs + experimental::lexical_topic + experimental::postderef + experimental::re_strict + experimental::refaliasing + experimental::regex_sets + experimental::signatures + experimental::smartmatch + experimental::win32_perlio + glob + imprecision + io + closed + exec + layer + newline + pipe + syscalls + unopened + locale + misc + missing + numeric + once + overflow + pack + portable + recursion + redefine + redundant + regexp + severe + debugging + inplace + internal + malloc + signal + substr + syntax + ambiguous + bareword + digit + illegalproto + parenthesis + precedence + printf + prototype + qw + reserved + semicolon + taint + threads + uninitialized + unpack + untie + utf8 + non_unicode + nonchar + surrogate + void + void_unusual + y2k +); sub VERSION { no warnings; @@ -33,6 +105,7 @@ sub import { = exists $^H{strictures_enable} ? delete $^H{strictures_enable} : int $VERSION; } + $opts{file} = (caller)[1]; $class->_enable(\%opts); } @@ -43,44 +116,92 @@ sub _enable { if !defined $version; my $method = "_enable_$version"; if (!$class->can($method)) { - die "Major version specified as $version - not supported!"; + require Carp; + Carp::croak("Major version specified as $version - not supported!"); } $class->$method($opts); } sub _enable_1 { + my ($class, $opts) = @_; strict->import; warnings->import(FATAL => 'all'); - _load_extras(qw(indirect multidimensional bareword::filehandles)) - or return; - indirect->unimport(':fatal') if $extra_load_states{indirect}; - multidimensional->unimport if $extra_load_states{multidimensional}; - bareword::filehandles->unimport if $extra_load_states{'bareword::filehandles'}; + 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 _load_extras { - my @extras = @_; - 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(4))[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' )) - )) +our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } ( + 'exec', # not safe to catch + 'recursion', # will be caught by other mechanisms + 'internal', # not safe to catch + 'malloc', # not safe to catch + 'newline', # stat on nonexistent file with a newline in it + 'experimental', # no reason for these to be fatal + 'deprecated', # unfortunately can't make these fatal + 'portable', # everything worked fine here, just may not elsewhere +); +our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } ( + 'once' # triggers inconsistently, can't be fatalized +); + +sub _enable_2 { + my ($class, $opts) = @_; + strict->import; + warnings->import; + warnings->import(FATAL => @WARNING_CATEGORIES); + warnings->unimport(FATAL => @V2_NONFATAL); + warnings->import(@V2_NONFATAL); + warnings->unimport(@V2_DISABLE); + + 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"; } - }; - return - unless $extra_tests; + 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 @@ -111,7 +232,6 @@ of a strictures-using module you need to run: but these modules are not required by your users. EOE } - return $extra_tests; } 1; @@ -123,12 +243,23 @@ strictures - turn on strict and make all warnings fatal =head1 SYNOPSIS - use strictures 1; + use strictures 2; is equivalent to use strict; use warnings FATAL => 'all'; + use warnings NONFATAL => qw( + exec + recursion + internal + malloc + newline + experimental + deprecated + portable + ); + no warnings 'once'; except when called from a file which matches: @@ -139,14 +270,8 @@ and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory 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; +set, in which case it also does the equivalent of -is equivalent to - - use strict; - use warnings FATAL => 'all'; no indirect 'fatal'; no multidimensional; no bareword::filehandles; @@ -189,20 +314,109 @@ 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 -when its version is tested to ensure that +=head1 CATEGORY SELECTIONS + +strictures does not enable fatal warnings for all categories. + +=over 4 + +=item exec + +Includes a warning that can cause your program to continue running +unintentionally after an internal fork. Not safe to fatalize. + +=item recursion + +Infinite recursion will end up overflowing the stack eventually anyway. + +=item internal + +Triggers deep within perl, in places that are not safe to trap. + +=item malloc + +Triggers deep within perl, in places that are not safe to trap. + +=item newline - use strictures 1; +Includes a warning for using stat on a valid but suspect filename, ending in a +newline. -will continue to only introduce the current set of strictures even if 2.0 is -installed. +=item experimental + +Experimental features are used intentionally. + +=item deprecated + +Deprecations will inherently be added to in the future in unexpected ways, +so making them fatal won't be reliable. + +=item portable + +Doesn't indicate an actual problem with the program, only that it may not +behave properly if run on a different machine. + +=item once + +Can't be fatalized. Also triggers very inconsistently, so we just disable it. + +=back + +=head1 VERSIONS + +Depending on the version of strictures requested, different warnings will be +enabled. If no specific version is requested, the current version's behavior +will be used. Versions can be requested using perl's standard mechanism: + + use strictures 2; + +Or, by passing in a C option: + + use strictures version => 2; + +=head2 VERSION 2 + +Equivalent to: + + use strict; + use warnings FATAL => 'all'; + use warnings NONFATAL => qw( + exec + recursion + internal + malloc + newline + experimental + deprecated + portable + ); + no warnings 'once'; + + # and if in dev mode: + no indirect 'fatal'; + no multidimensional; + no bareword::filehandles; + +Additionally, any warnings created by modules using L or +C will not be fatalized. + +=head2 VERSION 1 + +Equivalent to: + + use strict; + use warnings FATAL => 'all'; + # and if in dev mode: + no indirect 'fatal'; + no multidimensional; + no bareword::filehandles; =head1 METHODS =head2 import -This method does the setup work described above in L +This method does the setup work described above in L. Optionally +accepts a C option to request a specific version's behavior. =head2 VERSION