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