This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
29044 broke Fatal.pm
[perl5.git] / lib / Fatal.pm
1 package Fatal;
2
3 use 5.006_001;
4 use Carp;
5 use strict;
6 our($AUTOLOAD, $Debug, $VERSION);
7
8 $VERSION = 1.05;
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 && $sub !~ /^CORE::GLOBAL::/) {
103         # Stray user subroutine
104         die "$sub is not a Perl subroutine" 
105     } else {                    # CORE subroutine
106         $proto = eval { prototype "CORE::$name" };
107         die "$name is neither a builtin, nor a Perl subroutine" 
108           if $@;
109         die "Cannot make a non-overridable builtin fatal"
110           if not defined $proto;
111         $core = 1;
112         $call = "CORE::$name";
113     }
114     if (defined $proto) {
115       $real_proto = " ($proto)";
116     } else {
117       $real_proto = '';
118       $proto = '@';
119     }
120     $code = <<EOS;
121 sub$real_proto {
122         local(\$", \$!) = (', ', 0);
123 EOS
124     my @protos = fill_protos($proto);
125     $code .= write_invocation($core, $call, $name, $void, @protos);
126     $code .= "}\n";
127     print $code if $Debug;
128     {
129       no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
130       $code = eval("package $pkg; use Carp; $code");
131       die if $@;
132       no warnings;   # to avoid: Subroutine foo redefined ...
133       *{$sub} = $code;
134     }
135 }
136
137 1;
138
139 __END__
140
141 =head1 NAME
142
143 Fatal - replace functions with equivalents which succeed or die
144
145 =head1 SYNOPSIS
146
147     use Fatal qw(open close);
148
149     sub juggle { . . . }
150     import Fatal 'juggle';
151
152 =head1 DESCRIPTION
153
154 C<Fatal> provides a way to conveniently replace functions which normally
155 return a false value when they fail with equivalents which raise exceptions
156 if they are not successful.  This lets you use these functions without
157 having to test their return values explicitly on each call.  Exceptions
158 can be caught using C<eval{}>.  See L<perlfunc> and L<perlvar> for details.
159
160 The do-or-die equivalents are set up simply by calling Fatal's
161 C<import> routine, passing it the names of the functions to be
162 replaced.  You may wrap both user-defined functions and overridable
163 CORE operators (except C<exec>, C<system> which cannot be expressed
164 via prototypes) in this way.
165
166 If the symbol C<:void> appears in the import list, then functions
167 named later in that import list raise an exception only when
168 these are called in void context--that is, when their return
169 values are ignored.  For example
170
171         use Fatal qw/:void open close/;
172
173         # properly checked, so no exception raised on error
174         if(open(FH, "< /bogotic") {
175                 warn "bogo file, dude: $!";
176         }
177
178         # not checked, so error raises an exception
179         close FH;
180
181 =head1 BUGS
182
183 You should not fatalize functions that are called in list context, because this
184 module tests whether a function has failed by testing the boolean truth of its
185 return value in scalar context.
186
187 =head1 AUTHOR
188
189 Lionel Cons (CERN).
190
191 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
192
193 =cut