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