File Coverage

blib/lib/Exporter/Renaming.pm

Criterion	Covered	Total	%
statement	89	89	100.0
branch	34	40	85.0
condition	18	28	64.2
subroutine	14	14	100.0
pod	0	3	0.0
total	155	174	89.0

package Exporter::Renaming;

use 5.008;
use strict;
use warnings;
use Carp;

our $VERSION = 1.19;

my $renaming_on; # are we active?
my $exporter_import; # holds coderef to original Exporter behavior, if defined
my $exporter_to_level; # same for Export::Heavy::heavy_export_to_level

# switch on renaming behavior of Exporter
sub import {
    return if $renaming_on; # never do this twice
    require Exporter;
    require Exporter::Heavy;
    $exporter_import = \ &Exporter::import; # alias for original
    $exporter_to_level = \ &Exporter::Heavy::heavy_export_to_level;
    no warnings 'redefine';
    *Exporter::import = \ &renaming_import; # renaming behavior
    *Exporter::Heavy::heavy_export_to_level = \ &renaming_to_level;
    $renaming_on = 1;
}

# restore Exporter's original behavior
sub unimport {
    return unless $renaming_on;
    no warnings 'redefine';
    *Exporter::import = $exporter_import; # normal behavior
    *Exporter::Heavy::heavy_export_to_level = $exporter_to_level;
    $renaming_on = 0; # allow import again
}

# This is the import routine we supplant into Exporter.  It interprets
# a renaming package, if any, then resumes normal import through
# "goto &$exporter_import".  This is this sub's way of returning
sub renaming_import {
    # be as inconspicious as possible
    goto $exporter_import unless $renaming_on;
    my ($from_module, $key, $renamings, @normal) = @_;
    # check if we are needed at all
    goto $exporter_import unless
        $key and $key eq 'Renaming' and ref $renamings eq 'ARRAY';

    my $to_module = caller;
    process_renaming($from_module, $to_module, $renamings);

    # do any remaining straight imports
    return unless @normal;
    @_ = ($from_module, @normal);
    goto $exporter_import;
}

# replacement for Exporter::Heavy::heavy_export_to_level
sub renaming_to_level {
    goto $exporter_to_level unless $renaming_on;
    my $pkg = shift;
    my $level = shift;
    (undef) = shift;                  # XXX redundant arg
    my $callpkg = caller($level);
    my ($key, $renamings, @normal) = @_;
    return $pkg->export($callpkg, @_) unless
        $key and $key eq 'Renaming' and ref $renamings eq 'ARRAY';
    process_renaming($pkg, $callpkg, $renamings);
    $pkg->export($callpkg, @normal) if @normal;
}

sub process_renaming {
    my ($from, $to, $renamings) = @_;
    my %table;
    # build renaming table, basically as %table = reverse @$renamings,
    # but do error checking and type (sigil) propagation
    croak( "Odd number of renaming elements") if @$renamings % 2;
    while ( @$renamings ) {
        my ( $old_sym, $new_sym) = ( shift @$renamings, shift @$renamings);
        $new_sym ||= $old_sym; # default to straight import
        my ( $old_type, $old_name) = _get_type( $old_sym);
        my ( $new_type, $new_name) = _get_type( $new_sym);
        # check type and name
        croak( "Invalid type character in '$old_sym'") unless
            defined $old_type;
        croak( "Invalid type character in '$new_sym'") unless
            defined $new_type;
        # Check if $new_name is valid ($old_name will be checked by
        # standard Exporter)
        croak( "Invalid name in '$new_sym'") unless
            $new_name =~ /^[A-Za-z_]\w*$/;
        # type propagation
        my $type = $old_type || $new_type || '&';
        $old_type ||= $type;
        $new_type ||= $type;
        croak( "Different types: old '$old_sym', new '$new_sym'") if
            $old_type ne $new_type;
        $new_sym = "$type$new_name";
        $old_sym = "$type$old_name";
        # Check table for multiple entries
        croak( "Multiple renamings to '$new_sym'") if exists $table{ $new_sym};
        $table{ $new_sym} = $old_sym;
    }

    # Jump through Exporter's hoops for all original symbols
    {
        package Exporter::Renaming::Inter; # name space for importing

        # We want Exporter's messages passed on to our user
        our @CARP_NOT = qw(Exporter Exporter::Renaming);
        # "values %table" may list some symbols more than once, but Exporter
        # sorts that out.
        $exporter_import->($from, values %table); # original names
    }

    # If we are here, all imports are ok (under the original names)
    # now alias symbols into user space according to table
    while ( my ( $new, $old) = each %table ) {
        ( my( $type), $new) = _get_type( $new);
        ( undef, $old) = _get_type( $old);
        _sym_alias( $type, "${from}::$old", "${to}::$new");
    }
}

# split off type character
sub _get_type {
    local $_ = shift;
    my ( $type, $name) = /(\W?)(.*)/;
    return if $type and $type !~ /[\$@%&*]/; # reject invalid type chars
    ( $type, $name);
}

# create alias of any type (the only substantial copy of code from Exporter)
sub _sym_alias {
    my ( $type, $old, $new) = @_;
    $type ||= '&';
    no strict 'refs';
    *{$new} =
       $type eq '$' ? \ ${ $old} :
       $type eq '@' ? \ @{ $old} :
       $type eq '%' ? \ %{ $old} :
       $type eq '&' ? \ &{ $old} :
       $type eq '*' ? \ *{ $old} :
       undef;
   ;
}

1;
__END__