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