view release on metacpan or  search on metacpan

t/lib/aliased.pm  view on Meta::CPAN

package aliased;
$VERSION = '0.21';

require Exporter;
@ISA    = qw(Exporter);
@EXPORT = qw(alias);

use strict;

sub import {
    my ( $class, $package, $alias, @import ) = @_;

    if ( @_ <= 1 ) {
        $class->export_to_level(1);
        return;
    }

    my $callpack = caller(0);

    _load_alias( $package, $callpack, @import );
    _make_alias( $package, $callpack, $alias );
}

sub _get_alias {
    my $package = shift;
    $package =~ s/.*(?:::|')//;
    return $package;
}

sub _make_alias {
    my ( $package, $callpack, $alias ) = @_;

    $alias ||= _get_alias($package);

    local $SIG{__DIE__};
    eval qq{
        package $callpack;
        sub $alias () { '$package' }
    };
    die $@ if $@;
}

sub _load_alias {
    my ( $package, $callpack, @import ) = @_;

    my $sigdie;
    {
        local $SIG{__DIE__};
        my $code = @import == 0
          ? "package $callpack; use $package;"
          : "package $callpack; use $package (\@import)";
        eval $code;
        die $@ if $@;
        $sigdie = $SIG{__DIE__};
    }

    # Make sure a global $SIG{__DIE__} makes it out of the localization.
    $SIG{__DIE__} = $sigdie if defined $sigdie;
}

sub alias {
    my ( $package, @import ) = @_;

    my $callpack = scalar caller(0);
    _load_alias( $package, $callpack, @import );

    return $package;
}

1;
__END__

=head1 NAME

aliased - Use shorter versions of class names.

=head1 SYNOPSIS

  # Class name interface
  use aliased 'My::Company::Namespace::Customer';
  my $cust = Customer->new;

  use aliased 'My::Company::Namespace::Preferred::Customer' => 'Preferred';
  my $pref = Preferred->new;


  # Variable interface
  use aliased;
  my $Customer  = alias "My::Other::Namespace::Customer";
  my $cust      = $Customer->new;

  my $Preferred = alias "My::Other::Namespace::Preferred::Customer";
  my $pref      = $Preferred->new;  


=head1 DESCRIPTION

C<aliased> is simple in concept but is a rather handy module.  It loads the
class you specify and exports into your namespace a subroutine that returns
the class name.  You can explicitly alias the class to another name or, if you
prefer, you can do so implicitly.  In the latter case, the name of the
subroutine is the last part of the class name.  Thus, it does something
similar to the following:

  #use aliased 'Some::Annoyingly::Long::Module::Name::Customer';

  use Some::Annoyingly::Long::Module::Name::Customer;
  sub Customer {
    return 'Some::Annoyingly::Long::Module::Name::Customer';
  }
  my $cust = Customer->new;

This module is useful if you prefer a shorter name for a class.  It's also
handy if a class has been renamed.

(Some may object to the term "aliasing" because we're not aliasing one
namespace to another, but it's a handy term.  Just keep in mind that this is
done with a subroutine and not with typeglobs and weird namespace munging.)

Note that this is B<only> for C<use>ing OO modules.  You cannot use this to
load procedural modules.  See the L<Why OO Only?|Why OO Only?> section.  Also,
don't let the version number fool you.  This code is ridiculously simple and
is just fine for most use.