X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fstrictures.pm;h=43a6600cfbd8a47ec803667235c8a6dd9dd110fb;hb=1c35787c75148e768b8c61eb9aec45d6b0ea3949;hp=cc1689c61b195d60032aa7faac460abf30645cb3;hpb=d8c1c6b2316b6a4e250f8138bb5b89a6a7fad5a3;p=p5sagit%2Fstrictures.git diff --git a/lib/strictures.pm b/lib/strictures.pm index cc1689c..43a6600 100644 --- a/lib/strictures.pm +++ b/lib/strictures.pm @@ -3,77 +3,220 @@ package strictures; use strict; use warnings FATAL => 'all'; -use constant _PERL_LT_5_8_4 => ($] < 5.008004) ? 1 : 0; +BEGIN { + *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0}; +} -our $VERSION = '1.004001'; # 1.4.1 +our $VERSION = '2.000000'; +$VERSION = eval $VERSION; + +our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw( + closure + deprecated + exiting + experimental + experimental::lexical_subs + experimental::lexical_topic + experimental::regex_sets + experimental::smartmatch + glob + imprecision + io + closed + exec + layer + newline + pipe + unopened + misc + numeric + once + overflow + pack + portable + recursion + redefine + 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 + y2k +); sub VERSION { - for ($_[1]) { - 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]; } - # disable this since Foo->VERSION(undef) correctly returns the version - # and that can happen either if our caller passes undef explicitly or - # because the for above autovivified $_[1] - I could make it stop but - # it's pointless since we don't want to blow up if the caller does - # something valid either. - no warnings 'uninitialized'; - shift->SUPER::VERSION(@_); + goto &UNIVERSAL::VERSION; } -my $extras_load_warned; +our %extra_load_states; -our $Smells_Like_VCS = (-e '.git' || -e '.svn' - || (-e '../../dist.ini' && (-e '../../.git' || -e '../../.svn'))); +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)) { + 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'); - 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 $Smells_Like_VCS) - } - }; - if ($extra_tests) { - my @failed; - if (eval { require indirect; 1 }) { - indirect->unimport(':fatal'); - } else { - push @failed, 'indirect'; - } - if (eval { require multidimensional; 1 }) { - multidimensional->unimport; - } else { - push @failed, 'multidimensional'; - } - if (eval { require bareword::filehandles; 1 }) { - bareword::filehandles->unimport; - } else { - push @failed, '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'}; + } +} + +our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } qw( + exec + recursion + internal + malloc + newline + experimental + deprecated + portable +); +our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } qw( + once +); + +sub _enable_2 { + my ($class, $opts) = @_; + strict->import; + warnings->import; + warnings->import(FATAL => @WARNING_CATEGORIES); + warnings->import(NONFATAL => @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"; } - if (@failed and not $extras_load_warned++) { - my $failed = join ' ', @failed; - warn < 'all'; + use warnings NONFATAL => qw( + exec + recursion + internal + malloc + newline + experimental + deprecated + portable + ); + no warnings 'once'; except when called from a file which matches: - (caller)[1] =~ /^(?:t|xt|lib|blib)/ + (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/ -and when either C<.git> or C<.svn> is present in the current directory (with -the intention of only forcing extra tests on the author side) -- or when C<.git> -or C<.svn> 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; + 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'; no indirect 'fatal'; 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 @@ -128,7 +294,7 @@ about a year now. I figured it was time to make it shorter. Things like the importer in C don't help me because they turn warnings on but don't make them fatal -- which from my point of view is -useless because I want an exception to tell me my code isn't warnings clean. +useless because I want an exception to tell me my code isn't warnings-clean. Any time I see a warning from my code, that indicates a mistake. @@ -141,30 +307,57 @@ as such) get caught, but not at the cost of an XS dependency and not at the cost of blowing things up on another machine. Therefore, L turns on additional checking, but only when it thinks -it's running in a test file in a VCS checkout -- though if this causes +it's running in a test file in a VCS checkout -- although if this causes 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 (i.e. -1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the mechanism of -this code will result in a subversion increas (i.e. 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)). + +=head1 VERSIONS -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 +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 1; + use strictures 2; -will continue to only introduce the current set of strictures even if 2.0 is -installed. +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 => 'deprecated', 'experimental'; + # and if in dev mode: + no indirect 'fatal'; + no multidimensional; + no bareword::filehandles; + +=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 @@ -184,7 +377,7 @@ productive conversation, here's my current rationale for turning the extra testing on via a heuristic: The extra testing is all stuff that only ever blows up at compile time; -this is intentional. So the oft raised concern that it's different code being +this is intentional. So the oft-raised concern that it's different code being tested is only sort of the case -- none of the modules involved affect the final optree to my knowledge, so the author gets some additional compile time crashes which he/she then fixes, and the rest of the testing is @@ -205,7 +398,7 @@ differences between the production and the development environment. I wrote L to explain this particular problem before L itself existed. -As such, in my experience so far the L extra testing has +As such, in my experience so far L' extra testing has I production versus development differences, not caused them. Additionally, L' policy is very much "try and provide as much @@ -221,9 +414,27 @@ 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 POV 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 + +=over 4 + +=item * + +L + +=item * + +L + +=item * + +L + +=back =head1 COMMUNITY AND SUPPORT @@ -249,7 +460,11 @@ mst - Matt S. Trout (cpan:MSTROUT) =head1 CONTRIBUTORS -None required yet. Maybe this module is perfect (hahahahaha ...). +Karen Etheridge (cpan:ETHER) + +Mithaldu - Christian Walde (cpan:MITHALDU) + +haarg - Graham Knop (cpan:HAARG) =head1 COPYRIGHT