view release on metacpan or  search on metacpan

lib/Fatal.pm  view on Meta::CPAN

                $func, $pkg, $void, $lexical, $filename,
                $insist_this, \%install_subs,
            );

            $Original_user_sub{$sub} ||= $sub_ref;

            # If we're making lexical changes, we need to arrange
            # for them to be cleaned at the end of our scope, so
            # record them here.

            $unload_later{$func} = $sub_ref if $lexical;
        }
    }

    install_subs($pkg, \%install_subs);

    if ($lexical) {

        # Dark magic to have autodie work under 5.8
        # Copied from namespace::clean, that copied it from
        # autobox, that found it on an ancient scroll written
        # in blood.

        # This magic bit causes %^H to be lexically scoped.

        $^H |= 0x020000;

        # Our package guard gets invoked when we leave our lexical
        # scope.

        on_end_of_compile_scope(sub {
            install_subs($pkg, \%unload_later);
        });

        # To allow others to determine when autodie was in scope,
        # and with what arguments, we also set a %^H hint which
        # is how we were called.

        # This feature should be considered EXPERIMENTAL, and
        # may change without notice.  Please e-mail pjf@cpan.org
        # if you're actually using it.

        $^H{autodie} = "$PACKAGE @original_args";

    }

    return;

}

sub unimport {
    my $class = shift;

    # Calling "no Fatal" must start with ":lexical"
    if ($_[0] ne LEXICAL_TAG) {
        croak(sprintf(ERROR_NO_LEX,$class));
    }

    shift @_;   # Remove :lexical

    my $pkg = (caller)[0];

    # If we've been called with arguments, then the developer
    # has explicitly stated 'no autodie qw(blah)',
    # in which case, we disable Fatalistic behaviour for 'blah'.

    my @unimport_these = @_ ? @_ : ':all';
    my (%uninstall_subs, %reinstall_subs);

    for my $symbol ($class->_translate_import_args(@unimport_these)) {

        my $sub = $symbol;
        $sub = "${pkg}::$sub" unless $sub =~ /::/;

        # If 'blah' was already enabled with Fatal (which has package
        # scope) then, this is considered an error.

        if (exists $Package_Fatal{$sub}) {
            croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
        }

        # Record 'no autodie qw($sub)' as being in effect.
        # This is to catch conflicting semantics elsewhere
        # (eg, mixing Fatal with no autodie)

        $^H{$NO_PACKAGE}{$sub} = 1;
        # Record the current sub to be reinstalled at end of scope
        # and then restore the original (can be undef for "CORE::"
        # subs)

        {
            no strict 'refs';  ## no critic # to avoid: Can't use string (...) as a symbol ref ...
            $reinstall_subs{$symbol} = \&$sub
                if exists ${"${pkg}::"}{$symbol};
        }
        $uninstall_subs{$symbol} = $Original_user_sub{$sub};

    }

    install_subs($pkg, \%uninstall_subs);
    on_end_of_compile_scope(sub {
        install_subs($pkg, \%reinstall_subs);
    });

    return;

}

sub _translate_import_args {
    my ($class, @args) = @_;
    my @result;
    my %seen;

    if (@args < 2) {
        # Optimize for this case, as it is fairly common.  (e.g. use
        # autodie; or use autodie qw(:all); both trigger this).
        return unless @args;

        # Not a (known) tag, pass through.
        return @args unless exists($TAGS{$args[0]});