6 our($AUTOLOAD, $Debug, $VERSION);
10 $Debug = 0 unless defined $Debug;
17 &_make_fatal($sym, $pkg);
24 &_make_fatal($cmd, (caller)[0]);
30 my ($n, $isref, @out, @out1, $seen_semi) = -1;
31 while ($proto =~ /\S/) {
33 push(@out1,[$n,@out]) if $seen_semi;
34 push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
35 push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
36 push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
37 $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
38 die "Unknown prototype letters: \"$proto\"";
40 push(@out1,[$n+1,@out]);
44 sub write_invocation {
45 my ($core, $call, $name, @argvs) = @_;
46 if (@argvs == 1) { # No optional arguments
47 my @argv = @{$argvs[0]};
49 return "\t" . one_invocation($core, $call, $name, @argv) . ";\n";
54 @argv = @{shift @argvs};
56 push @out, "$ {else}if (\@_ == $n) {\n";
59 "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
63 die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
70 my ($core, $call, $name, @argv) = @_;
72 return qq{$call(@argv) || croak "Can't $name(\@_)} .
73 ($core ? ': $!' : ', \$! is \"$!\"') . '"';
78 my($name, $code, $sref, $real_proto, $proto, $core, $call);
81 $sub = "${pkg}::$sub" unless $sub =~ /::/;
83 $name =~ s/.*::// or $name =~ s/^&//;
84 print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug;
85 croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
86 if (defined(&$sub)) { # user subroutine
88 $proto = prototype $sref;
90 } elsif ($sub eq $ini) { # Stray user subroutine
91 die "$sub is not a Perl subroutine"
92 } else { # CORE subroutine
93 $proto = eval { prototype "CORE::$name" };
94 die "$name is neither a builtin, nor a Perl subroutine"
96 die "Cannot make a non-overridable builtin fatal"
97 if not defined $proto;
99 $call = "CORE::$name";
101 if (defined $proto) {
102 $real_proto = " ($proto)";
109 local(\$", \$!) = (', ', 0);
111 my @protos = fill_protos($proto);
112 $code .= write_invocation($core, $call, $name, @protos);
114 print $code if $Debug;
116 no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
117 $code = eval("package $pkg; use Carp; $code");
119 no warnings; # to avoid: Subroutine foo redefined ...
130 Fatal - replace functions with equivalents which succeed or die
134 use Fatal qw(open close);
137 import Fatal 'juggle';
141 C<Fatal> provides a way to conveniently replace functions which normally
142 return a false value when they fail with equivalents which raise exceptions
143 if they are not successful. This lets you use these functions without
144 having to test their return values explicitly on each call. Exceptions
145 can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
147 The do-or-die equivalents are set up simply by calling Fatal's
148 C<import> routine, passing it the names of the functions to be
149 replaced. You may wrap both user-defined functions and overridable
150 CORE operators (except C<exec>, C<system> which cannot be expressed
151 via prototypes) in this way.
157 prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu