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