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 VERSIONS
 317
 318 Depending on the version of strictures requested, different warnings will be
 319 enabled.  If no specific version is requested, the current version's behavior
 320 will be used.  Versions can be requested using perl's standard mechanism:
 321
 322   use strictures 2;
 323
 324 Or, by passing in a C<version> option:
 325
 326   use strictures version => 2;
 327
 328 =head2 VERSION 2
 329
 330 Equivalent to:
 331
 332   use strict;
 333   use warnings FATAL => 'all';
 334   use warnings NONFATAL => qw(
 335     exec
 336     recursion
 337     internal
 338     malloc
 339     newline
 340     experimental
 341     deprecated
 342     portable
 343   );
 344   no warnings 'once';
 345
 346   # and if in dev mode:
 347   no indirect 'fatal';
 348   no multidimensional;
 349   no bareword::filehandles;
 350
 351 Additionally, any warnings created by modules using L<warnings::register> or
 352 C<warnings::register_categories()> will not be fatalized.
 353
 354 =head2 VERSION 1
 355
 356 Equivalent to:
 357
 358   use strict;
 359   use warnings FATAL => 'all';
 360   # and if in dev mode:
 361   no indirect 'fatal';
 362   no multidimensional;
 363   no bareword::filehandles;
 364
 365 =head1 METHODS
 366
 367 =head2 import
 368
 369 This method does the setup work described above in L</DESCRIPTION>.  Optionally
 370 accepts a C<version> option to request a specific version's behavior.
 371
 372 =head2 VERSION
 373
 374 This method traps the C<< strictures->VERSION(1) >> call produced by a use line
 375 with a version number on it and does the version check.
 376
 377 =head1 EXTRA TESTING RATIONALE
 378
 379 Every so often, somebody complains that they're deploying via C<git pull>
 380 and that they don't want L<strictures> to enable itself in this case -- and that
 381 setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
 382 disable extra testing would be welcome but the discussion never seems to get
 383 that far).
 384
 385 In order to allow us to skip a couple of stages and get straight to a
 386 productive conversation, here's my current rationale for turning the
 387 extra testing on via a heuristic:
 388
 389 The extra testing is all stuff that only ever blows up at compile time;
 390 this is intentional. So the oft-raised concern that it's different code being
 391 tested is only sort of the case -- none of the modules involved affect the
 392 final optree to my knowledge, so the author gets some additional compile
 393 time crashes which he/she then fixes, and the rest of the testing is
 394 completely valid for all environments.
 395
 396 The point of the extra testing -- especially C<no indirect> -- is to catch
 397 mistakes that newbie users won't even realise are mistakes without
 398 help. For example,
 399
 400   foo { ... };
 401
 402 where foo is an & prototyped sub that you forgot to import -- this is
 403 pernicious to track down since all I<seems> fine until it gets called
 404 and you get a crash. Worse still, you can fail to have imported it due
 405 to a circular require, at which point you have a load order dependent
 406 bug which I've seen before now I<only> show up in production due to tiny
 407 differences between the production and the development environment. I wrote
 408 L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
 409 this particular problem before L<strictures> itself existed.
 410
 411 As such, in my experience so far L<strictures>' extra testing has
 412 I<avoided> production versus development differences, not caused them.
 413
 414 Additionally, L<strictures>' policy is very much "try and provide as much
 415 protection as possible for newbies -- who won't think about whether there's
 416 an option to turn on or not" -- so having only the environment variable
 417 is not sufficient to achieve that (I get to explain that you need to add
 418 C<use strict> at least once a week on freenode #perl -- newbies sometimes
 419 completely skip steps because they don't understand that that step
 420 is important).
 421
 422 I make no claims that the heuristic is perfect -- it's already been evolved
 423 significantly over time, especially for 1.004 where we changed things to
 424 ensure it only fires on files in your checkout (rather than L<strictures>-using
 425 modules you happened to have installed, which was just silly). However, I
 426 hope the above clarifies why a heuristic approach is not only necessary but
 427 desirable from a point of view of providing new users with as much safety as
 428 possible, and will allow any future discussion on the subject to focus on "how
 429 do we minimise annoyance to people deploying from checkouts intentionally".
 430
 431 =head1 SEE ALSO
 432
 433 =over 4
 434
 435 =item *
 436
 437 L<indirect>
 438
 439 =item *
 440
 441 L<multidimensional>
 442
 443 =item *
 444
 445 L<bareword::filehandles>
 446
 447 =back
 448
 449 =head1 COMMUNITY AND SUPPORT
 450
 451 =head2 IRC channel
 452
 453 irc.perl.org #toolchain
 454
 455 (or bug 'mst' in query on there or freenode)
 456
 457 =head2 Git repository
 458
 459 Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
 460
 461   git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
 462
 463 The web interface to the repository is at:
 464
 465   http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
 466
 467 =head1 AUTHOR
 468
 469 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 470
 471 =head1 CONTRIBUTORS
 472
 473 Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 474
 475 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
 476
 477 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 478
 479 =head1 COPYRIGHT
 480
 481 Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
 482 as listed above.
 483
 484 =head1 LICENSE
 485
 486 This library is free software and may be distributed under the same terms
 487 as perl itself.
 488
 489 =cut