better error messages when xsubpp fails to find map for a particular
[p5sagit/p5-mst-13.2.git] / lib / Fatal.pm
CommitLineData
e92e55da 1package Fatal;
2
17f410f9 3use 5.005_64;
e92e55da 4use Carp;
5use strict;
17f410f9 6our($AUTOLOAD, $Debug, $VERSION);
e92e55da 7
8$VERSION = 1.02;
9
10$Debug = 0 unless defined $Debug;
11
12sub import {
13 my $self = shift(@_);
14 my($sym, $pkg);
15 $pkg = (caller)[0];
16 foreach $sym (@_) {
17 &_make_fatal($sym, $pkg);
18 }
19};
20
21sub AUTOLOAD {
22 my $cmd = $AUTOLOAD;
23 $cmd =~ s/.*:://;
24 &_make_fatal($cmd, (caller)[0]);
25 goto &$AUTOLOAD;
26}
27
28sub 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
44sub 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";
64EOC
65 return join '', @out;
66 }
67}
68
69sub one_invocation {
70 my ($core, $call, $name, @argv) = @_;
71 local $" = ', ';
72 return qq{$call(@argv) || croak "Can't $name(\@_)} .
73 ($core ? ': $!' : ', \$! is \"$!\"') . '"';
74}
75
76sub _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;
108sub$real_proto {
109 local(\$", \$!) = (', ', 0);
110EOS
111 my @protos = fill_protos($proto);
112 $code .= write_invocation($core, $call, $name, @protos);
113 $code .= "}\n";
114 print $code if $Debug;
2ba6ecf4 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 $@;
db376a24 119 no warnings; # to avoid: Subroutine foo redefined ...
2ba6ecf4 120 *{$sub} = $code;
121 }
e92e55da 122}
123
1241;
125
126__END__
127
128=head1 NAME
129
130Fatal - 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
141C<Fatal> provides a way to conveniently replace functions which normally
142return a false value when they fail with equivalents which halt execution
143if they are not successful. This lets you use these functions without
144having to test their return values explicitly on each call. Errors are
145reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
146wish to take some action before the program exits.
147
148The do-or-die equivalents are set up simply by calling Fatal's
149C<import> routine, passing it the names of the functions to be
150replaced. You may wrap both user-defined functions and overridable
151CORE operators (except C<exec>, C<system> which cannot be expressed
152via prototypes) in this way.
153
154=head1 AUTHOR
155
156Lionel.Cons@cern.ch
157
158prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
159
160=cut