add new experimental::private_use warning from blead perl
[p5sagit/strictures.git] / lib / strictures.pm
1 package strictures;
2
3 use strict;
4 use warnings FATAL => 'all';
5
6 BEGIN {
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};
11 }
12
13 our $VERSION = '2.000005';
14 $VERSION =~ tr/_//d;
15
16 our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
17   closure
18   chmod
19   deprecated
20   exiting
21   experimental
22     experimental::alpha_assertions
23     experimental::autoderef
24     experimental::bitwise
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
38   glob
39   imprecision
40   io
41     closed
42     exec
43     layer
44     newline
45     pipe
46     syscalls
47     unopened
48   locale
49   misc
50   missing
51   numeric
52   once
53   overflow
54   pack
55   portable
56   recursion
57   redefine
58   redundant
59   regexp
60   severe
61     debugging
62     inplace
63     internal
64     malloc
65   shadow
66   signal
67   substr
68   syntax
69     ambiguous
70     bareword
71     digit
72     illegalproto
73     parenthesis
74     precedence
75     printf
76     prototype
77     qw
78     reserved
79     semicolon
80   taint
81   threads
82   uninitialized
83   umask
84   unpack
85   untie
86   utf8
87     non_unicode
88     nonchar
89     surrogate
90   void
91   void_unusual
92   y2k
93 );
94
95 sub VERSION {
96   {
97     no warnings;
98     local $@;
99     if (defined $_[1] && eval { &UNIVERSAL::VERSION; 1}) {
100       $^H |= 0x20000
101         unless _PERL_LT_5_8_4;
102       $^H{strictures_enable} = int $_[1];
103     }
104   }
105   _CAN_GOTO_VERSION ? goto &UNIVERSAL::VERSION : &UNIVERSAL::VERSION;
106 }
107
108 our %extra_load_states;
109
110 our $Smells_Like_VCS;
111
112 sub import {
113   my $class = shift;
114   my %opts = @_ == 1 ? %{$_[0]} : @_;
115   if (!exists $opts{version}) {
116     $opts{version}
117       = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
118       : int $VERSION;
119   }
120   $opts{file} = (caller)[1];
121   $class->_enable(\%opts);
122 }
123
124 sub _enable {
125   my ($class, $opts) = @_;
126   my $version = $opts->{version};
127   $version = 'undef'
128     if !defined $version;
129   my $method = "_enable_$version";
130   if (!$class->can($method)) {
131     require Carp;
132     Carp::croak("Major version specified as $version - not supported!");
133   }
134   $class->$method($opts);
135 }
136
137 sub _enable_1 {
138   my ($class, $opts) = @_;
139   strict->import;
140   warnings->import(FATAL => 'all');
141
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'};
150   }
151 }
152
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
162 );
163 our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } (
164   'once'          # triggers inconsistently, can't be fatalized
165 );
166
167 sub _enable_2 {
168   my ($class, $opts) = @_;
169   strict->import;
170   warnings->import;
171   warnings->import(FATAL => @WARNING_CATEGORIES);
172   warnings->unimport(FATAL => @V2_NONFATAL);
173   warnings->import(@V2_NONFATAL);
174   warnings->unimport(@V2_DISABLE);
175
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'};
184   }
185 }
186
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";
192     }
193     return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
194   }
195   return undef;
196 }
197
198 sub _want_extra {
199   my $file = shift;
200   my $want_env = _want_extra_env();
201   return $want_env
202     if defined $want_env;
203   return (
204     !_PERL_LT_5_8_4
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' ))
211       ))
212   );
213 }
214
215 sub _load_extras {
216   my @extras = @_;
217   my @failed;
218   foreach my $mod (@extras) {
219     next
220       if exists $extra_load_states{$mod};
221
222     $extra_load_states{$mod} = eval "require $mod; 1;" or do {
223       push @failed, $mod;
224
225       #work around 5.8 require bug
226       (my $file = $mod) =~ s|::|/|g;
227       delete $INC{"${file}.pm"};
228     };
229   }
230
231   if (@failed) {
232     my $failed = join ' ', @failed;
233     my $extras = join ' ', @extras;
234     print STDERR <<EOE;
235 strictures.pm extra testing active but couldn't load all modules. Missing were:
236
237   $failed
238
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:
241
242   cpan $extras
243
244 but these modules are not required by your users.
245 EOE
246   }
247 }
248
249 1;
250
251 __END__
252 =head1 NAME
253
254 strictures - Turn on strict and make most warnings fatal
255
256 =head1 SYNOPSIS
257
258   use strictures 2;
259
260 is equivalent to
261
262   use strict;
263   use warnings FATAL => 'all';
264   use warnings NONFATAL => qw(
265     exec
266     recursion
267     internal
268     malloc
269     newline
270     experimental
271     deprecated
272     portable
273   );
274   no warnings 'once';
275
276 except when called from a file which matches:
277
278   (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
279
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
286
287   no indirect 'fatal';
288   no multidimensional;
289   no bareword::filehandles;
290
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.
294
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.
298
299 =head1 DESCRIPTION
300
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.
303
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.
307
308 Any time I see a warning from my code, that indicates a mistake.
309
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.
312
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.
317
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.
322
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
327 1.000001 (1.0.1)).
328
329 =head1 CATEGORY SELECTIONS
330
331 strictures does not enable fatal warnings for all categories.
332
333 =over 4
334
335 =item exec
336
337 Includes a warning that can cause your program to continue running
338 unintentionally after an internal fork.  Not safe to fatalize.
339
340 =item recursion
341
342 Infinite recursion will end up overflowing the stack eventually anyway.
343
344 =item internal
345
346 Triggers deep within perl, in places that are not safe to trap.
347
348 =item malloc
349
350 Triggers deep within perl, in places that are not safe to trap.
351
352 =item newline
353
354 Includes a warning for using stat on a valid but suspect filename, ending in a
355 newline.
356
357 =item experimental
358
359 Experimental features are used intentionally.
360
361 =item deprecated
362
363 Deprecations will inherently be added to in the future in unexpected ways,
364 so making them fatal won't be reliable.
365
366 =item portable
367
368 Doesn't indicate an actual problem with the program, only that it may not
369 behave properly if run on a different machine.
370
371 =item once
372
373 Can't be fatalized.  Also triggers very inconsistently, so we just disable it.
374
375 =back
376
377 =head1 VERSIONS
378
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:
382
383   use strictures 2;
384
385 Or, by passing in a C<version> option:
386
387   use strictures version => 2;
388
389 =head2 VERSION 2
390
391 Equivalent to:
392
393   use strict;
394   use warnings FATAL => 'all';
395   use warnings NONFATAL => qw(
396     exec
397     recursion
398     internal
399     malloc
400     newline
401     experimental
402     deprecated
403     portable
404   );
405   no warnings 'once';
406
407   # and if in dev mode:
408   no indirect 'fatal';
409   no multidimensional;
410   no bareword::filehandles;
411
412 Additionally, any warnings created by modules using L<warnings::register> or
413 C<warnings::register_categories()> will not be fatalized.
414
415 =head2 VERSION 1
416
417 Equivalent to:
418
419   use strict;
420   use warnings FATAL => 'all';
421   # and if in dev mode:
422   no indirect 'fatal';
423   no multidimensional;
424   no bareword::filehandles;
425
426 =head1 METHODS
427
428 =head2 import
429
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.
432
433 =head2 VERSION
434
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.
437
438 =head1 EXTRA TESTING RATIONALE
439
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
444 that far).
445
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:
449
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.
456
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
459 help. For example,
460
461   foo { ... };
462
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.
471
472 As such, in my experience so far L<strictures>' extra testing has
473 I<avoided> production versus development differences, not caused them.
474
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
481 is important).
482
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".
491
492 =head1 SEE ALSO
493
494 =over 4
495
496 =item *
497
498 L<indirect>
499
500 =item *
501
502 L<multidimensional>
503
504 =item *
505
506 L<bareword::filehandles>
507
508 =back
509
510 =head1 COMMUNITY AND SUPPORT
511
512 =head2 IRC channel
513
514 irc.perl.org #toolchain
515
516 (or bug 'mst' in query on there or freenode)
517
518 =head2 Git repository
519
520 Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
521
522   git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
523
524 The web interface to the repository is at:
525
526   http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
527
528 =head1 AUTHOR
529
530 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
531
532 =head1 CONTRIBUTORS
533
534 Karen Etheridge (cpan:ETHER) <ether@cpan.org>
535
536 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
537
538 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
539
540 =head1 COPYRIGHT
541
542 Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
543 as listed above.
544
545 =head1 LICENSE
546
547 This library is free software and may be distributed under the same terms
548 as perl itself.
549
550 =cut