File Coverage

lib/Class/Forward.pm

Criterion	Covered	Total	%
statement	82	85	96.4
branch	49	54	90.7
condition	11	18	61.1
subroutine	9	11	81.8
pod	6	8	75.0
total	157	176	89.2

# ABSTRACT: Namespace Dispatch and Resolution

package Class::Forward;

use strict;
use warnings;

our $VERSION = '0.100006'; # VERSION

use Exporter ();

our @ISA    = qw(Exporter);
our @EXPORT = qw(clsf clsr);
our %CACHE  = ();



sub clsf {
    return Class::Forward->new(namespace => (caller)[0])->forward(@_);
}


sub clsr {
    return Class::Forward->new(namespace => (caller)[0])->reverse(@_);
}


sub new {
    my $self = bless {}, (shift);

    my %args = @_ ? @_ : ();

    $self->{namespace} = $args{namespace} if defined $args{namespace};

    return $self;
}


sub namespace {
    my ($self, $namespace) = @_;

    $self->{namespace} = $namespace if $namespace;

    return $self->{namespace};
}


sub forward {
    my ($self, $shorthand, @arguments) = @_;

    my $namespace = $self->namespace() || (caller)[0] || 'main';

    my $backspace;
    my $methods;
    my $myspace;

    my $class   = '';
    my @class   = ();
    my @methods = ();

    my $CACHE_KEY = $shorthand;
       $CACHE_KEY .= "\@$namespace";

    my $DATA = $CACHE{$CACHE_KEY} ||= do {

        if ($shorthand) {

            # capture path relativity notation

            $backspace = $1 if $shorthand =~ s/^((\.{1,2}\/){1,})//;

            $backspace = $1 if $shorthand =~ s/^(\/+)// && !$backspace;

            # capture method call notation

            ($methods) = $1 if $shorthand =~ s/((\.\w+){1,})$//;

            # convert shorthand to package notation

            $myspace = join "::", map {
                /_/ ? join '', map { ucfirst lc } split /_/, $_ : ucfirst $_
            }   split /(?:::|\-|\/)/, $shorthand;

            if ($backspace) {
                unless ($backspace =~ /^\/$/) {
                    @class = split /::/, $namespace;
                    if ($backspace =~ /^\/\/$/) {
                        while (@class > 1) {
                            pop @class;
                        }
                    }
                    else {
                        unless ($backspace =~ /^\.\/$/) {
                            my @backspaces = $backspace =~ /\.\.\//g;
                            for (@backspaces) {
                                pop @class unless @class == 1;
                            }
                        }
                    }
                }
            }
            else {
                push @class, $namespace;
            }

            push @class, split /::/, $myspace if $myspace;

            push @methods, grep /\w+/, split /\./, $methods if $methods;

        }

        push @class, $namespace if !@class;

        # build class namespace

        my $class = @class > 1 ? join('::', @class) : $class[0];

        # leverage @INC to validate and possibly correct any case issues

        my $file = "$class.pm";
        $file =~ s/::/\//g;

        unless ($INC{$file}) {

            # don't assume $#!+

            my @matches = grep(/^$file/i, keys %INC);

            if (@matches == 1) {

                $class = $matches[0];
                $class =~ s/\//::/g;
                $class =~ s/\.pm$//;

            }

        }

        # cache the results
        $CACHE{$CACHE_KEY} = {
            'CLASS'   => $class,
            'METHODS' => [@methods]
        };

    };

    $class   = $DATA->{'CLASS'};
    @methods = @{$DATA->{'METHODS'}} if $DATA && ! @methods;

    # return result of method call(s) or class name

    if (@methods) {

        for (my $i = 0 ; $i < @methods ; $i++) {

            my $method = $methods[$i];

            $class =
                $i == $#methods ? $class->$method(@arguments) : $class->$method;

        }

        return $class;

    }

    else {

        return $class;

    }
}

sub forward_lookup {
    goto \&forward
}


sub reverse {
    my ($self, $shorthand, $offset, $delimiter) = @_;

    $self->namespace((caller)[0] || 'main') unless $self->namespace;

    $shorthand =~ s/((\.\w+){1,})$// if $shorthand;
    $delimiter ||= '/';

    my $result = $self->forward($shorthand);
    my @pieces = split /::/, $result;

    if (defined $offset and $offset >= 0) {
        if ($offset == 0) {
            unshift @pieces, '';
        }
        else {
            shift @pieces for (1..$offset);
        }
    }
    else {
        unshift @pieces, '';
    }

    return join $delimiter,
        map { if ($_) { s/([a-z])([A-Z])/$1_\l$2/g; lc } } @pieces;
}

sub reverse_lookup {
    goto \&reverse
}


1;

__END__