f5ba5d832b1d6b70ae4bffe2774a343b587706d4
[perl.git] / lib / autodie / hints.pm
1 package autodie::hints;
2
3 use strict;
4 use warnings;
5
6 use constant PERL58 => ( $] < 5.009 );
7
8 our $VERSION = '2.06';
9
10 =head1 NAME
11
12 autodie::hints - Provide hints about user subroutines to autodie
13
14 =head1 SYNOPSIS
15
16     package Your::Module;
17
18     our %DOES = ( 'autodie::hints::provider' => 1 );
19
20     sub AUTODIE_HINTS {
21         return {
22             foo => { scalar => HINTS, list => SOME_HINTS },
23             bar => { scalar => HINTS, list => MORE_HINTS },
24         }
25     }
26
27     # Later, in your main program...
28
29     use Your::Module qw(foo bar);
30     use autodie      qw(:default foo bar);
31
32     foo();         # succeeds or dies based on scalar hints
33
34     # Alternatively, hints can be set on subroutines we've
35     # imported.
36
37     use autodie::hints;
38     use Some::Module qw(think_positive);
39
40     BEGIN {
41         autodie::hints->set_hints_for(
42             \&think_positive,
43             {
44                 fail => sub { $_[0] <= 0 }
45             }
46         )
47     }
48     use autodie qw(think_positive);
49
50     think_positive(...);    # Returns positive or dies.
51
52
53 =head1 DESCRIPTION
54
55 =head2 Introduction
56
57 The L<autodie> pragma is very smart when it comes to working with
58 Perl's built-in functions.  The behaviour for these functions are
59 fixed, and C<autodie> knows exactly how they try to signal failure.
60
61 But what about user-defined subroutines from modules?  If you use
62 C<autodie> on a user-defined subroutine then it assumes the following
63 behaviour to demonstrate failure:
64
65 =over
66
67 =item *
68
69 A false value, in scalar context
70
71 =item * 
72
73 An empty list, in list context
74
75 =item *
76
77 A list containing a single undef, in list context
78
79 =back
80
81 All other return values (including the list of the single zero, and the
82 list containing a single empty string) are considered successful.  However,
83 real-world code isn't always that easy.  Perhaps the code you're working
84 with returns a string containing the word "FAIL" upon failure, or a
85 two element list containing C<(undef, "human error message")>.  To make
86 autodie work with these sorts of subroutines, we have
87 the I<hinting interface>.
88
89 The hinting interface allows I<hints> to be provided to C<autodie>
90 on how it should detect failure from user-defined subroutines.  While
91 these I<can> be provided by the end-user of C<autodie>, they are ideally
92 written into the module itself, or into a helper module or sub-class
93 of C<autodie> itself.
94
95 =head2 What are hints?
96
97 A I<hint> is a subroutine or value that is checked against the
98 return value of an autodying subroutine.  If the match returns true,
99 C<autodie> considers the subroutine to have failed.
100
101 If the hint provided is a subroutine, then C<autodie> will pass
102 the complete return value to that subroutine.  If the hint is
103 any other value, then C<autodie> will smart-match against the
104 value provided.  In Perl 5.8.x there is no smart-match operator, and as such
105 only subroutine hints are supported in these versions.
106
107 Hints can be provided for both scalar and list contexts.  Note
108 that an autodying subroutine will never see a void context, as
109 C<autodie> always needs to capture the return value for examination.
110 Autodying subroutines called in void context act as if they're called
111 in a scalar context, but their return value is discarded after it
112 has been checked.
113
114 =head2 Example hints
115
116 Hints may consist of scalars, array references, regular expressions and
117 subroutine references.  You can specify different hints for how
118 failure should be identified in scalar and list contexts.
119
120 These examples apply for use in the C<AUTODIE_HINTS> subroutine and when
121 calling C<autodie::hints->set_hints_for()>.
122
123 The most common context-specific hints are:
124
125         # Scalar failures always return undef:
126             {  scalar => undef  }
127
128         # Scalar failures return any false value [default expectation]:
129             {  scalar => sub { ! $_[0] }  }
130
131         # Scalar failures always return zero explicitly:
132             {  scalar => '0'  }
133
134         # List failures always return an empty list:
135             {  list => []  }
136
137         # List failures return () or (undef) [default expectation]:
138             {  list => sub { ! @_ || @_ == 1 && !defined $_[0] }  }
139
140         # List failures return () or a single false value:
141             {  list => sub { ! @_ || @_ == 1 && !$_[0] }  }
142
143         # List failures return (undef, "some string")
144             {  list => sub { @_ == 2 && !defined $_[0] }  }
145
146         # Unsuccessful foo() returns 'FAIL' or '_FAIL' in scalar context,
147         #                    returns (-1) in list context...
148         autodie::hints->set_hints_for(
149             \&foo,
150             {
151                 scalar => qr/^ _? FAIL $/xms,
152                 list   => [-1],
153             }
154         );
155
156         # Unsuccessful foo() returns 0 in all contexts...
157         autodie::hints->set_hints_for(
158             \&foo,
159             {
160                 scalar => 0,
161                 list   => [0],
162             }
163         );
164
165 This "in all contexts" construction is very common, and can be
166 abbreviated, using the 'fail' key.  This sets both the C<scalar>
167 and C<list> hints to the same value:
168
169         # Unsuccessful foo() returns 0 in all contexts...
170         autodie::hints->set_hints_for(
171             \&foo,
172             {
173                 fail => sub { @_ == 1 and defined $_[0] and $_[0] == 0 }
174             }
175         );
176
177         # Unsuccessful think_positive() returns negative number on failure...
178         autodie::hints->set_hints_for(
179             \&think_positive,
180             {
181                 fail => sub { $_[0] < 0 }
182             }
183         );
184
185         # Unsuccessful my_system() returns non-zero on failure...
186         autodie::hints->set_hints_for(
187             \&my_system,
188             {
189                 fail => sub { $_[0] != 0 }
190             }
191         );
192
193 =head1 Manually setting hints from within your program
194
195 If you are using a module which returns something special on failure, then
196 you can manually create hints for each of the desired subroutines.  Once
197 the hints are specified, they are available for all files and modules loaded
198 thereafter, thus you can move this work into a module and it will still
199 work.
200
201         use Some::Module qw(foo bar);
202         use autodie::hints;
203
204         autodie::hints->set_hints_for(
205                 \&foo,
206                 {
207                         scalar => SCALAR_HINT,
208                         list   => LIST_HINT,
209                 }
210         );
211         autodie::hints->set_hints_for(
212                 \&bar,
213                 { fail => SOME_HINT, }
214         );
215
216 It is possible to pass either a subroutine reference (recommended) or a fully
217 qualified subroutine name as the first argument.  This means you can set hints
218 on modules that I<might> get loaded:
219
220         use autodie::hints;
221         autodie::hints->set_hints_for(
222                 'Some::Module:bar', { fail => SCALAR_HINT, }
223         );
224
225 This technique is most useful when you have a project that uses a
226 lot of third-party modules.  You can define all your possible hints
227 in one-place.  This can even be in a sub-class of autodie.  For
228 example:
229
230         package my::autodie;
231
232         use parent qw(autodie);
233         use autodie::hints;
234
235         autodie::hints->set_hints_for(...);
236
237         1;
238
239 You can now C<use my::autodie>, which will work just like the standard
240 C<autodie>, but is now aware of any hints that you've set.
241
242 =head1 Adding hints to your module
243
244 C<autodie> provides a passive interface to allow you to declare hints for
245 your module.  These hints will be found and used by C<autodie> if it
246 is loaded, but otherwise have no effect (or dependencies) without autodie.
247 To set these, your module needs to declare that it I<does> the
248 C<autodie::hints::provider> role.  This can be done by writing your
249 own C<DOES> method, using a system such as C<Class::DOES> to handle
250 the heavy-lifting for you, or declaring a C<%DOES> package variable
251 with a C<autodie::hints::provider> key and a corresponding true value.
252
253 Note that checking for a C<%DOES> hash is an C<autodie>-only
254 short-cut.  Other modules do not use this mechanism for checking
255 roles, although you can use the C<Class::DOES> module from the
256 CPAN to allow it.
257
258 In addition, you must define a C<AUTODIE_HINTS> subroutine that returns
259 a hash-reference containing the hints for your subroutines:
260
261         package Your::Module;
262
263         # We can use the Class::DOES from the CPAN to declare adherence
264         # to a role.
265
266         use Class::DOES 'autodie::hints::provider' => 1;
267
268         # Alternatively, we can declare the role in %DOES.  Note that
269         # this is an autodie specific optimisation, although Class::DOES
270         # can be used to promote this to a true role declaration.
271
272         our %DOES = ( 'autodie::hints::provider' => 1 );
273
274         # Finally, we must define the hints themselves.
275
276         sub AUTODIE_HINTS {
277             return {
278                 foo => { scalar => HINTS, list => SOME_HINTS },
279                 bar => { scalar => HINTS, list => MORE_HINTS },
280                 baz => { fail => HINTS },
281             }
282         }
283
284 This allows your code to set hints without relying on C<autodie> and
285 C<autodie::hints> being loaded, or even installed.  In this way your
286 code can do the right thing when C<autodie> is installed, but does not
287 need to depend upon it to function.
288
289 =head1 Insisting on hints
290
291 When a user-defined subroutine is wrapped by C<autodie>, it will
292 use hints if they are available, and otherwise reverts to the
293 I<default behaviour> described in the introduction of this document.
294 This can be problematic if we expect a hint to exist, but (for
295 whatever reason) it has not been loaded.
296
297 We can ask autodie to I<insist> that a hint be used by prefixing
298 an exclamation mark to the start of the subroutine name.  A lone
299 exclamation mark indicates that I<all> subroutines after it must
300 have hints declared.
301
302         # foo() and bar() must have their hints defined
303         use autodie qw( !foo !bar baz );
304
305         # Everything must have hints (recommended).
306         use autodie qw( ! foo bar baz );
307
308         # bar() and baz() must have their hints defined
309         use autodie qw( foo ! bar baz );
310
311         # Enable autodie for all of Perl's supported built-ins,
312         # as well as for foo(), bar() and baz().  Everything must
313         # have hints.
314         use autodie qw( ! :all foo bar baz );
315
316 If hints are not available for the specified subroutines, this will cause a
317 compile-time error.  Insisting on hints for Perl's built-in functions
318 (eg, C<open> and C<close>) is always successful.
319
320 Insisting on hints is I<strongly> recommended.
321
322 =cut
323
324 # TODO: implement regular expression hints
325
326 use constant UNDEF_ONLY       => sub { not defined $_[0] };
327 use constant EMPTY_OR_UNDEF   => sub {
328     ! @_ or
329     @_==1 && !defined $_[0]
330 };
331
332 use constant EMPTY_ONLY     => sub { @_ == 0 };
333 use constant EMPTY_OR_FALSE => sub {
334     ! @_ or
335     @_==1 && !$_[0]
336 };
337
338 use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] };
339
340 use constant DEFAULT_HINTS => {
341     scalar => UNDEF_ONLY,
342     list   => EMPTY_OR_UNDEF,
343 };
344
345
346 use constant HINTS_PROVIDER => 'autodie::hints::provider';
347
348 use base qw(Exporter);
349
350 our $DEBUG = 0;
351
352 # Only ( undef ) is a strange but possible situation for very
353 # badly written code.  It's not supported yet.
354
355 my %Hints = (
356     'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
357     'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
358     'File::Copy::cp'   => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
359     'File::Copy::mv'   => { scalar => SINGLE_TRUE, list => SINGLE_TRUE },
360 );
361
362 # Start by using Sub::Identify if it exists on this system.
363
364 eval { require Sub::Identify; Sub::Identify->import('get_code_info'); };
365
366 # If it doesn't exist, we'll define our own.  This code is directly
367 # taken from Rafael Garcia's Sub::Identify 0.04, used under the same
368 # license as Perl itself.
369
370 if ($@) {
371     require B;
372
373     no warnings 'once';
374
375     *get_code_info = sub ($) {
376
377         my ($coderef) = @_;
378         ref $coderef or return;
379         my $cv = B::svref_2object($coderef);
380         $cv->isa('B::CV') or return;
381         # bail out if GV is undefined
382         $cv->GV->isa('B::SPECIAL') and return;
383
384         return ($cv->GV->STASH->NAME, $cv->GV->NAME);
385     };
386
387 }
388
389 sub sub_fullname {
390     return join( '::', get_code_info( $_[1] ) );
391 }
392
393 my %Hints_loaded = ();
394
395 sub load_hints {
396     my ($class, $sub) = @_;
397
398     my ($package) = ( $sub =~ /(.*)::/ );
399
400     if (not defined $package) {
401         require Carp;
402         Carp::croak(
403             "Internal error in autodie::hints::load_hints - no package found.
404         ");
405     }
406
407     # Do nothing if we've already tried to load hints for
408     # this package.
409     return if $Hints_loaded{$package}++;
410
411     my $hints_available = 0;
412
413     {
414         no strict 'refs';   ## no critic
415
416         if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) {
417             $hints_available = 1;
418         }
419         elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) {
420             $hints_available = 1;
421         }
422         elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) {
423             $hints_available = 1;
424         }
425     }
426
427     return if not $hints_available;
428
429     my %package_hints = %{ $package->AUTODIE_HINTS };
430
431     foreach my $sub (keys %package_hints) {
432
433         my $hint = $package_hints{$sub};
434
435         # Ensure we have a package name.
436         $sub = "${package}::$sub" if $sub !~ /::/;
437
438         # TODO - Currently we don't check for conflicts, should we?
439         $Hints{$sub} = $hint;
440
441         $class->normalise_hints(\%Hints, $sub);
442     }
443
444     return;
445
446 }
447
448 sub normalise_hints {
449     my ($class, $hints, $sub) = @_;
450
451     if ( exists $hints->{$sub}->{fail} ) {
452
453         if ( exists $hints->{$sub}->{scalar} or
454              exists $hints->{$sub}->{list}
455         ) {
456             # TODO: Turn into a proper diagnostic.
457             require Carp;
458             local $Carp::CarpLevel = 1;
459             Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub");
460         }
461
462         # Set our scalar and list hints.
463
464         $hints->{$sub}->{scalar} = 
465         $hints->{$sub}->{list} = delete $hints->{$sub}->{fail};
466
467         return;
468
469     }
470
471     # Check to make sure all our hints exist.
472
473     foreach my $hint (qw(scalar list)) {
474         if ( not exists $hints->{$sub}->{$hint} ) {
475             # TODO: Turn into a proper diagnostic.
476             require Carp;
477             local $Carp::CarpLevel = 1;
478             Carp::croak("$hint hint missing for $sub");
479         }
480     }
481
482     return;
483 }
484
485 sub get_hints_for {
486     my ($class, $sub) = @_;
487
488     my $subname = $class->sub_fullname( $sub );
489
490     # If we have hints loaded for a sub, then return them.
491
492     if ( exists $Hints{ $subname } ) {
493         return $Hints{ $subname };
494     }
495
496     # If not, we try to load them...
497
498     $class->load_hints( $subname );
499
500     # ...and try again!
501
502     if ( exists $Hints{ $subname } ) {
503         return $Hints{ $subname };
504     }
505
506     # It's the caller's responsibility to use defaults if desired.
507     # This allows on autodie to insist on hints if needed.
508
509     return;
510
511 }
512
513 sub set_hints_for {
514     my ($class, $sub, $hints) = @_;
515
516     if (ref $sub) {
517         $sub = $class->sub_fullname( $sub );
518
519         require Carp;
520
521         $sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine");
522     }
523
524     if ($DEBUG) {
525         warn "autodie::hints: Setting $sub to hints: $hints\n";
526     }
527
528     $Hints{ $sub } = $hints;
529
530     $class->normalise_hints(\%Hints, $sub);
531
532     return;
533 }
534
535 1;
536
537 __END__
538
539
540 =head1 Diagnostics
541
542 =over 4
543
544 =item Attempts to set_hints_for unidentifiable subroutine
545
546 You've called C<< autodie::hints->set_hints_for() >> using a subroutine
547 reference, but that reference could not be resolved back to a
548 subroutine name.  It may be an anonymous subroutine (which can't
549 be made autodying), or may lack a name for other reasons.
550
551 If you receive this error with a subroutine that has a real name,
552 then you may have found a bug in autodie.  See L<autodie/BUGS>
553 for how to report this.
554
555 =item fail hints cannot be provided with either scalar or list hints for %s
556
557 When defining hints, you can either supply both C<list> and
558 C<scalar> keywords, I<or> you can provide a single C<fail> keyword.
559 You can't mix and match them.
560
561 =item %s hint missing for %s
562
563 You've provided either a C<scalar> hint without supplying
564 a C<list> hint, or vice-versa.  You I<must> supply both C<scalar>
565 and C<list> hints, I<or> a single C<fail> hint.
566
567 =back
568
569 =head1 ACKNOWLEDGEMENTS
570
571 =over 
572
573 =item *
574
575 Dr Damian Conway for suggesting the hinting interface and providing the
576 example usage.
577
578 =item *
579
580 Jacinta Richardson for translating much of my ideas into this
581 documentation.
582
583 =back
584
585 =head1 AUTHOR
586
587 Copyright 2009, Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>
588
589 =head1 LICENSE
590
591 This module is free software.  You may distribute it under the
592 same terms as Perl itself.
593
594 =head1 SEE ALSO
595
596 L<autodie>, L<Class::DOES>
597
598 =cut