File Coverage

blib/lib/as.pm

Criterion	Covered	Total	%
statement	61	65	93.8
branch	22	26	84.6
condition	4	6	66.6
subroutine	11	11	100.0
pod			n/a
total	98	108	90.7

package as;

# make sure we have version info for this module
$VERSION= '0.13';

# be as strict and verbose as possible
use strict;
use warnings;

# modules that we need
use Carp qw( croak );

# hash containing already aliased modules
my %ALIASED;

# make sure this is done before anything else
BEGIN {

    # allow dirty stuff happening without anyone complaining about it
    no strict 'refs';
    no warnings 'redefine';

=for Explanation:
     We want to take over the standard -require- functionality so that we
     can inject ourselves in the -use- processing and to install our own
     "import" functionality.  If there is no previous custom installed
     -require- handler yet, then we don't bother calling it, which should
     have some execution benefits.

=cut

    my $old= \&CORE::GLOBAL::require;
    eval { $old->() };
    $old= undef if $@ =~ m#CORE::GLOBAL::require#;

    # install our own -require- handler
    *CORE::GLOBAL::require = sub {
        my $file= $_[0];

        # perform what was originally expected
        my $return;
        if ($old) {
            ($return)= eval { $old->($file) };
        }

        # seems to be a version check
        elsif ( $file =~ m#^v?[\d\.]+$# ) {
            ($return)= eval { CORE::require( 0 + $file ) }; # needs num value
        }

        # no special -require- action needed, already loaded before
        elsif ( $INC{$file} ) {
            $return= 1;
        }

        # first time -require-
        else {
            ($return)= eval { CORE::require($file) };
        }

        # something wrong, cleanup and bail out
        if ($@) {
            $@ =~ s#(?: in require)? at /?(?:\w+/)*as\.pm line \d+.\s+##s;
            croak $@;
        }

        # not requiring a module, we're done
        my $module= shift;
        return $return if $module !~ s#\.pm$##;
        $module =~ s#/#::#g;

        # there's an "import" already, embed it
        if ( my $import= $module->can('import') ) {

            # install our own importer
            *{ $module . '::import' }= sub {

                # we need to do aliasing: do it and remove them params
                if ( @_ >= 3 and $_[-2] eq 'as' ) {
                    my ( undef, $alias )= splice @_, -2;
                    _alias( $module, $alias );
                }

                # hopefully keep same scope as caller
                goto &$import if @_;
            };
        }


        # no import to embed, simply install our own
        else {
            *{ $module . '::import' }= \&_import;
        }

        # really done now
        return $return;
    };
}     #BEGIN

# satisfy -require-
1;

#---------------------------------------------------------------------------
#
# Internal subroutines
#
#---------------------------------------------------------------------------
# _alias
#
# Perform the actual stash aliasing
#
#  IN: 1 original class name
#      2 alias class name

sub _alias {
    my ( $module, $alias )= @_;

    # allow dirty stuff happening without anyone complaining about it
    no strict 'refs';

    # make sure we're not treading on already taken territory
    if ( %{ $alias . '::' } ) {

        # alias already used, bail out if not same
        if ( my $old= $ALIASED{$alias} ) {
            croak
              "Cannot alias '$alias' to '$module': already aliased to '$old'"
                if $old ne $module;
        }

        # not aliased yet, but, but, but...
        else {
            croak "Cannot alias '$alias' to '$module': already taken";
        }
    }

    # perform the actual stash aliasing and remember it
    *{ $alias . '::' }= *{ $module . '::' };
    $ALIASED{$alias}= $module;

    s#::#/#g foreach ( $module, $alias );
    $INC{"$alias.pm"}= $INC{"$module.pm"};

    return;
}    #_alias

#---------------------------------------------------------------------------
# _import
#
# Generic importer, same for all modules that didn't have an import yet
#
#  IN: 1 class
#      2..N parameters

sub _import {

    # nothing to be done
    return if @_ < 3 or $_[-2] ne 'as';

    # perform the alias
    _alias( $_[0], $_[-1] );

    return;
}    #_import

#---------------------------------------------------------------------------

__END__