This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add a BUGS section to Fatal.pm, see bug #38790
[perl5.git] / lib / Fatal.pm
CommitLineData
e92e55da
MB
1package Fatal;
2
3b825e41 3use 5.006_001;
e92e55da
MB
4use Carp;
5use strict;
17f410f9 6our($AUTOLOAD, $Debug, $VERSION);
e92e55da 7
4d737ff8 8$VERSION = 1.04;
e92e55da
MB
9
10$Debug = 0 unless defined $Debug;
11
12sub import {
13 my $self = shift(@_);
14 my($sym, $pkg);
91c7a880 15 my $void = 0;
e92e55da
MB
16 $pkg = (caller)[0];
17 foreach $sym (@_) {
91c7a880
GS
18 if ($sym eq ":void") {
19 $void = 1;
20 }
21 else {
22 &_make_fatal($sym, $pkg, $void);
23 }
e92e55da
MB
24 }
25};
26
27sub AUTOLOAD {
28 my $cmd = $AUTOLOAD;
29 $cmd =~ s/.*:://;
30 &_make_fatal($cmd, (caller)[0]);
31 goto &$AUTOLOAD;
32}
33
34sub 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
50sub write_invocation {
91c7a880 51 my ($core, $call, $name, $void, @argvs) = @_;
e92e55da
MB
52 if (@argvs == 1) { # No optional arguments
53 my @argv = @{$argvs[0]};
54 shift @argv;
91c7a880 55 return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
e92e55da
MB
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,
91c7a880 65 "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
e92e55da
MB
66 }
67 push @out, <<EOC;
68 }
69 die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
70EOC
71 return join '', @out;
72 }
73}
74
75sub one_invocation {
91c7a880 76 my ($core, $call, $name, $void, @argv) = @_;
e92e55da 77 local $" = ', ';
91c7a880
GS
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 }
e92e55da
MB
86}
87
88sub _make_fatal {
91c7a880 89 my($sub, $pkg, $void) = @_;
e92e55da
MB
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/^&//;
91c7a880 96 print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
e92e55da
MB
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;
120sub$real_proto {
121 local(\$", \$!) = (', ', 0);
122EOS
123 my @protos = fill_protos($proto);
91c7a880 124 $code .= write_invocation($core, $call, $name, $void, @protos);
e92e55da
MB
125 $code .= "}\n";
126 print $code if $Debug;
2ba6ecf4
GS
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 $@;
db376a24 131 no warnings; # to avoid: Subroutine foo redefined ...
2ba6ecf4
GS
132 *{$sub} = $code;
133 }
e92e55da
MB
134}
135
1361;
137
138__END__
139
140=head1 NAME
141
142Fatal - 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
153C<Fatal> provides a way to conveniently replace functions which normally
59d9ee20 154return a false value when they fail with equivalents which raise exceptions
e92e55da 155if they are not successful. This lets you use these functions without
59d9ee20
GS
156having to test their return values explicitly on each call. Exceptions
157can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details.
e92e55da
MB
158
159The do-or-die equivalents are set up simply by calling Fatal's
160C<import> routine, passing it the names of the functions to be
161replaced. You may wrap both user-defined functions and overridable
162CORE operators (except C<exec>, C<system> which cannot be expressed
163via prototypes) in this way.
164
91c7a880
GS
165If the symbol C<:void> appears in the import list, then functions
166named later in that import list raise an exception only when
167these are called in void context--that is, when their return
168values 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
a6fd7f3f
RGS
180=head1 BUGS
181
182You should not fatalize functions that are called in list context, because this
183module tests whether a function has failed by testing the boolean truth of its
184return value in scalar context.
185
e92e55da
MB
186=head1 AUTHOR
187
10af26ed 188Lionel Cons (CERN).
e92e55da 189
10af26ed 190Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>.
e92e55da
MB
191
192=cut