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