File Coverage

lib/Fatal/Exception.pm

Criterion	Covered	Total	%
statement	210	226	92.9
branch	80	118	67.8
condition	18	68	26.4
subroutine	34	35	97.1
pod			n/a
total	342	447	76.5

#!/usr/bin/perl -c

package Fatal::Exception;

=head1 NAME

Fatal::Exception - Succeed or throw exception

=head1 SYNOPSIS

  use Fatal::Exception 'Exception::System' => qw< open close >;
  open my $fh, "/nonexistent";   # throw Exception::System

  use Exception::Base 'Exception::My';
  sub juggle { ... }
  Fatal::Exception->import('Exception::My' => 'juggle');
  juggle;          # succeed or throw exception
  Fatal::Exception->unimport('juggle');
  juggle or die;   # restore original behavior

=head1 DESCRIPTION

L provides a way to conveniently replace functions
which normally return a false value when they fail with equivalents
which raise exceptions if they are not successful.  This is the same as
L module from Perl 5.8 and previous but it throws
L object on error.

=cut


use 5.006;
use strict;
use warnings;

our $VERSION = 0.05;


use Symbol ();


use Exception::Base (
    '+ignore_package' => __PACKAGE__,
);
use Exception::Argument;
use Exception::Fatal;


# Switch to enable dump for created wrapper functions
our $Debug;


# Cache for not fatalized functions. The key is "$sub".
our %Not_Fatalized_Functions;


# Cache for fatalized functions. The key is "$sub:$exception:$void".
our %Fatalized_Functions;


# Export the wrapped functions to the caller
sub import {
    my $pkg = shift;
    my $exception = shift || return;

    Exception::Argument->throw(
        message => 'Not enough arguments for "' . __PACKAGE__ . '->import"',
    ) unless @_;

    my $mod_version = $exception->VERSION || 0;
    if (not $mod_version) {
        eval "use $exception;";
        if ($@) {
            Exception::Fatal->throw(
                message => "Cannot find \"$exception\" exception class",
            );
        };
    };

    my $callpkg = caller;
    my $void = 0;

    foreach my $arg (@_) {
        if ($arg eq ':void') {
            $void = 1;
        }
        else {
            my $sub = $arg =~ /::/
                      ? $arg
                      : $callpkg . '::' . $arg;
            (my $name = $sub) =~ s/^&?(.*::)?//;

            __make_fatal(
                exception => $exception,
                name      => $name,
                pkg       => $callpkg,
                sub       => $sub,
                void      => $void,
            );
        };
    };

    return 1;
};


# Restore the non fatalized functions to the caller
sub unimport {
    my $pkg = shift;

    my $callpkg = caller;

    foreach my $arg (@_) {
        next if ($arg eq ':void');

        my $sub = $arg =~ /::/
                ? $arg
                : $callpkg . '::' . $arg;
        (my $name = $sub) =~ s/^&?(.*::)?//;

        __make_not_fatal(
            name => $name,
            pkg  => $callpkg,
            sub  => $sub
        );
    };

    return 1;
};


