[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package Fatal; 2 3 use 5.006_001; 4 use Carp; 5 use strict; 6 our($AUTOLOAD, $Debug, $VERSION); 7 8 $VERSION = 1.05; 9 10 $Debug = 0 unless defined $Debug; 11 12 sub import { 13 my $self = shift(@_); 14 my($sym, $pkg); 15 my $void = 0; 16 $pkg = (caller)[0]; 17 foreach $sym (@_) { 18 if ($sym eq ":void") { 19 $void = 1; 20 } 21 else { 22 &_make_fatal($sym, $pkg, $void); 23 } 24 } 25 }; 26 27 sub AUTOLOAD { 28 my $cmd = $AUTOLOAD; 29 $cmd =~ s/.*:://; 30 &_make_fatal($cmd, (caller)[0]); 31 goto &$AUTOLOAD; 32 } 33 34 sub 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 50 sub write_invocation { 51 my ($core, $call, $name, $void, @argvs) = @_; 52 if (@argvs == 1) { # No optional arguments 53 my @argv = @{$argvs[0]}; 54 shift @argv; 55 return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n"; 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, 65 "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n"; 66 } 67 push @out, <<EOC; 68 } 69 die "$name(\@_): Do not expect to get ", scalar \@_, " arguments"; 70 EOC 71 return join '', @out; 72 } 73 } 74 75 sub one_invocation { 76 my ($core, $call, $name, $void, @argv) = @_; 77 local $" = ', '; 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 } 86 } 87 88 sub _make_fatal { 89 my($sub, $pkg, $void) = @_; 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/^&//; 96 print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; 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 && $sub !~ /^CORE::GLOBAL::/) { 103 # Stray user subroutine 104 die "$sub is not a Perl subroutine" 105 } else { # CORE subroutine 106 $proto = eval { prototype "CORE::$name" }; 107 die "$name is neither a builtin, nor a Perl subroutine" 108 if $@; 109 die "Cannot make a non-overridable builtin fatal" 110 if not defined $proto; 111 $core = 1; 112 $call = "CORE::$name"; 113 } 114 if (defined $proto) { 115 $real_proto = " ($proto)"; 116 } else { 117 $real_proto = ''; 118 $proto = '@'; 119 } 120 $code = <<EOS; 121 sub$real_proto { 122 local(\$", \$!) = (', ', 0); 123 EOS 124 my @protos = fill_protos($proto); 125 $code .= write_invocation($core, $call, $name, $void, @protos); 126 $code .= "}\n"; 127 print $code if $Debug; 128 { 129 no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ... 130 $code = eval("package $pkg; use Carp; $code"); 131 die if $@; 132 no warnings; # to avoid: Subroutine foo redefined ... 133 *{$sub} = $code; 134 } 135 } 136 137 1; 138 139 __END__ 140 141 =head1 NAME 142 143 Fatal - replace functions with equivalents which succeed or die 144 145 =head1 SYNOPSIS 146 147 use Fatal qw(open close); 148 149 sub juggle { . . . } 150 import Fatal 'juggle'; 151 152 =head1 DESCRIPTION 153 154 C<Fatal> provides a way to conveniently replace functions which normally 155 return a false value when they fail with equivalents which raise exceptions 156 if they are not successful. This lets you use these functions without 157 having to test their return values explicitly on each call. Exceptions 158 can be caught using C<eval{}>. See L<perlfunc> and L<perlvar> for details. 159 160 The do-or-die equivalents are set up simply by calling Fatal's 161 C<import> routine, passing it the names of the functions to be 162 replaced. You may wrap both user-defined functions and overridable 163 CORE operators (except C<exec>, C<system> which cannot be expressed 164 via prototypes) in this way. 165 166 If the symbol C<:void> appears in the import list, then functions 167 named later in that import list raise an exception only when 168 these are called in void context--that is, when their return 169 values are ignored. For example 170 171 use Fatal qw/:void open close/; 172 173 # properly checked, so no exception raised on error 174 if(open(FH, "< /bogotic") { 175 warn "bogo file, dude: $!"; 176 } 177 178 # not checked, so error raises an exception 179 close FH; 180 181 =head1 BUGS 182 183 You should not fatalize functions that are called in list context, because this 184 module tests whether a function has failed by testing the boolean truth of its 185 return value in scalar context. 186 187 =head1 AUTHOR 188 189 Lionel Cons (CERN). 190 191 Prototype updates by Ilya Zakharevich <ilya@math.ohio-state.edu>. 192 193 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |