1*0Sstevel@tonic-gatepackage Fatal; 2*0Sstevel@tonic-gate 3*0Sstevel@tonic-gateuse 5.006_001; 4*0Sstevel@tonic-gateuse Carp; 5*0Sstevel@tonic-gateuse strict; 6*0Sstevel@tonic-gateour($AUTOLOAD, $Debug, $VERSION); 7*0Sstevel@tonic-gate 8*0Sstevel@tonic-gate$VERSION = 1.03; 9*0Sstevel@tonic-gate 10*0Sstevel@tonic-gate$Debug = 0 unless defined $Debug; 11*0Sstevel@tonic-gate 12*0Sstevel@tonic-gatesub import { 13*0Sstevel@tonic-gate my $self = shift(@_); 14*0Sstevel@tonic-gate my($sym, $pkg); 15*0Sstevel@tonic-gate my $void = 0; 16*0Sstevel@tonic-gate $pkg = (caller)[0]; 17*0Sstevel@tonic-gate foreach $sym (@_) { 18*0Sstevel@tonic-gate if ($sym eq ":void") { 19*0Sstevel@tonic-gate $void = 1; 20*0Sstevel@tonic-gate } 21*0Sstevel@tonic-gate else { 22*0Sstevel@tonic-gate &_make_fatal($sym, $pkg, $void); 23*0Sstevel@tonic-gate } 24*0Sstevel@tonic-gate } 25*0Sstevel@tonic-gate}; 26*0Sstevel@tonic-gate 27*0Sstevel@tonic-gatesub AUTOLOAD { 28*0Sstevel@tonic-gate my $cmd = $AUTOLOAD; 29*0Sstevel@tonic-gate $cmd =~ s/.*:://; 30*0Sstevel@tonic-gate &_make_fatal($cmd, (caller)[0]); 31*0Sstevel@tonic-gate goto &$AUTOLOAD; 32*0Sstevel@tonic-gate} 33*0Sstevel@tonic-gate 34*0Sstevel@tonic-gatesub fill_protos { 35*0Sstevel@tonic-gate my $proto = shift; 36*0Sstevel@tonic-gate my ($n, $isref, @out, @out1, $seen_semi) = -1; 37*0Sstevel@tonic-gate while ($proto =~ /\S/) { 38*0Sstevel@tonic-gate $n++; 39*0Sstevel@tonic-gate push(@out1,[$n,@out]) if $seen_semi; 40*0Sstevel@tonic-gate push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; 41*0Sstevel@tonic-gate push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//; 42*0Sstevel@tonic-gate push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; 43*0Sstevel@tonic-gate $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? 44*0Sstevel@tonic-gate die "Unknown prototype letters: \"$proto\""; 45*0Sstevel@tonic-gate } 46*0Sstevel@tonic-gate push(@out1,[$n+1,@out]); 47*0Sstevel@tonic-gate @out1; 48*0Sstevel@tonic-gate} 49*0Sstevel@tonic-gate 50*0Sstevel@tonic-gatesub write_invocation { 51*0Sstevel@tonic-gate my ($core, $call, $name, $void, @argvs) = @_; 52*0Sstevel@tonic-gate if (@argvs == 1) { # No optional arguments 53*0Sstevel@tonic-gate my @argv = @{$argvs[0]}; 54*0Sstevel@tonic-gate shift @argv; 55*0Sstevel@tonic-gate return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n"; 56*0Sstevel@tonic-gate } else { 57*0Sstevel@tonic-gate my $else = "\t"; 58*0Sstevel@tonic-gate my (@out, @argv, $n); 59*0Sstevel@tonic-gate while (@argvs) { 60*0Sstevel@tonic-gate @argv = @{shift @argvs}; 61*0Sstevel@tonic-gate $n = shift @argv; 62*0Sstevel@tonic-gate push @out, "$ {else}if (\@_ == $n) {\n"; 63*0Sstevel@tonic-gate $else = "\t} els"; 64*0Sstevel@tonic-gate push @out, 65*0Sstevel@tonic-gate "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n"; 66*0Sstevel@tonic-gate } 67*0Sstevel@tonic-gate push @out, <<EOC; 68*0Sstevel@tonic-gate } 69*0Sstevel@tonic-gate die "$name(\@_): Do not expect to get ", scalar \@_, " arguments"; 70*0Sstevel@tonic-gateEOC 71*0Sstevel@tonic-gate return join '', @out; 72*0Sstevel@tonic-gate } 73*0Sstevel@tonic-gate} 74*0Sstevel@tonic-gate 75*0Sstevel@tonic-gatesub one_invocation { 76*0Sstevel@tonic-gate my ($core, $call, $name, $void, @argv) = @_; 77*0Sstevel@tonic-gate local $" = ', '; 78*0Sstevel@tonic-gate if ($void) { 79*0Sstevel@tonic-gate return qq/(defined wantarray)?$call(@argv): 80*0Sstevel@tonic-gate $call(@argv) || croak "Can't $name(\@_)/ . 81*0Sstevel@tonic-gate ($core ? ': $!' : ', \$! is \"$!\"') . '"' 82*0Sstevel@tonic-gate } else { 83*0Sstevel@tonic-gate return qq{$call(@argv) || croak "Can't $name(\@_)} . 84*0Sstevel@tonic-gate ($core ? ': $!' : ', \$! is \"$!\"') . '"'; 85*0Sstevel@tonic-gate } 86*0Sstevel@tonic-gate} 87*0Sstevel@tonic-gate 88*0Sstevel@tonic-gatesub _make_fatal { 89*0Sstevel@tonic-gate my($sub, $pkg, $void) = @_; 90*0Sstevel@tonic-gate my($name, $code, $sref, $real_proto, $proto, $core, $call); 91*0Sstevel@tonic-gate my $ini = $sub; 92*0Sstevel@tonic-gate 93*0Sstevel@tonic-gate $sub = "${pkg}::$sub" unless $sub =~ /::/; 94*0Sstevel@tonic-gate $name = $sub; 95*0Sstevel@tonic-gate $name =~ s/.*::// or $name =~ s/^&//; 96*0Sstevel@tonic-gate print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; 97*0Sstevel@tonic-gate croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/; 98*0Sstevel@tonic-gate if (defined(&$sub)) { # user subroutine 99*0Sstevel@tonic-gate $sref = \&$sub; 100*0Sstevel@tonic-gate $proto = prototype $sref; 101*0Sstevel@tonic-gate $call = '&$sref'; 102*0Sstevel@tonic-gate } elsif ($sub eq $ini) { # Stray user subroutine 103*0Sstevel@tonic-gate die "$sub is not a Perl subroutine" 104*0Sstevel@tonic-gate } else { # CORE subroutine 105*0Sstevel@tonic-gate $proto = eval { prototype "CORE::$name" }; 106*0Sstevel@tonic-gate die "$name is neither a builtin, nor a Perl subroutine" 107*0Sstevel@tonic-gate if $@; 108*0Sstevel@tonic-gate die "Cannot make a non-overridable builtin fatal" 109*0Sstevel@tonic-gate if not defined $proto; 110*0Sstevel@tonic-gate $core = 1; 111*0Sstevel@tonic-gate $call = "CORE::$name"; 112*0Sstevel@tonic-gate } 113*0Sstevel@tonic-gate if (defined $proto) { 114*0Sstevel@tonic-gate $real_proto = " ($proto)"; 115*0Sstevel@tonic-gate } else { 116*0Sstevel@tonic-gate $real_proto = ''; 117*0Sstevel@tonic-gate $proto = '@'; 118*0Sstevel@tonic-gate } 119*0Sstevel@tonic-gate $code = <<EOS; 120*0Sstevel@tonic-gatesub$real_proto { 121*0Sstevel@tonic-gate local(\$", \$!) = (', ', 0); 122*0Sstevel@tonic-gateEOS 123*0Sstevel@tonic-gate my @protos = fill_protos($proto); 124*0Sstevel@tonic-gate $code .= write_invocation($core, $call, $name, $void, @protos); 125*0Sstevel@tonic-gate $code .= "}\n"; 126*0Sstevel@tonic-gate print $code if $Debug; 127*0Sstevel@tonic-gate { 128*0Sstevel@tonic-gate no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... 129*0Sstevel@tonic-gate $code = eval("package $pkg; use Carp; $code"); 130*0Sstevel@tonic-gate die if $@; 131*0Sstevel@tonic-gate no warnings; # to avoid: Subroutine foo redefined ... 132*0Sstevel@tonic-gate *{$sub} = $code; 133*0Sstevel@tonic-gate } 134*0Sstevel@tonic-gate} 135*0Sstevel@tonic-gate 136*0Sstevel@tonic-gate1; 137*0Sstevel@tonic-gate 138*0Sstevel@tonic-gate__END__ 139*0Sstevel@tonic-gate 140*0Sstevel@tonic-gate=head1 NAME 141*0Sstevel@tonic-gate 142*0Sstevel@tonic-gateFatal - replace functions with equivalents which succeed or die 143*0Sstevel@tonic-gate 144*0Sstevel@tonic-gate=head1 SYNOPSIS 145*0Sstevel@tonic-gate 146*0Sstevel@tonic-gate use Fatal qw(open close); 147*0Sstevel@tonic-gate 148*0Sstevel@tonic-gate sub juggle { . . . } 149*0Sstevel@tonic-gate import Fatal 'juggle'; 150*0Sstevel@tonic-gate 151*0Sstevel@tonic-gate=head1 DESCRIPTION 152*0Sstevel@tonic-gate 153*0Sstevel@tonic-gateC<Fatal> provides a way to conveniently replace functions which normally 154*0Sstevel@tonic-gatereturn a false value when they fail with equivalents which raise exceptions 155*0Sstevel@tonic-gateif they are not successful. This lets you use these functions without 156*0Sstevel@tonic-gatehaving to test their return values explicitly on each call. Exceptions 157*0Sstevel@tonic-gatecan be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details. 158*0Sstevel@tonic-gate 159*0Sstevel@tonic-gateThe do-or-die equivalents are set up simply by calling Fatal's 160*0Sstevel@tonic-gateC<import> routine, passing it the names of the functions to be 161*0Sstevel@tonic-gatereplaced. You may wrap both user-defined functions and overridable 162*0Sstevel@tonic-gateCORE operators (except C<exec>, C<system> which cannot be expressed 163*0Sstevel@tonic-gatevia prototypes) in this way. 164*0Sstevel@tonic-gate 165*0Sstevel@tonic-gateIf the symbol C<:void> appears in the import list, then functions 166*0Sstevel@tonic-gatenamed later in that import list raise an exception only when 167*0Sstevel@tonic-gatethese are called in void context--that is, when their return 168*0Sstevel@tonic-gatevalues are ignored. For example 169*0Sstevel@tonic-gate 170*0Sstevel@tonic-gate use Fatal qw/:void open close/; 171*0Sstevel@tonic-gate 172*0Sstevel@tonic-gate # properly checked, so no exception raised on error 173*0Sstevel@tonic-gate if(open(FH, "< /bogotic") { 174*0Sstevel@tonic-gate warn "bogo file, dude: $!"; 175*0Sstevel@tonic-gate } 176*0Sstevel@tonic-gate 177*0Sstevel@tonic-gate # not checked, so error raises an exception 178*0Sstevel@tonic-gate close FH; 179*0Sstevel@tonic-gate 180*0Sstevel@tonic-gate=head1 AUTHOR 181*0Sstevel@tonic-gate 182*0Sstevel@tonic-gateLionel.Cons@cern.ch 183*0Sstevel@tonic-gate 184*0Sstevel@tonic-gateprototype updates by Ilya Zakharevich ilya@math.ohio-state.edu 185*0Sstevel@tonic-gate 186*0Sstevel@tonic-gate=cut 187