File Coverage

blib/lib/Class/Dot/Model/Util.pm

Criterion	Covered	Total	%
statement	65	68	95.5
branch	4	6	66.6
condition			n/a
subroutine	16	16	100.0
pod	4	4	100.0
total	89	94	94.6

# $Id: Util.pm 4 2007-09-13 10:16:35Z asksol $
# $Source$
# $Author: asksol $
# $HeadURL: https://class-dot-model.googlecode.com/svn/trunk/lib/Class/Dot/Model/Util.pm $
# $Revision: 4 $
# $Date: 2007-09-13 12:16:35 +0200 (Thu, 13 Sep 2007) $
package Class::Dot::Model::Util;

use strict;
use warnings;
use version; our $VERSION = qv('0.1.3');
use 5.006_001;

use Carp                qw(croak);
use English             qw( -no_match_vars );
use Params::Util        qw(_ARRAY _HASHLIKE);
use Class::Plugin::Util;

my $UPLEVEL  = 2;

my %EXPORT   = (
    FQDN               => \&FQDN,
    install_coderef    => \&install_coderef,
    push_base_class    => \&push_base_class,
    run_as_call_class  => \&run_as_call_class,
);

sub import {
    my $class     = shift;
    my $call_class = caller 0;

    while (my ($sub_name, $sub_code_ref) = each %EXPORT) {
        install_coderef(
            $sub_code_ref => $call_class, $sub_name
        );
    }

    return;
}

sub FQDN {
    return join q{::}, @_;
}

sub install_coderef {
    my ($coderef, $package, $name) = @_;

    my $fqdn = join q{::}, $package, $name;

    NOSTRICT: {
        no strict 'refs'; ## no critic;
        *{ FQDN($package, $name) } = $coderef;
    }

    return $fqdn;
}


sub push_base_class {
    my ($base_class, $target_class) = @_;

    Class::Plugin::Util::_require_class($base_class); ## no critic

    if (! $target_class->isa($base_class)) {
        no strict 'refs'; ## no critic
        push @{ FQDN($target_class, 'ISA') }, $base_class;
    }

    run_as_call_class({
        call_class => $target_class,
        class     => $base_class,
        method    => 'import'
    });

    return;
}

sub run_as_call_class { ## no critic
    my $class;
    my $method;
    my $call_class;

    if (_HASHLIKE($_[0])) {
        my $opts      = shift;
        $class        = $opts->{class};
        $method       = $opts->{method};
        $call_class   = $opts->{call_class};
    }
    else {
        $call_class   = shift;
        $method       = shift;
        $class        = $call_class;
    }

    my $statement = qq{
        package $call_class;
        \$call_class->\$method(\@_);
    }; ## no critic

    eval qq{ $statement }; ## no critic

    if ($EVAL_ERROR) {
        no warnings 'once'; ## no critic
        $Carp::CallLevel = $UPLEVEL; ## no critic
        croak $EVAL_ERROR;
    }

    return;
}

1;

__END__