Bump up versions because of #12041.
[p5sagit/p5-mst-13.2.git] / lib / Fatal.pm
1 package Fatal;
2
3 use 5.6.1;
4 use Carp;
5 use strict;
6 our($AUTOLOAD, $Debug, $VERSION);
7
8 $VERSION = 1.03;
9
10 $Debug = 0 unless defined $Debug;
11
12 sub import {
13     my $self = shift(@_);
14     my($sym, $pkg);
15     my $void = 0;
16     $pkg = (caller)[0];
17     foreach $sym (@_) {
18         if ($sym eq ":void") {
19             $void = 1;
20         }
21         else {
22             &_make_fatal($sym, $pkg, $void);
23         }
24     }
25 };
26
27 sub AUTOLOAD {
28     my $cmd = $AUTOLOAD;
29     $cmd =~ s/.*:://;
30     &_make_fatal($cmd, (caller)[0]);
31     goto &$AUTOLOAD;
32 }
33
34 sub fill_protos {
35   my $proto = shift;
36   my ($n, $isref, @out, @out1, $seen_semi) = -1;
37   while ($proto =~ /\S/) {
38     $n++;
39     push(@out1,[$n,@out]) if $seen_semi;
40     push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
41     push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
42     push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
43     $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
44     die "Unknown prototype letters: \"$proto\"";
45   }
46   push(@out1,[$n+1,@out]);
47   @out1;
48 }
49
50 sub write_invocation {
51   my ($core, $call, $name, $void, @argvs) = @_;
52   if (@argvs == 1) {            # No optional arguments
53     my @argv = @{$argvs[0]};
54     shift @argv;
55     return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
56   } else {
57     my $else = "\t";
58     my (@out, @argv, $n);
59     while (@argvs) {
60       @argv = @{shift @argvs};
61       $n = shift @argv;
62       push @out, "$ {else}if (\@_ == $n) {\n";
63       $else = "\t} els";
64       push @out, 
65           "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
66     }
67     push @out, <<EOC;
68         }
69         die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
70 EOC
71     return join '', @out;
72   }
73 }
74
75 sub one_invocation {
76   my ($core, $call, $name, $void, @argv) = @_;
77   local $" = ', ';
78   if ($void) { 
79     return qq/(defined wantarray)?$call(@argv):
80               $call(@argv) || croak "Can't $name(\@_)/ . 
81            ($core ? ': $!' : ', \$! is \"$!\"') . '"'
82   } else {
83     return qq{$call(@argv) || croak "Can't $name(\@_)} . 
84            ($core ? ': $!' : ', \$! is \"$!\"') . '"';
85   }
86 }
87
88 sub _make_fatal {
89     my($sub, $pkg, $void) = @_;
90     my($name, $code, $sref, $real_proto, $proto, $core, $call);
91     my $ini = $sub;
92
93     $sub = "${pkg}::$sub" unless $sub =~ /::/;
94     $name = $sub;
95     $name =~ s/.*::// or $name =~ s/^&//;
96     print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
97     croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
98     if (defined(&$sub)) {       # user subroutine
99         $sref = \&$sub;
100         $proto = prototype $sref;
101         $call = '&$sref';
102     } elsif ($sub eq $ini) {    # Stray user subroutine
103         die "$sub is not a Perl subroutine" 
104     } else {                    # CORE subroutine
105         $proto = eval { prototype "CORE::$name" };
106         die "$name is neither a builtin, nor a Perl subroutine" 
107           if $@;
108         die "Cannot make a non-overridable builtin fatal"
109           if not defined $proto;
110         $core = 1;
111         $call = "CORE::$name";
112     }
113     if (defined $proto) {
114       $real_proto = " ($proto)";
115     } else {
116       $real_proto = '';
117       $proto = '@';
118     }
119     $code = <<EOS;
120 sub$real_proto {
121         local(\$", \$!) = (', ', 0);
122 EOS
123     my @protos = fill_protos($proto);
124     $code .= write_invocation($core, $call, $name, $void, @protos);
125     $code .= "}\n";
126     print $code if $Debug;
127     {
128       no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
129       $code = eval("package $pkg; use Carp; $code");
130       die if $@;
131       no warnings;   # to avoid: Subroutine foo redefined ...
132       *{$sub} = $code;
133     }
134 }
135
136 1;
137
138 __END__
139
140 =head1 NAME
141
142 Fatal - replace functions with equivalents which succeed or die
143
144 =head1 SYNOPSIS
145
146     use Fatal qw(open close);
147
148     sub juggle { . . . }
149     import Fatal 'juggle';
150
151 =head1 DESCRIPTION
152
153 C<Fatal> provides a way to conveniently replace functions which normally
154 return a false value when they fail with equivalents which raise exceptions
155 if they are not successful.  This lets you use these functions without
156 having to test their return values explicitly on each call.  Exceptions
157 can be caught using C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
158
159 The do-or-die equivalents are set up simply by calling Fatal's
160 C<import> routine, passing it the names of the functions to be
161 replaced.  You may wrap both user-defined functions and overridable
162 CORE operators (except C<exec>, C<system> which cannot be expressed
163 via prototypes) in this way.
164
165 If the symbol C<:void> appears in the import list, then functions
166 named later in that import list raise an exception only when
167 these are called in void context--that is, when their return
168 values are ignored.  For example
169
170         use Fatal qw/:void open close/;
171
172         # properly checked, so no exception raised on error
173         if(open(FH, "< /bogotic") {
174                 warn "bogo file, dude: $!";
175         }
176
177         # not checked, so error raises an exception
178         close FH;
179
180 =head1 AUTHOR
181
182 Lionel.Cons@cern.ch
183
184 prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
185
186 =cut