File Coverage

blib/lib/Any/Moose.pm

Criterion	Covered	Total	%
statement	84	97	86.6
branch	21	36	58.3
condition	9	14	64.2
subroutine	15	16	93.7
pod	0	4	0.0
total	129	167	77.2

package Any::Moose; # git description: v0.25-2-g151f81b
# ABSTRACT: (DEPRECATED) use Moo instead!
# KEYWORDS: deprecated Moose Mouse abstraction layer object-oriented
$Any::Moose::VERSION = '0.26';
use 5.006_002;
use strict;
use warnings;

# decide which backend to use
our $PREFERRED;
do {
    local $@;
    if ($ENV{ANY_MOOSE}) {
        $PREFERRED = $ENV{'ANY_MOOSE'};
        warn "ANY_MOOSE is not set to Moose or Mouse"
            unless $PREFERRED eq 'Moose'
                || $PREFERRED eq 'Mouse';

        # if we die here, then perl gives "unknown error" which doesn't tell
        # you what the problem is at all. argh.
        if ($PREFERRED eq 'Moose' && !eval { require Moose }) {
            warn "\$ANY_MOOSE is set to Moose but we cannot load it";
        }
        elsif ($PREFERRED eq 'Mouse' && !eval { require Mouse }) {
            warn "\$ANY_MOOSE is set to Mouse but we cannot load it";
        }
    }
    elsif ( $INC{'Moo.pm'} && eval { require Moose } ) {
        $PREFERRED = 'Moose';
    }
    elsif (_is_moose_loaded()) {
        $PREFERRED = 'Moose';
    }
    elsif (eval { require Mouse; require Mouse::Util; Mouse::Util->can('get_metaclass_by_name') }) {
        $PREFERRED = 'Mouse';
    }
    elsif (eval { require Moose }) {
        $PREFERRED = 'Moose';
    }
    else {
        require Carp;
        warn "Unable to locate Mouse or Moose in INC";
    }
};

sub import {
    my $self = shift;
    my $pkg  = caller;

    # Any::Moose gives you strict and warnings
    strict->import;
    warnings->import;

    # first options are for Mo*se
    unshift @_, 'Moose' if !@_ || ref($_[0]);

    while (my $module = shift) {
        my $options = @_ && ref($_[0]) ? shift : [];

        $options = $self->_canonicalize_options(
            module  => $module,
            options => $options,
            package => $pkg,
        );

        $self->_install_module($options);
    }

    # give them any_moose too
    no strict 'refs';
    *{$pkg.'::any_moose'} = \&any_moose;
}

sub unimport {
    my $sel = shift;
    my $pkg = caller;
    my $module;

    if(@_){
        $module = any_moose(shift, $pkg);
    }
    else {
        $module = _backer_of($pkg);
    }
    my $e = do{
        local $@;
        eval "package $pkg;\n"
           . '$module->unimport();';
        $@;
   };

   if ($e) {
        require Carp;
        Carp::croak("Cannot unimport Any::Moose: $e");
   }

   return;
}

sub _backer_of {
    my $pkg = shift;

    if(exists $INC{'Mouse.pm'}
        and Mouse::Util->can('get_metaclass_by_name')
      ){
        my $meta = Mouse::Util::get_metaclass_by_name($pkg);
        if ($meta) {
            return 'Mouse::Role' if $meta->isa('Mouse::Meta::Role');
            return 'Mouse'       if $meta->isa('Mouse::Meta::Class');
       }
    }

    if (_is_moose_loaded()) {
        my $meta = Class::MOP::get_metaclass_by_name($pkg);
        if ($meta) {
            return 'Moose::Role' if $meta->isa('Moose::Meta::Role');
            return 'Moose'       if $meta->isa('Moose::Meta::Class');
        }
    }

    return undef;
}

sub _canonicalize_options {
    my $self = shift;
    my %args = @_;

    my %options;
    if (ref($args{options}) eq 'HASH') {
        %options = %{ $args{options} };
    }
    else {
        %options = (
            imports => $args{options},
        );
    }

    $options{package} = $args{package};
    $options{module}  = any_moose($args{module}, $args{package});

    return \%options;
}

sub _install_module {
    my $self    = shift;
    my $options = shift;

    my $module = $options->{module};
    (my $file = $module . '.pm') =~ s{::}{/}g;

    require $file;

    my $e = do {
        local $@;
        eval "package $options->{package};\n"
           . '$module->import(@{ $options->{imports} });';
        $@;
    };
    if ($e) {
        require Carp;
        Carp::croak("Cannot import Any::Moose: $e");
    }
    return;
}

sub any_moose {
    my $fragment = _canonicalize_fragment(shift);
    my $package  = shift || caller;

    # Mouse gets first dibs because it doesn't introspect existing classes

    my $backer = _backer_of($package) || '';

    if ($backer =~ /^Mouse/) {
        $fragment =~ s/^Moose/Mouse/;
        return $fragment;
    }

    return $fragment if $backer =~ /^Moose/;

    $fragment =~ s/^Moose/Mouse/ if mouse_is_preferred();
    return $fragment;
}

for my $name (qw/
    load_class
    is_class_loaded
    class_of
    get_metaclass_by_name
    get_all_metaclass_instances
    get_all_metaclass_names
    load_first_existing_class
        /) {
    no strict 'refs';
    *{__PACKAGE__."::$name"} = moose_is_preferred()
        ? *{"Class::MOP::$name"}
        : *{"Mouse::Util::$name"};
}

sub moose_is_preferred { $PREFERRED eq 'Moose' }
sub mouse_is_preferred { $PREFERRED eq 'Mouse' }

sub _is_moose_loaded { exists $INC{'Moose.pm'} }

sub is_moose_loaded {
    require Carp;
    Carp::carp("Any::Moose::is_moose_loaded is deprecated. Please use Any::Moose::moose_is_preferred instead");
    goto \&_is_moose_loaded;
}

sub _canonicalize_fragment {
    my $fragment = shift;

    return 'Moose' if !$fragment;

    # any_moose("X::Types") -> any_moose("MooseX::Types")
    $fragment =~ s/^X::/MooseX::/;

    # any_moose("::Util") -> any_moose("Moose::Util")
    $fragment =~ s/^::/Moose::/;

    # any_moose("Mouse::Util") -> any_moose("Moose::Util")
    $fragment =~ s/^Mouse(X?)\b/Moose$1/;

    # any_moose("Util") -> any_moose("Moose::Util")
    $fragment =~ s/^(?!Moose)/Moose::/;

    return $fragment;
}

1;

__END__