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