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