view release on metacpan or  search on metacpan

Fatal.pm  view on Meta::CPAN

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, <<EOC;
	}
	die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
EOC
    return join '', @out;
  }
}

sub one_invocation {
  my ($core, $call, $name, $void, @argv) = @_;
  local $" = ', ';
  if ($void) { 
    return qq/(defined wantarray)?$call(@argv):
              $call(@argv) || croak "Can't $name(\@_)/ . 
           ($core ? ': $!' : ', \$! is \"$!\"') . '"'
  } else {
    return qq{$call(@argv) || croak "Can't $name(\@_)} . 
           ($core ? ': $!' : ', \$! is \"$!\"') . '"';
  }
}

sub _make_fatal {
    my($sub, $pkg, $void) = @_;
    my($name, $code, $sref, $real_proto, $proto, $core, $call);