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