Commit | Line | Data |
394c3a46 |
1 | package strictures; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
500f28df |
6 | BEGIN { |
e12af862 |
7 | *_PERL_LT_5_8_4 = ("$]" < 5.008004) ? sub(){1} : sub(){0}; |
161de96d |
8 | # goto &UNIVERSAL::VERSION usually works on 5.8, but fails on some ARM |
9 | # machines. Seems to always work on 5.10 though. |
e12af862 |
10 | *_CAN_GOTO_VERSION = ("$]" >= 5.010000) ? sub(){1} : sub(){0}; |
500f28df |
11 | } |
084caaf3 |
12 | |
139c9070 |
13 | our $VERSION = '2.000006'; |
03278299 |
14 | $VERSION =~ tr/_//d; |
394c3a46 |
15 | |
23c0b85d |
16 | our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw( |
17 | closure |
95d54bcb |
18 | chmod |
23c0b85d |
19 | deprecated |
effab3f4 |
20 | deprecated::apostrophe_as_package_separator |
21 | deprecated::delimiter_will_be_paired |
22 | deprecated::dot_in_inc |
23 | deprecated::goto_construct |
24 | deprecated::missing_import_called_with_args |
25 | deprecated::smartmatch |
26 | deprecated::subsequent_use_version |
27 | deprecated::unicode_property_name |
28 | deprecated::version_downgrade |
23c0b85d |
29 | exiting |
30 | experimental |
ae11fa66 |
31 | experimental::alpha_assertions |
effab3f4 |
32 | experimental::args_array_with_signatures |
c5b35ddf |
33 | experimental::autoderef |
dfe53a53 |
34 | experimental::bitwise |
effab3f4 |
35 | experimental::builtin |
36 | experimental::class |
1e139b49 |
37 | experimental::const_attr |
b87194d6 |
38 | experimental::declared_refs |
effab3f4 |
39 | experimental::defer |
40 | experimental::extra_paired_delimiters |
41 | experimental::for_list |
85420a0b |
42 | experimental::isa |
23c0b85d |
43 | experimental::lexical_subs |
44 | experimental::lexical_topic |
c5b35ddf |
45 | experimental::postderef |
be9a89ec |
46 | experimental::private_use |
1e139b49 |
47 | experimental::re_strict |
48 | experimental::refaliasing |
23c0b85d |
49 | experimental::regex_sets |
ae11fa66 |
50 | experimental::script_run |
c5b35ddf |
51 | experimental::signatures |
23c0b85d |
52 | experimental::smartmatch |
effab3f4 |
53 | experimental::try |
85420a0b |
54 | experimental::uniprop_wildcards |
55 | experimental::vlb |
1e139b49 |
56 | experimental::win32_perlio |
23c0b85d |
57 | glob |
58 | imprecision |
59 | io |
60 | closed |
61 | exec |
62 | layer |
63 | newline |
64 | pipe |
c5b35ddf |
65 | syscalls |
23c0b85d |
66 | unopened |
1e139b49 |
67 | locale |
23c0b85d |
68 | misc |
1e139b49 |
69 | missing |
23c0b85d |
70 | numeric |
71 | once |
72 | overflow |
73 | pack |
74 | portable |
75 | recursion |
76 | redefine |
1e139b49 |
77 | redundant |
23c0b85d |
78 | regexp |
effab3f4 |
79 | scalar |
23c0b85d |
80 | severe |
81 | debugging |
82 | inplace |
83 | internal |
84 | malloc |
ae11fa66 |
85 | shadow |
23c0b85d |
86 | signal |
87 | substr |
88 | syntax |
89 | ambiguous |
90 | bareword |
91 | digit |
92 | illegalproto |
93 | parenthesis |
94 | precedence |
95 | printf |
96 | prototype |
97 | qw |
98 | reserved |
99 | semicolon |
100 | taint |
101 | threads |
102 | uninitialized |
95d54bcb |
103 | umask |
23c0b85d |
104 | unpack |
105 | untie |
106 | utf8 |
107 | non_unicode |
108 | nonchar |
109 | surrogate |
110 | void |
1e139b49 |
111 | void_unusual |
23c0b85d |
112 | y2k |
113 | ); |
114 | |
394c3a46 |
115 | sub VERSION { |
24590d98 |
116 | { |
117 | no warnings; |
118 | local $@; |
119 | if (defined $_[1] && eval { &UNIVERSAL::VERSION; 1}) { |
120 | $^H |= 0x20000 |
121 | unless _PERL_LT_5_8_4; |
122 | $^H{strictures_enable} = int $_[1]; |
123 | } |
394c3a46 |
124 | } |
24590d98 |
125 | _CAN_GOTO_VERSION ? goto &UNIVERSAL::VERSION : &UNIVERSAL::VERSION; |
394c3a46 |
126 | } |
127 | |
8f0df510 |
128 | our %extra_load_states; |
ffedb166 |
129 | |
2da53f4a |
130 | our $Smells_Like_VCS; |
12b8f19b |
131 | |
394c3a46 |
132 | sub import { |
92cde693 |
133 | my $class = shift; |
da50db3f |
134 | my %opts = @_ == 1 ? %{$_[0]} : @_; |
92cde693 |
135 | if (!exists $opts{version}) { |
136 | $opts{version} |
137 | = exists $^H{strictures_enable} ? delete $^H{strictures_enable} |
138 | : int $VERSION; |
139 | } |
c5a67be6 |
140 | $opts{file} = (caller)[1]; |
92cde693 |
141 | $class->_enable(\%opts); |
142 | } |
143 | |
144 | sub _enable { |
145 | my ($class, $opts) = @_; |
146 | my $version = $opts->{version}; |
147 | $version = 'undef' |
148 | if !defined $version; |
149 | my $method = "_enable_$version"; |
150 | if (!$class->can($method)) { |
a97f64c7 |
151 | require Carp; |
152 | Carp::croak("Major version specified as $version - not supported!"); |
92cde693 |
153 | } |
154 | $class->$method($opts); |
155 | } |
156 | |
157 | sub _enable_1 { |
c5a67be6 |
158 | my ($class, $opts) = @_; |
394c3a46 |
159 | strict->import; |
160 | warnings->import(FATAL => 'all'); |
084caaf3 |
161 | |
c5a67be6 |
162 | if (_want_extra($opts->{file})) { |
163 | _load_extras(qw(indirect multidimensional bareword::filehandles)); |
164 | indirect->unimport(':fatal') |
165 | if $extra_load_states{indirect}; |
166 | multidimensional->unimport |
167 | if $extra_load_states{multidimensional}; |
168 | bareword::filehandles->unimport |
169 | if $extra_load_states{'bareword::filehandles'}; |
170 | } |
8f0df510 |
171 | } |
172 | |
1931c77d |
173 | our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } ( |
174 | 'exec', # not safe to catch |
175 | 'recursion', # will be caught by other mechanisms |
176 | 'internal', # not safe to catch |
177 | 'malloc', # not safe to catch |
178 | 'newline', # stat on nonexistent file with a newline in it |
179 | 'experimental', # no reason for these to be fatal |
180 | 'deprecated', # unfortunately can't make these fatal |
181 | 'portable', # everything worked fine here, just may not elsewhere |
23c0b85d |
182 | ); |
1931c77d |
183 | our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } ( |
184 | 'once' # triggers inconsistently, can't be fatalized |
23c0b85d |
185 | ); |
186 | |
187 | sub _enable_2 { |
188 | my ($class, $opts) = @_; |
189 | strict->import; |
190 | warnings->import; |
191 | warnings->import(FATAL => @WARNING_CATEGORIES); |
d50343b9 |
192 | warnings->unimport(FATAL => @V2_NONFATAL); |
193 | warnings->import(@V2_NONFATAL); |
23c0b85d |
194 | warnings->unimport(@V2_DISABLE); |
195 | |
196 | if (_want_extra($opts->{file})) { |
197 | _load_extras(qw(indirect multidimensional bareword::filehandles)); |
198 | indirect->unimport(':fatal') |
199 | if $extra_load_states{indirect}; |
200 | multidimensional->unimport |
201 | if $extra_load_states{multidimensional}; |
202 | bareword::filehandles->unimport |
203 | if $extra_load_states{'bareword::filehandles'}; |
204 | } |
205 | } |
206 | |
9d763997 |
207 | sub _want_extra_env { |
c5a67be6 |
208 | if (exists $ENV{PERL_STRICTURES_EXTRA}) { |
209 | if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) { |
210 | die 'PERL_STRICTURES_EXTRA checks are not available on perls older' |
211 | . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n"; |
394c3a46 |
212 | } |
9d763997 |
213 | return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0; |
c5a67be6 |
214 | } |
9d763997 |
215 | return undef; |
216 | } |
217 | |
218 | sub _want_extra { |
219 | my $file = shift; |
220 | my $want_env = _want_extra_env(); |
221 | return $want_env |
222 | if defined $want_env; |
c5a67be6 |
223 | return ( |
224 | !_PERL_LT_5_8_4 |
225 | and $file =~ /^(?:t|xt|lib|blib)[\\\/]/ |
226 | and defined $Smells_Like_VCS ? $Smells_Like_VCS |
227 | : ( $Smells_Like_VCS = !!( |
7470ef57 |
228 | -e '.git' || -e '.svn' || -e '.hg' || -e '.bzr' |
c5a67be6 |
229 | || (-e '../../dist.ini' |
7470ef57 |
230 | && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' || -e '../../.bzr' )) |
c5a67be6 |
231 | )) |
232 | ); |
233 | } |
4f219885 |
234 | |
c5a67be6 |
235 | sub _load_extras { |
236 | my @extras = @_; |
8f0df510 |
237 | my @failed; |
238 | foreach my $mod (@extras) { |
239 | next |
240 | if exists $extra_load_states{$mod}; |
4f219885 |
241 | |
8f0df510 |
242 | $extra_load_states{$mod} = eval "require $mod; 1;" or do { |
243 | push @failed, $mod; |
488f2966 |
244 | |
8f0df510 |
245 | #work around 5.8 require bug |
246 | (my $file = $mod) =~ s|::|/|g; |
247 | delete $INC{"${file}.pm"}; |
248 | }; |
249 | } |
4f219885 |
250 | |
8f0df510 |
251 | if (@failed) { |
252 | my $failed = join ' ', @failed; |
253 | my $extras = join ' ', @extras; |
254 | print STDERR <<EOE; |
ffedb166 |
255 | strictures.pm extra testing active but couldn't load all modules. Missing were: |
256 | |
257 | $failed |
258 | |
0925b84b |
259 | Extra testing is auto-enabled in checkouts only, so if you're the author |
624cf8bb |
260 | of a strictures-using module you need to run: |
653f4377 |
261 | |
8f0df510 |
262 | cpan $extras |
653f4377 |
263 | |
264 | but these modules are not required by your users. |
084caaf3 |
265 | EOE |
394c3a46 |
266 | } |
267 | } |
268 | |
269 | 1; |
270 | |
271 | __END__ |
272 | =head1 NAME |
273 | |
4104cf62 |
274 | strictures - Turn on strict and make most warnings fatal |
394c3a46 |
275 | |
276 | =head1 SYNOPSIS |
277 | |
1c35787c |
278 | use strictures 2; |
394c3a46 |
279 | |
280 | is equivalent to |
281 | |
282 | use strict; |
283 | use warnings FATAL => 'all'; |
1c35787c |
284 | use warnings NONFATAL => qw( |
285 | exec |
286 | recursion |
287 | internal |
288 | malloc |
289 | newline |
290 | experimental |
291 | deprecated |
292 | portable |
293 | ); |
294 | no warnings 'once'; |
394c3a46 |
295 | |
5ab06a4d |
296 | except when called from a file which matches: |
394c3a46 |
297 | |
5b2a026b |
298 | (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/ |
394c3a46 |
299 | |
7470ef57 |
300 | and when either C<.git>, C<.svn>, C<.hg>, or C<.bzr> is present in the current |
301 | directory (with the intention of only forcing extra tests on the author side) |
302 | -- or when C<.git>, C<.svn>, C<.hg>, or C<.bzr> is present two directories up |
303 | along with C<dist.ini> (which would indicate we are in a C<dzil test> operation, |
304 | via L<Dist::Zilla>) -- or when the C<PERL_STRICTURES_EXTRA> environment variable |
305 | is set, in which case it also does the equivalent of |
394c3a46 |
306 | |
394c3a46 |
307 | no indirect 'fatal'; |
653f4377 |
308 | no multidimensional; |
309 | no bareword::filehandles; |
394c3a46 |
310 | |
3e14202f |
311 | Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with |
312 | only a minor version increase, but any changes to the effect of C<use |
313 | strictures> in normal mode will involve a major version bump. |
394c3a46 |
314 | |
0eb0d037 |
315 | If any of the extra testing modules are not present, L<strictures> will |
25877bf2 |
316 | complain loudly, once, via C<warn()>, and then shut up. But you really |
ffedb166 |
317 | should consider installing them, they're all great anti-footgun tools. |
17b03f2e |
318 | |
394c3a46 |
319 | =head1 DESCRIPTION |
320 | |
321 | I've been writing the equivalent of this module at the top of my code for |
322 | about a year now. I figured it was time to make it shorter. |
323 | |
25877bf2 |
324 | Things like the importer in C<use Moose> don't help me because they turn |
d8c1c6b2 |
325 | warnings on but don't make them fatal -- which from my point of view is |
2288278f |
326 | useless because I want an exception to tell me my code isn't warnings-clean. |
394c3a46 |
327 | |
328 | Any time I see a warning from my code, that indicates a mistake. |
329 | |
d8c1c6b2 |
330 | Any time my code encounters a mistake, I want a crash -- not spew to STDERR |
394c3a46 |
331 | and then unknown (and probably undesired) subsequent behaviour. |
332 | |
333 | I also want to ensure that obvious coding mistakes, like indirect object |
334 | syntax (and not so obvious mistakes that cause things to accidentally compile |
335 | as such) get caught, but not at the cost of an XS dependency and not at the |
336 | cost of blowing things up on another machine. |
337 | |
0eb0d037 |
338 | Therefore, L<strictures> turns on additional checking, but only when it thinks |
2288278f |
339 | it's running in a test file in a VCS checkout -- although if this causes |
93ae637e |
340 | undesired behaviour this can be overridden by setting the |
25877bf2 |
341 | C<PERL_STRICTURES_EXTRA> environment variable. |
394c3a46 |
342 | |
343 | If additional useful author side checks come to mind, I'll add them to the |
3e14202f |
344 | C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version |
345 | increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the |
346 | mechanism of this code will result in a sub-version increase (e.g. 1.000000 to |
347 | 1.000001 (1.0.1)). |
394c3a46 |
348 | |
d48424bd |
349 | =head1 CATEGORY SELECTIONS |
350 | |
351 | strictures does not enable fatal warnings for all categories. |
352 | |
353 | =over 4 |
354 | |
355 | =item exec |
356 | |
357 | Includes a warning that can cause your program to continue running |
358 | unintentionally after an internal fork. Not safe to fatalize. |
359 | |
360 | =item recursion |
361 | |
362 | Infinite recursion will end up overflowing the stack eventually anyway. |
363 | |
364 | =item internal |
365 | |
366 | Triggers deep within perl, in places that are not safe to trap. |
367 | |
368 | =item malloc |
369 | |
370 | Triggers deep within perl, in places that are not safe to trap. |
371 | |
372 | =item newline |
373 | |
374 | Includes a warning for using stat on a valid but suspect filename, ending in a |
375 | newline. |
376 | |
377 | =item experimental |
378 | |
379 | Experimental features are used intentionally. |
380 | |
381 | =item deprecated |
382 | |
383 | Deprecations will inherently be added to in the future in unexpected ways, |
384 | so making them fatal won't be reliable. |
385 | |
386 | =item portable |
387 | |
388 | Doesn't indicate an actual problem with the program, only that it may not |
389 | behave properly if run on a different machine. |
390 | |
391 | =item once |
392 | |
393 | Can't be fatalized. Also triggers very inconsistently, so we just disable it. |
394 | |
395 | =back |
396 | |
1c35787c |
397 | =head1 VERSIONS |
398 | |
399 | Depending on the version of strictures requested, different warnings will be |
400 | enabled. If no specific version is requested, the current version's behavior |
401 | will be used. Versions can be requested using perl's standard mechanism: |
402 | |
403 | use strictures 2; |
404 | |
405 | Or, by passing in a C<version> option: |
406 | |
407 | use strictures version => 2; |
394c3a46 |
408 | |
1c35787c |
409 | =head2 VERSION 2 |
394c3a46 |
410 | |
1c35787c |
411 | Equivalent to: |
412 | |
413 | use strict; |
414 | use warnings FATAL => 'all'; |
d771b3bb |
415 | use warnings NONFATAL => qw( |
416 | exec |
417 | recursion |
418 | internal |
419 | malloc |
420 | newline |
421 | experimental |
422 | deprecated |
423 | portable |
424 | ); |
425 | no warnings 'once'; |
426 | |
1c35787c |
427 | # and if in dev mode: |
428 | no indirect 'fatal'; |
429 | no multidimensional; |
430 | no bareword::filehandles; |
431 | |
d771b3bb |
432 | Additionally, any warnings created by modules using L<warnings::register> or |
433 | C<warnings::register_categories()> will not be fatalized. |
434 | |
1c35787c |
435 | =head2 VERSION 1 |
436 | |
437 | Equivalent to: |
438 | |
439 | use strict; |
440 | use warnings FATAL => 'all'; |
441 | # and if in dev mode: |
442 | no indirect 'fatal'; |
443 | no multidimensional; |
444 | no bareword::filehandles; |
eae006ee |
445 | |
446 | =head1 METHODS |
447 | |
448 | =head2 import |
449 | |
1c35787c |
450 | This method does the setup work described above in L</DESCRIPTION>. Optionally |
451 | accepts a C<version> option to request a specific version's behavior. |
eae006ee |
452 | |
453 | =head2 VERSION |
454 | |
25877bf2 |
455 | This method traps the C<< strictures->VERSION(1) >> call produced by a use line |
eae006ee |
456 | with a version number on it and does the version check. |
457 | |
f9df7e2e |
458 | =head1 EXTRA TESTING RATIONALE |
459 | |
25877bf2 |
460 | Every so often, somebody complains that they're deploying via C<git pull> |
d8c1c6b2 |
461 | and that they don't want L<strictures> to enable itself in this case -- and that |
f9df7e2e |
462 | setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to |
463 | disable extra testing would be welcome but the discussion never seems to get |
464 | that far). |
465 | |
466 | In order to allow us to skip a couple of stages and get straight to a |
467 | productive conversation, here's my current rationale for turning the |
468 | extra testing on via a heuristic: |
469 | |
470 | The extra testing is all stuff that only ever blows up at compile time; |
2288278f |
471 | this is intentional. So the oft-raised concern that it's different code being |
d8c1c6b2 |
472 | tested is only sort of the case -- none of the modules involved affect the |
f9df7e2e |
473 | final optree to my knowledge, so the author gets some additional compile |
474 | time crashes which he/she then fixes, and the rest of the testing is |
475 | completely valid for all environments. |
476 | |
d8c1c6b2 |
477 | The point of the extra testing -- especially C<no indirect> -- is to catch |
f9df7e2e |
478 | mistakes that newbie users won't even realise are mistakes without |
479 | help. For example, |
480 | |
481 | foo { ... }; |
482 | |
d8c1c6b2 |
483 | where foo is an & prototyped sub that you forgot to import -- this is |
9a363fed |
484 | pernicious to track down since all I<seems> fine until it gets called |
f9df7e2e |
485 | and you get a crash. Worse still, you can fail to have imported it due |
486 | to a circular require, at which point you have a load order dependent |
9a363fed |
487 | bug which I've seen before now I<only> show up in production due to tiny |
f9df7e2e |
488 | differences between the production and the development environment. I wrote |
489 | L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain |
490 | this particular problem before L<strictures> itself existed. |
491 | |
2288278f |
492 | As such, in my experience so far L<strictures>' extra testing has |
9a363fed |
493 | I<avoided> production versus development differences, not caused them. |
f9df7e2e |
494 | |
0eb0d037 |
495 | Additionally, L<strictures>' policy is very much "try and provide as much |
d8c1c6b2 |
496 | protection as possible for newbies -- who won't think about whether there's |
497 | an option to turn on or not" -- so having only the environment variable |
f9df7e2e |
498 | is not sufficient to achieve that (I get to explain that you need to add |
d8c1c6b2 |
499 | C<use strict> at least once a week on freenode #perl -- newbies sometimes |
f9df7e2e |
500 | completely skip steps because they don't understand that that step |
501 | is important). |
502 | |
d8c1c6b2 |
503 | I make no claims that the heuristic is perfect -- it's already been evolved |
f9df7e2e |
504 | significantly over time, especially for 1.004 where we changed things to |
0eb0d037 |
505 | ensure it only fires on files in your checkout (rather than L<strictures>-using |
f9df7e2e |
506 | modules you happened to have installed, which was just silly). However, I |
507 | hope the above clarifies why a heuristic approach is not only necessary but |
3e14202f |
508 | desirable from a point of view of providing new users with as much safety as |
509 | possible, and will allow any future discussion on the subject to focus on "how |
510 | do we minimise annoyance to people deploying from checkouts intentionally". |
f9df7e2e |
511 | |
96c8649b |
512 | =head1 SEE ALSO |
513 | |
514 | =over 4 |
515 | |
516 | =item * |
517 | |
518 | L<indirect> |
519 | |
520 | =item * |
521 | |
522 | L<multidimensional> |
523 | |
524 | =item * |
525 | |
526 | L<bareword::filehandles> |
527 | |
528 | =back |
529 | |
eae006ee |
530 | =head1 COMMUNITY AND SUPPORT |
531 | |
532 | =head2 IRC channel |
533 | |
534 | irc.perl.org #toolchain |
535 | |
536 | (or bug 'mst' in query on there or freenode) |
537 | |
538 | =head2 Git repository |
539 | |
540 | Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is: |
541 | |
542 | git clone git://git.shadowcat.co.uk/p5sagit/strictures.git |
543 | |
91be28bc |
544 | The web interface to the repository is at: |
545 | |
546 | http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git |
547 | |
eae006ee |
548 | =head1 AUTHOR |
549 | |
d81f898d |
550 | mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk> |
eae006ee |
551 | |
552 | =head1 CONTRIBUTORS |
553 | |
8190ff5b |
554 | Karen Etheridge (cpan:ETHER) <ether@cpan.org> |
eae006ee |
555 | |
04b4a35d |
556 | Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com> |
557 | |
a79d1096 |
558 | haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org> |
559 | |
eae006ee |
560 | =head1 COPYRIGHT |
561 | |
562 | Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS> |
563 | as listed above. |
564 | |
565 | =head1 LICENSE |
566 | |
567 | This library is free software and may be distributed under the same terms |
568 | as perl itself. |
569 | |
570 | =cut |