4 use warnings FATAL => 'all';
7 *_PERL_LT_5_8_4 = ("$]" < 5.008004) ? sub(){1} : sub(){0};
8 # goto &UNIVERSAL::VERSION usually works on 5.8, but fails on some ARM
9 # machines. Seems to always work on 5.10 though.
10 *_CAN_GOTO_VERSION = ("$]" >= 5.010000) ? sub(){1} : sub(){0};
13 our $VERSION = '2.000005';
16 our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
22 experimental::alpha_assertions
23 experimental::autoderef
25 experimental::const_attr
26 experimental::declared_refs
27 experimental::lexical_subs
28 experimental::lexical_topic
29 experimental::postderef
30 experimental::private_use
31 experimental::re_strict
32 experimental::refaliasing
33 experimental::regex_sets
34 experimental::script_run
35 experimental::signatures
36 experimental::smartmatch
37 experimental::win32_perlio
99 if (defined $_[1] && eval { &UNIVERSAL::VERSION; 1}) {
101 unless _PERL_LT_5_8_4;
102 $^H{strictures_enable} = int $_[1];
105 _CAN_GOTO_VERSION ? goto &UNIVERSAL::VERSION : &UNIVERSAL::VERSION;
108 our %extra_load_states;
110 our $Smells_Like_VCS;
114 my %opts = @_ == 1 ? %{$_[0]} : @_;
115 if (!exists $opts{version}) {
117 = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
120 $opts{file} = (caller)[1];
121 $class->_enable(\%opts);
125 my ($class, $opts) = @_;
126 my $version = $opts->{version};
128 if !defined $version;
129 my $method = "_enable_$version";
130 if (!$class->can($method)) {
132 Carp::croak("Major version specified as $version - not supported!");
134 $class->$method($opts);
138 my ($class, $opts) = @_;
140 warnings->import(FATAL => 'all');
142 if (_want_extra($opts->{file})) {
143 _load_extras(qw(indirect multidimensional bareword::filehandles));
144 indirect->unimport(':fatal')
145 if $extra_load_states{indirect};
146 multidimensional->unimport
147 if $extra_load_states{multidimensional};
148 bareword::filehandles->unimport
149 if $extra_load_states{'bareword::filehandles'};
153 our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } (
154 'exec', # not safe to catch
155 'recursion', # will be caught by other mechanisms
156 'internal', # not safe to catch
157 'malloc', # not safe to catch
158 'newline', # stat on nonexistent file with a newline in it
159 'experimental', # no reason for these to be fatal
160 'deprecated', # unfortunately can't make these fatal
161 'portable', # everything worked fine here, just may not elsewhere
163 our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } (
164 'once' # triggers inconsistently, can't be fatalized
168 my ($class, $opts) = @_;
171 warnings->import(FATAL => @WARNING_CATEGORIES);
172 warnings->unimport(FATAL => @V2_NONFATAL);
173 warnings->import(@V2_NONFATAL);
174 warnings->unimport(@V2_DISABLE);
176 if (_want_extra($opts->{file})) {
177 _load_extras(qw(indirect multidimensional bareword::filehandles));
178 indirect->unimport(':fatal')
179 if $extra_load_states{indirect};
180 multidimensional->unimport
181 if $extra_load_states{multidimensional};
182 bareword::filehandles->unimport
183 if $extra_load_states{'bareword::filehandles'};
187 sub _want_extra_env {
188 if (exists $ENV{PERL_STRICTURES_EXTRA}) {
189 if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
190 die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
191 . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
193 return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
200 my $want_env = _want_extra_env();
202 if defined $want_env;
205 and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
206 and defined $Smells_Like_VCS ? $Smells_Like_VCS
207 : ( $Smells_Like_VCS = !!(
208 -e '.git' || -e '.svn' || -e '.hg' || -e '.bzr'
209 || (-e '../../dist.ini'
210 && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' || -e '../../.bzr' ))
218 foreach my $mod (@extras) {
220 if exists $extra_load_states{$mod};
222 $extra_load_states{$mod} = eval "require $mod; 1;" or do {
225 #work around 5.8 require bug
226 (my $file = $mod) =~ s|::|/|g;
227 delete $INC{"${file}.pm"};
232 my $failed = join ' ', @failed;
233 my $extras = join ' ', @extras;
235 strictures.pm extra testing active but couldn't load all modules. Missing were:
239 Extra testing is auto-enabled in checkouts only, so if you're the author
240 of a strictures-using module you need to run:
244 but these modules are not required by your users.
254 strictures - Turn on strict and make most warnings fatal
263 use warnings FATAL => 'all';
264 use warnings NONFATAL => qw(
276 except when called from a file which matches:
278 (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
280 and when either C<.git>, C<.svn>, C<.hg>, or C<.bzr> is present in the current
281 directory (with the intention of only forcing extra tests on the author side)
282 -- or when C<.git>, C<.svn>, C<.hg>, or C<.bzr> is present two directories up
283 along with C<dist.ini> (which would indicate we are in a C<dzil test> operation,
284 via L<Dist::Zilla>) -- or when the C<PERL_STRICTURES_EXTRA> environment variable
285 is set, in which case it also does the equivalent of
289 no bareword::filehandles;
291 Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with
292 only a minor version increase, but any changes to the effect of C<use
293 strictures> in normal mode will involve a major version bump.
295 If any of the extra testing modules are not present, L<strictures> will
296 complain loudly, once, via C<warn()>, and then shut up. But you really
297 should consider installing them, they're all great anti-footgun tools.
301 I've been writing the equivalent of this module at the top of my code for
302 about a year now. I figured it was time to make it shorter.
304 Things like the importer in C<use Moose> don't help me because they turn
305 warnings on but don't make them fatal -- which from my point of view is
306 useless because I want an exception to tell me my code isn't warnings-clean.
308 Any time I see a warning from my code, that indicates a mistake.
310 Any time my code encounters a mistake, I want a crash -- not spew to STDERR
311 and then unknown (and probably undesired) subsequent behaviour.
313 I also want to ensure that obvious coding mistakes, like indirect object
314 syntax (and not so obvious mistakes that cause things to accidentally compile
315 as such) get caught, but not at the cost of an XS dependency and not at the
316 cost of blowing things up on another machine.
318 Therefore, L<strictures> turns on additional checking, but only when it thinks
319 it's running in a test file in a VCS checkout -- although if this causes
320 undesired behaviour this can be overridden by setting the
321 C<PERL_STRICTURES_EXTRA> environment variable.
323 If additional useful author side checks come to mind, I'll add them to the
324 C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version
325 increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the
326 mechanism of this code will result in a sub-version increase (e.g. 1.000000 to
329 =head1 CATEGORY SELECTIONS
331 strictures does not enable fatal warnings for all categories.
337 Includes a warning that can cause your program to continue running
338 unintentionally after an internal fork. Not safe to fatalize.
342 Infinite recursion will end up overflowing the stack eventually anyway.
346 Triggers deep within perl, in places that are not safe to trap.
350 Triggers deep within perl, in places that are not safe to trap.
354 Includes a warning for using stat on a valid but suspect filename, ending in a
359 Experimental features are used intentionally.
363 Deprecations will inherently be added to in the future in unexpected ways,
364 so making them fatal won't be reliable.
368 Doesn't indicate an actual problem with the program, only that it may not
369 behave properly if run on a different machine.
373 Can't be fatalized. Also triggers very inconsistently, so we just disable it.
379 Depending on the version of strictures requested, different warnings will be
380 enabled. If no specific version is requested, the current version's behavior
381 will be used. Versions can be requested using perl's standard mechanism:
385 Or, by passing in a C<version> option:
387 use strictures version => 2;
394 use warnings FATAL => 'all';
395 use warnings NONFATAL => qw(
407 # and if in dev mode:
410 no bareword::filehandles;
412 Additionally, any warnings created by modules using L<warnings::register> or
413 C<warnings::register_categories()> will not be fatalized.
420 use warnings FATAL => 'all';
421 # and if in dev mode:
424 no bareword::filehandles;
430 This method does the setup work described above in L</DESCRIPTION>. Optionally
431 accepts a C<version> option to request a specific version's behavior.
435 This method traps the C<< strictures->VERSION(1) >> call produced by a use line
436 with a version number on it and does the version check.
438 =head1 EXTRA TESTING RATIONALE
440 Every so often, somebody complains that they're deploying via C<git pull>
441 and that they don't want L<strictures> to enable itself in this case -- and that
442 setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
443 disable extra testing would be welcome but the discussion never seems to get
446 In order to allow us to skip a couple of stages and get straight to a
447 productive conversation, here's my current rationale for turning the
448 extra testing on via a heuristic:
450 The extra testing is all stuff that only ever blows up at compile time;
451 this is intentional. So the oft-raised concern that it's different code being
452 tested is only sort of the case -- none of the modules involved affect the
453 final optree to my knowledge, so the author gets some additional compile
454 time crashes which he/she then fixes, and the rest of the testing is
455 completely valid for all environments.
457 The point of the extra testing -- especially C<no indirect> -- is to catch
458 mistakes that newbie users won't even realise are mistakes without
463 where foo is an & prototyped sub that you forgot to import -- this is
464 pernicious to track down since all I<seems> fine until it gets called
465 and you get a crash. Worse still, you can fail to have imported it due
466 to a circular require, at which point you have a load order dependent
467 bug which I've seen before now I<only> show up in production due to tiny
468 differences between the production and the development environment. I wrote
469 L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
470 this particular problem before L<strictures> itself existed.
472 As such, in my experience so far L<strictures>' extra testing has
473 I<avoided> production versus development differences, not caused them.
475 Additionally, L<strictures>' policy is very much "try and provide as much
476 protection as possible for newbies -- who won't think about whether there's
477 an option to turn on or not" -- so having only the environment variable
478 is not sufficient to achieve that (I get to explain that you need to add
479 C<use strict> at least once a week on freenode #perl -- newbies sometimes
480 completely skip steps because they don't understand that that step
483 I make no claims that the heuristic is perfect -- it's already been evolved
484 significantly over time, especially for 1.004 where we changed things to
485 ensure it only fires on files in your checkout (rather than L<strictures>-using
486 modules you happened to have installed, which was just silly). However, I
487 hope the above clarifies why a heuristic approach is not only necessary but
488 desirable from a point of view of providing new users with as much safety as
489 possible, and will allow any future discussion on the subject to focus on "how
490 do we minimise annoyance to people deploying from checkouts intentionally".
506 L<bareword::filehandles>
510 =head1 COMMUNITY AND SUPPORT
514 irc.perl.org #toolchain
516 (or bug 'mst' in query on there or freenode)
518 =head2 Git repository
520 Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
522 git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
524 The web interface to the repository is at:
526 http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
530 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
534 Karen Etheridge (cpan:ETHER) <ether@cpan.org>
536 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
538 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
542 Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
547 This library is free software and may be distributed under the same terms