Commit | Line | Data |
394c3a46 |
1 | package strictures; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
500f28df |
6 | BEGIN { |
7 | *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0}; |
8 | } |
084caaf3 |
9 | |
9668cbf1 |
10 | our $VERSION = '1.005006'; |
20b853bb |
11 | $VERSION = eval $VERSION; |
394c3a46 |
12 | |
13 | sub VERSION { |
92cde693 |
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]; |
394c3a46 |
20 | } |
92cde693 |
21 | goto &UNIVERSAL::VERSION; |
394c3a46 |
22 | } |
23 | |
8f0df510 |
24 | our %extra_load_states; |
ffedb166 |
25 | |
2da53f4a |
26 | our $Smells_Like_VCS; |
12b8f19b |
27 | |
394c3a46 |
28 | sub import { |
92cde693 |
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 | } |
c5a67be6 |
36 | $opts{file} = (caller)[1]; |
92cde693 |
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 { |
c5a67be6 |
53 | my ($class, $opts) = @_; |
394c3a46 |
54 | strict->import; |
55 | warnings->import(FATAL => 'all'); |
084caaf3 |
56 | |
c5a67be6 |
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 | } |
8f0df510 |
66 | } |
67 | |
9d763997 |
68 | sub _want_extra_env { |
c5a67be6 |
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"; |
394c3a46 |
73 | } |
9d763997 |
74 | return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0; |
c5a67be6 |
75 | } |
9d763997 |
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; |
c5a67be6 |
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 | } |
4f219885 |
95 | |
c5a67be6 |
96 | sub _load_extras { |
97 | my @extras = @_; |
8f0df510 |
98 | my @failed; |
99 | foreach my $mod (@extras) { |
100 | next |
101 | if exists $extra_load_states{$mod}; |
4f219885 |
102 | |
8f0df510 |
103 | $extra_load_states{$mod} = eval "require $mod; 1;" or do { |
104 | push @failed, $mod; |
488f2966 |
105 | |
8f0df510 |
106 | #work around 5.8 require bug |
107 | (my $file = $mod) =~ s|::|/|g; |
108 | delete $INC{"${file}.pm"}; |
109 | }; |
110 | } |
4f219885 |
111 | |
8f0df510 |
112 | if (@failed) { |
113 | my $failed = join ' ', @failed; |
114 | my $extras = join ' ', @extras; |
115 | print STDERR <<EOE; |
ffedb166 |
116 | strictures.pm extra testing active but couldn't load all modules. Missing were: |
117 | |
118 | $failed |
119 | |
0925b84b |
120 | Extra testing is auto-enabled in checkouts only, so if you're the author |
624cf8bb |
121 | of a strictures-using module you need to run: |
653f4377 |
122 | |
8f0df510 |
123 | cpan $extras |
653f4377 |
124 | |
125 | but these modules are not required by your users. |
084caaf3 |
126 | EOE |
394c3a46 |
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 | |
5ab06a4d |
146 | except when called from a file which matches: |
394c3a46 |
147 | |
5b2a026b |
148 | (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/ |
394c3a46 |
149 | |
3e14202f |
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 |
394c3a46 |
156 | |
157 | use strictures 1; |
158 | |
159 | is equivalent to |
160 | |
161 | use strict; |
162 | use warnings FATAL => 'all'; |
163 | no indirect 'fatal'; |
653f4377 |
164 | no multidimensional; |
165 | no bareword::filehandles; |
394c3a46 |
166 | |
3e14202f |
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. |
394c3a46 |
170 | |
0eb0d037 |
171 | If any of the extra testing modules are not present, L<strictures> will |
25877bf2 |
172 | complain loudly, once, via C<warn()>, and then shut up. But you really |
ffedb166 |
173 | should consider installing them, they're all great anti-footgun tools. |
17b03f2e |
174 | |
394c3a46 |
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 | |
25877bf2 |
180 | Things like the importer in C<use Moose> don't help me because they turn |
d8c1c6b2 |
181 | warnings on but don't make them fatal -- which from my point of view is |
2288278f |
182 | useless because I want an exception to tell me my code isn't warnings-clean. |
394c3a46 |
183 | |
184 | Any time I see a warning from my code, that indicates a mistake. |
185 | |
d8c1c6b2 |
186 | Any time my code encounters a mistake, I want a crash -- not spew to STDERR |
394c3a46 |
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 | |
0eb0d037 |
194 | Therefore, L<strictures> turns on additional checking, but only when it thinks |
2288278f |
195 | it's running in a test file in a VCS checkout -- although if this causes |
93ae637e |
196 | undesired behaviour this can be overridden by setting the |
25877bf2 |
197 | C<PERL_STRICTURES_EXTRA> environment variable. |
394c3a46 |
198 | |
199 | If additional useful author side checks come to mind, I'll add them to the |
3e14202f |
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)). |
394c3a46 |
204 | |
25877bf2 |
205 | If the behaviour of C<use strictures> in normal mode changes in any way, that |
d8c1c6b2 |
206 | will constitute a major version increase -- and the code already checks |
394c3a46 |
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. |
eae006ee |
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 | |
25877bf2 |
222 | This method traps the C<< strictures->VERSION(1) >> call produced by a use line |
eae006ee |
223 | with a version number on it and does the version check. |
224 | |
f9df7e2e |
225 | =head1 EXTRA TESTING RATIONALE |
226 | |
25877bf2 |
227 | Every so often, somebody complains that they're deploying via C<git pull> |
d8c1c6b2 |
228 | and that they don't want L<strictures> to enable itself in this case -- and that |
f9df7e2e |
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; |
2288278f |
238 | this is intentional. So the oft-raised concern that it's different code being |
d8c1c6b2 |
239 | tested is only sort of the case -- none of the modules involved affect the |
f9df7e2e |
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 | |
d8c1c6b2 |
244 | The point of the extra testing -- especially C<no indirect> -- is to catch |
f9df7e2e |
245 | mistakes that newbie users won't even realise are mistakes without |
246 | help. For example, |
247 | |
248 | foo { ... }; |
249 | |
d8c1c6b2 |
250 | where foo is an & prototyped sub that you forgot to import -- this is |
9a363fed |
251 | pernicious to track down since all I<seems> fine until it gets called |
f9df7e2e |
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 |
9a363fed |
254 | bug which I've seen before now I<only> show up in production due to tiny |
f9df7e2e |
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 | |
2288278f |
259 | As such, in my experience so far L<strictures>' extra testing has |
9a363fed |
260 | I<avoided> production versus development differences, not caused them. |
f9df7e2e |
261 | |
0eb0d037 |
262 | Additionally, L<strictures>' policy is very much "try and provide as much |
d8c1c6b2 |
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 |
f9df7e2e |
265 | is not sufficient to achieve that (I get to explain that you need to add |
d8c1c6b2 |
266 | C<use strict> at least once a week on freenode #perl -- newbies sometimes |
f9df7e2e |
267 | completely skip steps because they don't understand that that step |
268 | is important). |
269 | |
d8c1c6b2 |
270 | I make no claims that the heuristic is perfect -- it's already been evolved |
f9df7e2e |
271 | significantly over time, especially for 1.004 where we changed things to |
0eb0d037 |
272 | ensure it only fires on files in your checkout (rather than L<strictures>-using |
f9df7e2e |
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 |
3e14202f |
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". |
f9df7e2e |
278 | |
96c8649b |
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 | |
eae006ee |
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 | |
91be28bc |
311 | The web interface to the repository is at: |
312 | |
313 | http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git |
314 | |
eae006ee |
315 | =head1 AUTHOR |
316 | |
d81f898d |
317 | mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk> |
eae006ee |
318 | |
319 | =head1 CONTRIBUTORS |
320 | |
8190ff5b |
321 | Karen Etheridge (cpan:ETHER) <ether@cpan.org> |
eae006ee |
322 | |
04b4a35d |
323 | Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com> |
324 | |
a79d1096 |
325 | haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org> |
326 | |
eae006ee |
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 |