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