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