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