This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
lib/Fatal.pm missing from repository
[perl5.git] / lib / Fatal.pm
CommitLineData
e92e55da
MB
1package Fatal;
2
3use Carp;
4use strict;
5use vars qw( $AUTOLOAD $Debug $VERSION);
6
7$VERSION = 1.02;
8
9$Debug = 0 unless defined $Debug;
10
11sub import {
12 my $self = shift(@_);
13 my($sym, $pkg);
14 $pkg = (caller)[0];
15 foreach $sym (@_) {
16 &_make_fatal($sym, $pkg);
17 }
18};
19
20sub AUTOLOAD {
21 my $cmd = $AUTOLOAD;
22 $cmd =~ s/.*:://;
23 &_make_fatal($cmd, (caller)[0]);
24 goto &$AUTOLOAD;
25}
26
27sub fill_protos {
28 my $proto = shift;
29 my ($n, $isref, @out, @out1, $seen_semi) = -1;
30 while ($proto =~ /\S/) {
31 $n++;
32 push(@out1,[$n,@out]) if $seen_semi;
33 push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
34 push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
35 push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
36 $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
37 die "Unknown prototype letters: \"$proto\"";
38 }
39 push(@out1,[$n+1,@out]);
40 @out1;
41}
42
43sub write_invocation {
44 my ($core, $call, $name, @argvs) = @_;
45 if (@argvs == 1) { # No optional arguments
46 my @argv = @{$argvs[0]};
47 shift @argv;
48 return "\t" . one_invocation($core, $call, $name, @argv) . ";\n";
49 } else {
50 my $else = "\t";
51 my (@out, @argv, $n);
52 while (@argvs) {
53 @argv = @{shift @argvs};
54 $n = shift @argv;
55 push @out, "$ {else}if (\@_ == $n) {\n";
56 $else = "\t} els";
57 push @out,
58 "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
59 }
60 push @out, <<EOC;
61 }
62 die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
63EOC
64 return join '', @out;
65 }
66}
67
68sub one_invocation {
69 my ($core, $call, $name, @argv) = @_;
70 local $" = ', ';
71 return qq{$call(@argv) || croak "Can't $name(\@_)} .
72 ($core ? ': $!' : ', \$! is \"$!\"') . '"';
73}
74
75sub _make_fatal {
76 my($sub, $pkg) = @_;
77 my($name, $code, $sref, $real_proto, $proto, $core, $call);
78 my $ini = $sub;
79
80 $sub = "${pkg}::$sub" unless $sub =~ /::/;
81 $name = $sub;
82 $name =~ s/.*::// or $name =~ s/^&//;
83 print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug;
84 croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
85 if (defined(&$sub)) { # user subroutine
86 $sref = \&$sub;
87 $proto = prototype $sref;
88 $call = '&$sref';
89 } elsif ($sub eq $ini) { # Stray user subroutine
90 die "$sub is not a Perl subroutine"
91 } else { # CORE subroutine
92 $proto = eval { prototype "CORE::$name" };
93 die "$name is neither a builtin, nor a Perl subroutine"
94 if $@;
95 die "Cannot make a non-overridable builtin fatal"
96 if not defined $proto;
97 $core = 1;
98 $call = "CORE::$name";
99 }
100 if (defined $proto) {
101 $real_proto = " ($proto)";
102 } else {
103 $real_proto = '';
104 $proto = '@';
105 }
106 $code = <<EOS;
107sub$real_proto {
108 local(\$", \$!) = (', ', 0);
109EOS
110 my @protos = fill_protos($proto);
111 $code .= write_invocation($core, $call, $name, @protos);
112 $code .= "}\n";
113 print $code if $Debug;
114 $code = eval($code);
115 die if $@;
116 local($^W) = 0; # to avoid: Subroutine foo redefined ...
117 no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
118 *{$sub} = $code;
119}
120
1211;
122
123__END__
124
125=head1 NAME
126
127Fatal - replace functions with equivalents which succeed or die
128
129=head1 SYNOPSIS
130
131 use Fatal qw(open close);
132
133 sub juggle { . . . }
134 import Fatal 'juggle';
135
136=head1 DESCRIPTION
137
138C<Fatal> provides a way to conveniently replace functions which normally
139return a false value when they fail with equivalents which halt execution
140if they are not successful. This lets you use these functions without
141having to test their return values explicitly on each call. Errors are
142reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
143wish to take some action before the program exits.
144
145The do-or-die equivalents are set up simply by calling Fatal's
146C<import> routine, passing it the names of the functions to be
147replaced. You may wrap both user-defined functions and overridable
148CORE operators (except C<exec>, C<system> which cannot be expressed
149via prototypes) in this way.
150
151=head1 AUTHOR
152
153Lionel.Cons@cern.ch
154
155prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
156
157=cut