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 = '1.005006';
  11 $VERSION = eval $VERSION;
  12
  13 sub VERSION {
  14   no warnings;
  15   local $@;
  16   if (defined $_[1] && eval { $_[0]->UNIVERSAL::VERSION($_[1]); 1}) {
  17     $^H |= 0x20000
  18       unless _PERL_LT_5_8_4;
  19     $^H{strictures_enable} = int $_[1];
  20   }
  21   goto &UNIVERSAL::VERSION;
  22 }
  23
  24 our %extra_load_states;
  25
  26 our $Smells_Like_VCS;
  27
  28 sub import {
  29   my $class = shift;
  30   my %opts = ref $_[0] ? %{$_[0]} : @_;
  31   if (!exists $opts{version}) {
  32     $opts{version}
  33       = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
  34       : int $VERSION;
  35   }
  36   $opts{file} = (caller)[1];
  37   $class->_enable(\%opts);
  38 }
  39
  40 sub _enable {
  41   my ($class, $opts) = @_;
  42   my $version = $opts->{version};
  43   $version = 'undef'
  44     if !defined $version;
  45   my $method = "_enable_$version";
  46   if (!$class->can($method)) {
  47     die "Major version specified as $version - not supported!";
  48   }
  49   $class->$method($opts);
  50 }
  51
  52 sub _enable_1 {
  53   my ($class, $opts) = @_;
  54   strict->import;
  55   warnings->import(FATAL => 'all');
  56
  57   if (_want_extra($opts->{file})) {
  58     _load_extras(qw(indirect multidimensional bareword::filehandles));
  59     indirect->unimport(':fatal')
  60       if $extra_load_states{indirect};
  61     multidimensional->unimport
  62       if $extra_load_states{multidimensional};
  63     bareword::filehandles->unimport
  64       if $extra_load_states{'bareword::filehandles'};
  65   }
  66 }
  67
  68 sub _want_extra_env {
  69   if (exists $ENV{PERL_STRICTURES_EXTRA}) {
  70     if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
  71       die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
  72         . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
  73     }
  74     return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
  75   }
  76   return undef;
  77 }
  78
  79 sub _want_extra {
  80   my $file = shift;
  81   my $want_env = _want_extra_env();
  82   return $want_env
  83     if defined $want_env;
  84   return (
  85     !_PERL_LT_5_8_4
  86     and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
  87     and defined $Smells_Like_VCS ? $Smells_Like_VCS
  88       : ( $Smells_Like_VCS = !!(
  89         -e '.git' || -e '.svn' || -e '.hg'
  90         || (-e '../../dist.ini'
  91           && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' ))
  92       ))
  93   );
  94 }
  95
  96 sub _load_extras {
  97   my @extras = @_;
  98   my @failed;
  99   foreach my $mod (@extras) {
 100     next
 101       if exists $extra_load_states{$mod};
 102
 103     $extra_load_states{$mod} = eval "require $mod; 1;" or do {
 104       push @failed, $mod;
 105
 106       #work around 5.8 require bug
 107       (my $file = $mod) =~ s|::|/|g;
 108       delete $INC{"${file}.pm"};
 109     };
 110   }
 111
 112   if (@failed) {
 113     my $failed = join ' ', @failed;
 114     my $extras = join ' ', @extras;
 115     print STDERR <<EOE;
 116 strictures.pm extra testing active but couldn't load all modules. Missing were:
 117
 118   $failed
 119
 120 Extra testing is auto-enabled in checkouts only, so if you're the author
 121 of a strictures-using module you need to run:
 122
 123   cpan $extras
 124
 125 but these modules are not required by your users.
 126 EOE
 127   }
 128 }
 129
 130 1;
 131
 132 __END__
 133 =head1 NAME
 134
 135 strictures - turn on strict and make all warnings fatal
 136
 137 =head1 SYNOPSIS
 138
 139   use strictures 1;
 140
 141 is equivalent to
 142
 143   use strict;
 144   use warnings FATAL => 'all';
 145
 146 except when called from a file which matches:
 147
 148   (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
 149
 150 and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory
 151 (with the intention of only forcing extra tests on the author side) -- or when
 152 C<.git>, C<.svn>, or C<.hg> is present two directories up along with
 153 C<dist.ini> (which would indicate we are in a C<dzil test> operation, via
 154 L<Dist::Zilla>) -- or when the C<PERL_STRICTURES_EXTRA> environment variable is
 155 set, in which case
 156
 157   use strictures 1;
 158
 159 is equivalent to
 160
 161   use strict;
 162   use warnings FATAL => 'all';
 163   no indirect 'fatal';
 164   no multidimensional;
 165   no bareword::filehandles;
 166
 167 Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with
 168 only a minor version increase, but any changes to the effect of C<use
 169 strictures> in normal mode will involve a major version bump.
 170
 171 If any of the extra testing modules are not present, L<strictures> will
 172 complain loudly, once, via C<warn()>, and then shut up. But you really
 173 should consider installing them, they're all great anti-footgun tools.
 174
 175 =head1 DESCRIPTION
 176
 177 I've been writing the equivalent of this module at the top of my code for
 178 about a year now. I figured it was time to make it shorter.
 179
 180 Things like the importer in C<use Moose> don't help me because they turn
 181 warnings on but don't make them fatal -- which from my point of view is
 182 useless because I want an exception to tell me my code isn't warnings-clean.
 183
 184 Any time I see a warning from my code, that indicates a mistake.
 185
 186 Any time my code encounters a mistake, I want a crash -- not spew to STDERR
 187 and then unknown (and probably undesired) subsequent behaviour.
 188
 189 I also want to ensure that obvious coding mistakes, like indirect object
 190 syntax (and not so obvious mistakes that cause things to accidentally compile
 191 as such) get caught, but not at the cost of an XS dependency and not at the
 192 cost of blowing things up on another machine.
 193
 194 Therefore, L<strictures> turns on additional checking, but only when it thinks
 195 it's running in a test file in a VCS checkout -- although if this causes
 196 undesired behaviour this can be overridden by setting the
 197 C<PERL_STRICTURES_EXTRA> environment variable.
 198
 199 If additional useful author side checks come to mind, I'll add them to the
 200 C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version
 201 increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the
 202 mechanism of this code will result in a sub-version increase (e.g. 1.000000 to
 203 1.000001 (1.0.1)).
 204
 205 If the behaviour of C<use strictures> in normal mode changes in any way, that
 206 will constitute a major version increase -- and the code already checks
 207 when its version is tested to ensure that
 208
 209   use strictures 1;
 210
 211 will continue to only introduce the current set of strictures even if 2.0 is
 212 installed.
 213
 214 =head1 METHODS
 215
 216 =head2 import
 217
 218 This method does the setup work described above in L</DESCRIPTION>
 219
 220 =head2 VERSION
 221
 222 This method traps the C<< strictures->VERSION(1) >> call produced by a use line
 223 with a version number on it and does the version check.
 224
 225 =head1 EXTRA TESTING RATIONALE
 226
 227 Every so often, somebody complains that they're deploying via C<git pull>
 228 and that they don't want L<strictures> to enable itself in this case -- and that
 229 setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
 230 disable extra testing would be welcome but the discussion never seems to get
 231 that far).
 232
 233 In order to allow us to skip a couple of stages and get straight to a
 234 productive conversation, here's my current rationale for turning the
 235 extra testing on via a heuristic:
 236
 237 The extra testing is all stuff that only ever blows up at compile time;
 238 this is intentional. So the oft-raised concern that it's different code being
 239 tested is only sort of the case -- none of the modules involved affect the
 240 final optree to my knowledge, so the author gets some additional compile
 241 time crashes which he/she then fixes, and the rest of the testing is
 242 completely valid for all environments.
 243
 244 The point of the extra testing -- especially C<no indirect> -- is to catch
 245 mistakes that newbie users won't even realise are mistakes without
 246 help. For example,
 247
 248   foo { ... };
 249
 250 where foo is an & prototyped sub that you forgot to import -- this is
 251 pernicious to track down since all I<seems> fine until it gets called
 252 and you get a crash. Worse still, you can fail to have imported it due
 253 to a circular require, at which point you have a load order dependent
 254 bug which I've seen before now I<only> show up in production due to tiny
 255 differences between the production and the development environment. I wrote
 256 L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
 257 this particular problem before L<strictures> itself existed.
 258
 259 As such, in my experience so far L<strictures>' extra testing has
 260 I<avoided> production versus development differences, not caused them.
 261
 262 Additionally, L<strictures>' policy is very much "try and provide as much
 263 protection as possible for newbies -- who won't think about whether there's
 264 an option to turn on or not" -- so having only the environment variable
 265 is not sufficient to achieve that (I get to explain that you need to add
 266 C<use strict> at least once a week on freenode #perl -- newbies sometimes
 267 completely skip steps because they don't understand that that step
 268 is important).
 269
 270 I make no claims that the heuristic is perfect -- it's already been evolved
 271 significantly over time, especially for 1.004 where we changed things to
 272 ensure it only fires on files in your checkout (rather than L<strictures>-using
 273 modules you happened to have installed, which was just silly). However, I
 274 hope the above clarifies why a heuristic approach is not only necessary but
 275 desirable from a point of view of providing new users with as much safety as
 276 possible, and will allow any future discussion on the subject to focus on "how
 277 do we minimise annoyance to people deploying from checkouts intentionally".
 278
 279 =head1 SEE ALSO
 280
 281 =over 4
 282
 283 =item *
 284
 285 L<indirect>
 286
 287 =item *
 288
 289 L<multidimensional>
 290
 291 =item *
 292
 293 L<bareword::filehandles>
 294
 295 =back
 296
 297 =head1 COMMUNITY AND SUPPORT
 298
 299 =head2 IRC channel
 300
 301 irc.perl.org #toolchain
 302
 303 (or bug 'mst' in query on there or freenode)
 304
 305 =head2 Git repository
 306
 307 Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
 308
 309   git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
 310
 311 The web interface to the repository is at:
 312
 313   http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
 314
 315 =head1 AUTHOR
 316
 317 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 318
 319 =head1 CONTRIBUTORS
 320
 321 Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 322
 323 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
 324
 325 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 326
 327 =head1 COPYRIGHT
 328
 329 Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
 330 as listed above.
 331
 332 =head1 LICENSE
 333
 334 This library is free software and may be distributed under the same terms
 335 as perl itself.
 336
 337 =cut