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