|
What this is
Other links
The source code
package Fatal;
use 5.006_001;
use Carp;
use strict;
our($AUTOLOAD, $Debug, $VERSION);
$VERSION = 1.03;
$Debug = 0 unless defined $Debug;
sub import {
my $self = shift(@_);
my($sym, $pkg);
my $void = 0;
$pkg = (caller)[0];
foreach $sym (@_) {
if ($sym eq ":void") {
$void = 1;
}
else {
&_make_fatal($sym, $pkg, $void);
}
}
};
sub AUTOLOAD {
my $cmd = $AUTOLOAD;
$cmd =~ s/.*:://;
&_make_fatal($cmd, (caller)[0]);
goto &$AUTOLOAD;
}
sub fill_protos {
my $proto = shift;
my ($n, $isref, @out, @out1, $seen_semi) = -1;
while ($proto =~ /\S/) {
$n++;
push(@out1,[$n,@out]) if $seen_semi;
push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
$seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
die "Unknown prototype letters: \"$proto\"";
}
push(@out1,[$n+1,@out]);
@out1;
}
sub write_invocation {
my ($core, $call, $name, $void, @argvs) = @_;
if (@argvs == 1) { # No optional arguments
my @argv = @{$argvs[0]};
shift @argv;
return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
} else {
my $else = "\t";
my (@out, @argv, $n);
while (@argvs) {
@argv = @{shift @argvs};
$n = shift @argv;
push @out, "$ {else}if (\@_ == $n) {\n";
$else = "\t} els";
push @out,
"\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
}
push @out, <
|
Copyright 1998-2008 Alvin Alexander
All Rights Reserved.
devdaily.com is based in louisville, kentucky, and this web site is hosted by godaddy.com