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