# Create the wrapper. Stolen from Fatal.
sub __make_fatal {
    # args:
    #   exception - exception class name
    #   name - base name of sub
    #   pkg  - current package name
    #   sub  - full name of sub
    #   void - is function called in scalar context?
    my (%args) = @_;

    # check args
    Exception::Argument->throw(
        message => 'Not enough arguments for "' . __PACKAGE__ . '->__make_fatal"',
    ) if grep { not defined } @args{qw< exception name pkg sub >};

    Exception::Argument->throw(
        message => 'Bad subroutine name for "' . __PACKAGE__ . '": ' . $args{name},
    ) if not $args{name} =~ /^\w+$/;

    my ($proto, $code_proto, $call, $core, $argvs);
    my $cache_key = "$args{sub}:$args{exception}:" . ($args{void} ? 1 : 0);
    if (defined $Fatalized_Functions{$cache_key} and defined $Not_Fatalized_Functions{$args{sub}}) {
        # already wrapped: restore from cache
        undef *{ Symbol::qualify_to_ref($args{sub}) };
        return *{ Symbol::qualify_to_ref($args{sub}) } = $Fatalized_Functions{$cache_key};
    }
    elsif (defined(&{$args{sub}}) and not eval { prototype "CORE::$args{name}" }) {
        # user subroutine
        $call = "&{\$" . __PACKAGE__ . "::Not_Fatalized_Functions{\"$args{sub}\"}}";
        $proto = prototype $args{sub};
        $Not_Fatalized_Functions{$args{sub}} = \&{$args{sub}}
            unless defined $Not_Fatalized_Functions{$args{sub}};
    }
    else {
        # CORE subroutine
        $core = 1;
        $call = "CORE::$args{name}";
        $proto = eval { prototype $call };

        # not found as CORE subroutine
        Exception::Argument->throw(
            message => "\"$args{sub}\" is not a Perl subroutine",
        ) unless $proto;

        # create package's function
        if (not defined &{$args{sub}}) {
            # not package's function yet
            $argvs = __fill_argvs($proto);
            my $name = "__$args{name}__Fatal__Exception__not_wrapped";
            my $code = "package $args{pkg};\n"
                     . "sub $name ($proto) {\n"
                     . "    no strict 'refs';\n"
                     .      __write_invocation(
                                %args,
                                argvs => $argvs,
                                call  => $call,
                                orig  => 1,
                            )
                     . "}\n";
            print STDERR $code if $Debug;

            eval $code;
            if ($@) {
                Exception::Fatal->throw(
                    message => "Cannot create \"$args{sub}\" subroutine",
                );
            };

            my $sub = "$args{pkg}::$name";
            print STDERR "*{ $args{sub} } = \\&$sub;\n" if $Debug;
            undef *{ Symbol::qualify_to_ref($args{sub}) };
            *{ Symbol::qualify_to_ref($args{sub}) } = \&$sub;
        };

        if (not defined $Not_Fatalized_Functions{$args{sub}}) {
            $Not_Fatalized_Functions{$args{sub}} = \&{$args{sub}};
        };
    };

    if (defined $proto) {
        $code_proto = " ($proto)";
    }
    else {
        $code_proto = '';
        $proto = '@';
    };

    $argvs = __fill_argvs($proto) if not defined $argvs;

    # define new named subroutine (anonymous would be harder to debug from stacktrace)
    my $name = "__$args{name}__Fatal__Exception__$args{exception}" . ($args{void} ? '_void' : '') . "__wrapped";
    $name =~ tr/:/_/;

    my $code = "package $args{pkg};\n"
             . "sub $name$code_proto {\n"
             . "    no strict 'refs';\n"
             .      __write_invocation(
                        %args,
                        argvs => $argvs,
                        call  => $call,
                    )
             . "}\n";
    print STDERR $code if $Debug;

    my $newsub = eval $code;
    if ($@) {
        Exception::Fatal->throw(
            message => "Cannot create \"$args{sub}\" subroutine",
        );
    };

    my $sub = "$args{pkg}::$name";
    print STDERR "*{ $args{sub} } = \\&$sub;\n" if $Debug;

    undef *{ Symbol::qualify_to_ref($args{sub}) };
    return *{ Symbol::qualify_to_ref($args{sub}) } = $Fatalized_Functions{$cache_key} = \&$sub;
};


# Restore the not-fatalized function.
sub __make_not_fatal {
    # args:
    #   name - base name of sub
    #   pkg  - current package name
    #   sub  - full name of sub
    my (%args) = @_;

    # check args
    Exception::Argument->throw(
        message => 'Not enough arguments for "' . __PACKAGE__ . '->__make_non_fatal"',
    ) if grep { not defined } @args{qw< name pkg sub >};

    Exception::Argument->throw(
        message => 'Bad subroutine name for "' . __PACKAGE__ . '": ' . $args{name},
    ) if not $args{name} =~ /^\w+$/;

    # not wrapped - do nothing
    return unless defined $Not_Fatalized_Functions{$args{sub}};

    undef *{ Symbol::qualify_to_ref($args{sub}) };
    return *{ Symbol::qualify_to_ref($args{sub}) } = $Not_Fatalized_Functions{$args{sub}};
};


# Fill argvs array based on function prototype. Stolen from Fatal.
sub __fill_argvs {
    my $proto = shift;

    my $n = -1;
    my (@code, @protos, $seen_semi);

    while ($proto =~ /\S/) {
        $n++;
        if ($seen_semi) {
            push(@protos,[$n,@code]);
        };
        if ($proto =~ s/^\s*\\([\@%\$\&])//) {
            push(@code, $1 . "{\$_[$n]}");
            next;
        };
        if ($proto =~ s/^\s*([*\$&])//) {
            push(@code, "\$_[$n]");
            next;
        };
        if ($proto =~ s/^\s*(;\s*)?\@//) {
            push(@code, "\@_[$n..\$#_]");
            last;
        };
        if ($proto =~ s/^\s*;//) {
            $seen_semi = 1;
            $n--;
            next;
        };
        Exception::Argument->throw(
            message => "Unknown prototype letters: \"$proto\"",
        );
    };
    push @protos, [$n+1, @code];
    return \@protos;
};


