4 use warnings FATAL => 'all';
7 *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0};
10 our $VERSION = '2.000000';
11 $VERSION = eval $VERSION;
13 our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
18 experimental::autoderef
19 experimental::lexical_subs
20 experimental::lexical_topic
21 experimental::postderef
22 experimental::regex_sets
23 experimental::signatures
24 experimental::smartmatch
79 if (defined $_[1] && eval { $_[0]->UNIVERSAL::VERSION($_[1]); 1}) {
81 unless _PERL_LT_5_8_4;
82 $^H{strictures_enable} = int $_[1];
84 goto &UNIVERSAL::VERSION;
87 our %extra_load_states;
93 my %opts = ref $_[0] ? %{$_[0]} : @_;
94 if (!exists $opts{version}) {
96 = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
99 $opts{file} = (caller)[1];
100 $class->_enable(\%opts);
104 my ($class, $opts) = @_;
105 my $version = $opts->{version};
107 if !defined $version;
108 my $method = "_enable_$version";
109 if (!$class->can($method)) {
111 Carp::croak("Major version specified as $version - not supported!");
113 $class->$method($opts);
117 my ($class, $opts) = @_;
119 warnings->import(FATAL => 'all');
121 if (_want_extra($opts->{file})) {
122 _load_extras(qw(indirect multidimensional bareword::filehandles));
123 indirect->unimport(':fatal')
124 if $extra_load_states{indirect};
125 multidimensional->unimport
126 if $extra_load_states{multidimensional};
127 bareword::filehandles->unimport
128 if $extra_load_states{'bareword::filehandles'};
132 our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } (
133 'exec', # not safe to catch
134 'recursion', # will be caught by other mechanisms
135 'internal', # not safe to catch
136 'malloc', # not safe to catch
137 'newline', # stat on nonexistent file with a newline in it
138 'experimental', # no reason for these to be fatal
139 'deprecated', # unfortunately can't make these fatal
140 'portable', # everything worked fine here, just may not elsewhere
142 our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } (
143 'once' # triggers inconsistently, can't be fatalized
147 my ($class, $opts) = @_;
150 warnings->import(FATAL => @WARNING_CATEGORIES);
151 warnings->import(NONFATAL => @V2_NONFATAL);
152 warnings->unimport(@V2_DISABLE);
154 if (_want_extra($opts->{file})) {
155 _load_extras(qw(indirect multidimensional bareword::filehandles));
156 indirect->unimport(':fatal')
157 if $extra_load_states{indirect};
158 multidimensional->unimport
159 if $extra_load_states{multidimensional};
160 bareword::filehandles->unimport
161 if $extra_load_states{'bareword::filehandles'};
165 sub _want_extra_env {
166 if (exists $ENV{PERL_STRICTURES_EXTRA}) {
167 if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
168 die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
169 . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
171 return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
178 my $want_env = _want_extra_env();
180 if defined $want_env;
183 and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
184 and defined $Smells_Like_VCS ? $Smells_Like_VCS
185 : ( $Smells_Like_VCS = !!(
186 -e '.git' || -e '.svn' || -e '.hg'
187 || (-e '../../dist.ini'
188 && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' ))
196 foreach my $mod (@extras) {
198 if exists $extra_load_states{$mod};
200 $extra_load_states{$mod} = eval "require $mod; 1;" or do {
203 #work around 5.8 require bug
204 (my $file = $mod) =~ s|::|/|g;
205 delete $INC{"${file}.pm"};
210 my $failed = join ' ', @failed;
211 my $extras = join ' ', @extras;
213 strictures.pm extra testing active but couldn't load all modules. Missing were:
217 Extra testing is auto-enabled in checkouts only, so if you're the author
218 of a strictures-using module you need to run:
222 but these modules are not required by your users.
232 strictures - turn on strict and make all warnings fatal
241 use warnings FATAL => 'all';
242 use warnings NONFATAL => qw(
254 except when called from a file which matches:
256 (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
258 and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory
259 (with the intention of only forcing extra tests on the author side) -- or when
260 C<.git>, C<.svn>, or C<.hg> is present two directories up along with
261 C<dist.ini> (which would indicate we are in a C<dzil test> operation, via
262 L<Dist::Zilla>) -- or when the C<PERL_STRICTURES_EXTRA> environment variable is
270 use warnings FATAL => 'all';
271 use warnings NONFATAL => qw(
284 no bareword::filehandles;
286 Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with
287 only a minor version increase, but any changes to the effect of C<use
288 strictures> in normal mode will involve a major version bump.
290 If any of the extra testing modules are not present, L<strictures> will
291 complain loudly, once, via C<warn()>, and then shut up. But you really
292 should consider installing them, they're all great anti-footgun tools.
296 I've been writing the equivalent of this module at the top of my code for
297 about a year now. I figured it was time to make it shorter.
299 Things like the importer in C<use Moose> don't help me because they turn
300 warnings on but don't make them fatal -- which from my point of view is
301 useless because I want an exception to tell me my code isn't warnings-clean.
303 Any time I see a warning from my code, that indicates a mistake.
305 Any time my code encounters a mistake, I want a crash -- not spew to STDERR
306 and then unknown (and probably undesired) subsequent behaviour.
308 I also want to ensure that obvious coding mistakes, like indirect object
309 syntax (and not so obvious mistakes that cause things to accidentally compile
310 as such) get caught, but not at the cost of an XS dependency and not at the
311 cost of blowing things up on another machine.
313 Therefore, L<strictures> turns on additional checking, but only when it thinks
314 it's running in a test file in a VCS checkout -- although if this causes
315 undesired behaviour this can be overridden by setting the
316 C<PERL_STRICTURES_EXTRA> environment variable.
318 If additional useful author side checks come to mind, I'll add them to the
319 C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version
320 increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the
321 mechanism of this code will result in a sub-version increase (e.g. 1.000000 to
326 Depending on the version of strictures requested, different warnings will be
327 enabled. If no specific version is requested, the current version's behavior
328 will be used. Versions can be requested using perl's standard mechanism:
332 Or, by passing in a C<version> option:
334 use strictures version => 2;
341 use warnings FATAL => 'all';
342 use warnings NONFATAL => 'deprecated', 'experimental';
343 # and if in dev mode:
346 no bareword::filehandles;
353 use warnings FATAL => 'all';
354 # and if in dev mode:
357 no bareword::filehandles;
363 This method does the setup work described above in L</DESCRIPTION>. Optionally
364 accepts a C<version> option to request a specific version's behavior.
368 This method traps the C<< strictures->VERSION(1) >> call produced by a use line
369 with a version number on it and does the version check.
371 =head1 EXTRA TESTING RATIONALE
373 Every so often, somebody complains that they're deploying via C<git pull>
374 and that they don't want L<strictures> to enable itself in this case -- and that
375 setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
376 disable extra testing would be welcome but the discussion never seems to get
379 In order to allow us to skip a couple of stages and get straight to a
380 productive conversation, here's my current rationale for turning the
381 extra testing on via a heuristic:
383 The extra testing is all stuff that only ever blows up at compile time;
384 this is intentional. So the oft-raised concern that it's different code being
385 tested is only sort of the case -- none of the modules involved affect the
386 final optree to my knowledge, so the author gets some additional compile
387 time crashes which he/she then fixes, and the rest of the testing is
388 completely valid for all environments.
390 The point of the extra testing -- especially C<no indirect> -- is to catch
391 mistakes that newbie users won't even realise are mistakes without
396 where foo is an & prototyped sub that you forgot to import -- this is
397 pernicious to track down since all I<seems> fine until it gets called
398 and you get a crash. Worse still, you can fail to have imported it due
399 to a circular require, at which point you have a load order dependent
400 bug which I've seen before now I<only> show up in production due to tiny
401 differences between the production and the development environment. I wrote
402 L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
403 this particular problem before L<strictures> itself existed.
405 As such, in my experience so far L<strictures>' extra testing has
406 I<avoided> production versus development differences, not caused them.
408 Additionally, L<strictures>' policy is very much "try and provide as much
409 protection as possible for newbies -- who won't think about whether there's
410 an option to turn on or not" -- so having only the environment variable
411 is not sufficient to achieve that (I get to explain that you need to add
412 C<use strict> at least once a week on freenode #perl -- newbies sometimes
413 completely skip steps because they don't understand that that step
416 I make no claims that the heuristic is perfect -- it's already been evolved
417 significantly over time, especially for 1.004 where we changed things to
418 ensure it only fires on files in your checkout (rather than L<strictures>-using
419 modules you happened to have installed, which was just silly). However, I
420 hope the above clarifies why a heuristic approach is not only necessary but
421 desirable from a point of view of providing new users with as much safety as
422 possible, and will allow any future discussion on the subject to focus on "how
423 do we minimise annoyance to people deploying from checkouts intentionally".
439 L<bareword::filehandles>
443 =head1 COMMUNITY AND SUPPORT
447 irc.perl.org #toolchain
449 (or bug 'mst' in query on there or freenode)
451 =head2 Git repository
453 Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
455 git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
457 The web interface to the repository is at:
459 http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
463 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
467 Karen Etheridge (cpan:ETHER) <ether@cpan.org>
469 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
471 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
475 Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
480 This library is free software and may be distributed under the same terms