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