# Write subroutine invocation. Stolen from Fatal.
sub __write_invocation {
    # args:
    #   argvs - ref to prototypes stored as array of array of calling arguments
    #   call  - called sub full name
    #   exception - exception class name
    #   name  - base name of sub
    #   orig  - is function called as non-fatalized version?
    #   void  - is function called in scalar context?
    my (%args) = @_;

    # check args
    Exception::Argument->throw(
        message => 'Not enough arguments for "' . __PACKAGE__ . '->__write_invocation"',
    ) if grep { not defined } @args{qw< argvs call exception name >};

    my @argvs = @{ $args{argvs} };

    my $code;

    if (@argvs == 1) {
        # No optional arguments
        my @argv = @{ $argvs[0] };
        shift @argv;
        $code =
            "    "
            . __one_invocation(
                %args,
                argv => \@argv,
              )
            . ";\n";
    }
    else {
        my $else = "    ";
        my (@out, @argv, $n);
        while (@argvs) {
            @argv = @{shift @argvs};
            $n = shift @argv;
            push @out, "${else}if (\@_ == $n) {\n";
            $else = "    }\n    els";
            push @out,
                "        return "
                . __one_invocation(
                    %args,
                    argv      => \@argv,
                  )
                . ";\n";
        }
        push @out,
            "    };\n"
          . "    Exception::Argument->throw(\n"
          . "        ignore_level => 1,\n"
          . "        message => \"$args{name}: Do not expect to get \" . scalar \@_ . \" arguments\"\n"
          . "    );\n";
        $code = join '', @out;
    };

    return $code;
};


# Write subroutine invocation. Stolen from Fatal.
sub __one_invocation {
    # args:
    #   argv - ref to prototypes stored as array of calling arguments
    #   call - called sub full name
    #   exception - exception class name
    #   name - base name of sub
    #   orig - is function called as non-fatalized version?
    #   void - is function called in scalar context?
    my (%args) = @_;

    # check args
    Exception::Argument->throw(
        message => 'Not enough arguments for "' . __PACKAGE__ . '->__one_invocation"',
    ) if grep { not defined } @args{qw< argv call exception name >};

    my $argv = join ', ', @{$args{argv}};

    my $code;

    if ($args{orig}) {
        return "$args{call}($argv)";
    }
    elsif ($args{void}) {
        $code = "(defined wantarray)\n"
             . "            ? $args{call}($argv)\n"
             . "            : do {\n"
             . "                  my \$return = eval {\n"
             . "                      $args{call}($argv);\n"
             . "                  };\n"
             . "                  if (\$@) {\n"
             . "                      Exception::Fatal->throw(\n"
             . "                          ignore_level => 1,\n"
             . "                          message      => \"Cannot $args{name}\",\n"
             . "                      );\n"
             . "                  };\n"
             . "                  \$return;\n"
             . "              } || $args{exception}->throw(\n"
             . "                       ignore_level => 1,\n"
             . "                       message      => \"Cannot $args{name}\",\n"
             . "                   )";
    }
    else {
        $code = "$args{call}($argv)\n"
             . "            || $args{exception}->throw(\n"
             . "                   ignore_level => 1,\n"
             . "                   message      => \"Cannot $args{name}\"\n"
             . "               )";
        $code = "(defined wantarray)\n"
             . "            ? do {\n"
             . "                  my \@return = eval {\n"
             . "                      $args{call}($argv);\n"
             . "                  };\n"
             . "                  if (\$@) {\n"
             . "                      Exception::Fatal->throw(\n"
             . "                          ignore_level => 1,\n"
             . "                          message      => \"Cannot $args{name}\",\n"
             . "                      );\n"
             . "                  };\n"
             . "                  \@return;\n"
             . "              } || $args{exception}->throw(\n"
             . "                       ignore_level => 1,\n"
             . "                       message      => \"Cannot $args{name}\",\n"
             . "                   )\n"
             . "            : do {\n"
             . "                  my \$return = eval {\n"
             . "                      $args{call}($argv);\n"
             . "                  };\n"
             . "                  if (\$@) {\n"
             . "                      Exception::Fatal->throw(\n"
             . "                          ignore_level => 1,\n"
             . "                          message      => \"Cannot $args{name}\",\n"
             . "                      );\n"
             . "                  };\n"
             . "                  \$return;\n"
             . "              } || $args{exception}->throw(\n"
             . "                       ignore_level => 1,\n"
             . "                       message      => \"Cannot $args{name}\",\n"
             . "                   )";
    };

    return $code;
};


1;


__END__