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