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 it also does the equivalent of
 265
 266   no indirect 'fatal';
 267   no multidimensional;
 268   no bareword::filehandles;
 269
 270 Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with
 271 only a minor version increase, but any changes to the effect of C<use
 272 strictures> in normal mode will involve a major version bump.
 273
 274 If any of the extra testing modules are not present, L<strictures> will
 275 complain loudly, once, via C<warn()>, and then shut up. But you really
 276 should consider installing them, they're all great anti-footgun tools.
 277
 278 =head1 DESCRIPTION
 279
 280 I've been writing the equivalent of this module at the top of my code for
 281 about a year now. I figured it was time to make it shorter.
 282
 283 Things like the importer in C<use Moose> don't help me because they turn
 284 warnings on but don't make them fatal -- which from my point of view is
 285 useless because I want an exception to tell me my code isn't warnings-clean.
 286
 287 Any time I see a warning from my code, that indicates a mistake.
 288
 289 Any time my code encounters a mistake, I want a crash -- not spew to STDERR
 290 and then unknown (and probably undesired) subsequent behaviour.
 291
 292 I also want to ensure that obvious coding mistakes, like indirect object
 293 syntax (and not so obvious mistakes that cause things to accidentally compile
 294 as such) get caught, but not at the cost of an XS dependency and not at the
 295 cost of blowing things up on another machine.
 296
 297 Therefore, L<strictures> turns on additional checking, but only when it thinks
 298 it's running in a test file in a VCS checkout -- although if this causes
 299 undesired behaviour this can be overridden by setting the
 300 C<PERL_STRICTURES_EXTRA> environment variable.
 301
 302 If additional useful author side checks come to mind, I'll add them to the
 303 C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version
 304 increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the
 305 mechanism of this code will result in a sub-version increase (e.g. 1.000000 to
 306 1.000001 (1.0.1)).
 307
 308 =head1 VERSIONS
 309
 310 Depending on the version of strictures requested, different warnings will be
 311 enabled.  If no specific version is requested, the current version's behavior
 312 will be used.  Versions can be requested using perl's standard mechanism:
 313
 314   use strictures 2;
 315
 316 Or, by passing in a C<version> option:
 317
 318   use strictures version => 2;
 319
 320 =head2 VERSION 2
 321
 322 Equivalent to:
 323
 324   use strict;
 325   use warnings FATAL => 'all';
 326   use warnings NONFATAL => 'deprecated', 'experimental';
 327   # and if in dev mode:
 328   no indirect 'fatal';
 329   no multidimensional;
 330   no bareword::filehandles;
 331
 332 =head2 VERSION 1
 333
 334 Equivalent to:
 335
 336   use strict;
 337   use warnings FATAL => 'all';
 338   # and if in dev mode:
 339   no indirect 'fatal';
 340   no multidimensional;
 341   no bareword::filehandles;
 342
 343 =head1 METHODS
 344
 345 =head2 import
 346
 347 This method does the setup work described above in L</DESCRIPTION>.  Optionally
 348 accepts a C<version> option to request a specific version's behavior.
 349
 350 =head2 VERSION
 351
 352 This method traps the C<< strictures->VERSION(1) >> call produced by a use line
 353 with a version number on it and does the version check.
 354
 355 =head1 EXTRA TESTING RATIONALE
 356
 357 Every so often, somebody complains that they're deploying via C<git pull>
 358 and that they don't want L<strictures> to enable itself in this case -- and that
 359 setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
 360 disable extra testing would be welcome but the discussion never seems to get
 361 that far).
 362
 363 In order to allow us to skip a couple of stages and get straight to a
 364 productive conversation, here's my current rationale for turning the
 365 extra testing on via a heuristic:
 366
 367 The extra testing is all stuff that only ever blows up at compile time;
 368 this is intentional. So the oft-raised concern that it's different code being
 369 tested is only sort of the case -- none of the modules involved affect the
 370 final optree to my knowledge, so the author gets some additional compile
 371 time crashes which he/she then fixes, and the rest of the testing is
 372 completely valid for all environments.
 373
 374 The point of the extra testing -- especially C<no indirect> -- is to catch
 375 mistakes that newbie users won't even realise are mistakes without
 376 help. For example,
 377
 378   foo { ... };
 379
 380 where foo is an & prototyped sub that you forgot to import -- this is
 381 pernicious to track down since all I<seems> fine until it gets called
 382 and you get a crash. Worse still, you can fail to have imported it due
 383 to a circular require, at which point you have a load order dependent
 384 bug which I've seen before now I<only> show up in production due to tiny
 385 differences between the production and the development environment. I wrote
 386 L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
 387 this particular problem before L<strictures> itself existed.
 388
 389 As such, in my experience so far L<strictures>' extra testing has
 390 I<avoided> production versus development differences, not caused them.
 391
 392 Additionally, L<strictures>' policy is very much "try and provide as much
 393 protection as possible for newbies -- who won't think about whether there's
 394 an option to turn on or not" -- so having only the environment variable
 395 is not sufficient to achieve that (I get to explain that you need to add
 396 C<use strict> at least once a week on freenode #perl -- newbies sometimes
 397 completely skip steps because they don't understand that that step
 398 is important).
 399
 400 I make no claims that the heuristic is perfect -- it's already been evolved
 401 significantly over time, especially for 1.004 where we changed things to
 402 ensure it only fires on files in your checkout (rather than L<strictures>-using
 403 modules you happened to have installed, which was just silly). However, I
 404 hope the above clarifies why a heuristic approach is not only necessary but
 405 desirable from a point of view of providing new users with as much safety as
 406 possible, and will allow any future discussion on the subject to focus on "how
 407 do we minimise annoyance to people deploying from checkouts intentionally".
 408
 409 =head1 SEE ALSO
 410
 411 =over 4
 412
 413 =item *
 414
 415 L<indirect>
 416
 417 =item *
 418
 419 L<multidimensional>
 420
 421 =item *
 422
 423 L<bareword::filehandles>
 424
 425 =back
 426
 427 =head1 COMMUNITY AND SUPPORT
 428
 429 =head2 IRC channel
 430
 431 irc.perl.org #toolchain
 432
 433 (or bug 'mst' in query on there or freenode)
 434
 435 =head2 Git repository
 436
 437 Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
 438
 439   git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
 440
 441 The web interface to the repository is at:
 442
 443   http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
 444
 445 =head1 AUTHOR
 446
 447 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 448
 449 =head1 CONTRIBUTORS
 450
 451 Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 452
 453 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
 454
 455 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 456
 457 =head1 COPYRIGHT
 458
 459 Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
 460 as listed above.
 461
 462 =head1 LICENSE
 463
 464 This library is free software and may be distributed under the same terms
 465 as perl itself.
 466
 467 =cut