File Coverage

blib/lib/Any/Moose.pm

Criterion	Covered	Total	%
statement	87	95	91.5
branch	29	36	80.5
condition	10	14	71.4
subroutine	15	16	93.7
pod	0	4	0.0
total	141	165	85.4

package Any::Moose; # git description: v0.26-20-g4c2f951
# ABSTRACT: (DEPRECATED) use Moo instead!
# KEYWORDS: deprecated Moose Mouse abstraction layer object-oriented
# vim: set ts=8 sts=4 sw=4 tw=115 et :

use 5.006_002;
use strict;
use warnings;

our $VERSION = '0.27';

warnings::warnif('deprecated', 'Any::Moose is deprecated. Please use Moo instead');

# 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 {
    warnings::warnif('deprecated', "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__

=pod

=encoding UTF-8

=head1 NAME

Any::Moose - (DEPRECATED) use Moo instead!

=head1 VERSION

version 0.27

=head1 DEPRECATION

日本語翻訳: http://blog.64p.org/entry/2013/02/06/094906

Please use L<Moo> instead of Any::Moose for new code.

Moo classes and roles will transparently and correctly upgrade to
Moose when needed. This is a fundamentally better design than what
Any::Moose offers. Mouse metaclasses do not interact with Moose
metaclasses which leaks abstractions all over the place.

Any::Moose had a good run. It was a simplistic but expedient answer
for getting Moose syntax on the cheap but with the transparent
upgrade path to Moose when you needed it. But really, please don't
use it any more. :)

You may find L<MooX::late> useful for porting your code from
Any::Moose to Moo.

For the sparse documentation Any::Moose used to include, see
L<https://metacpan.org/module/SARTAK/Any-Moose-0.18/lib/Any/Moose.pm>

=head1 SUPPORT

Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Any-Moose>
(or L<[e-mail]|mailto:[e-mail]>).

There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.

There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.

=head1 AUTHORS

=over 4

=item *

Shawn M Moore <[e-mail]>

=item *

Florian Ragwitz <[e-mail]>

=item *

Stevan Little <[e-mail]>

=item *

藤 吾郎 (Fuji Goro) <[e-mail]>

=back

=head1 CONTRIBUTORS

=for stopwords Karen Etheridge Tokuhiro Matsuno Ricardo Signes Graham Knop Stevan Little Chris 'BinGOs' Williams

=over 4

=item *

Karen Etheridge <[e-mail]>

=item *

Tokuhiro Matsuno <[e-mail]>

=item *

Ricardo Signes <[e-mail]>

=item *

Graham Knop <[e-mail]>

=item *

Stevan Little <[e-mail]>

=item *

Chris 'BinGOs' Williams <[e-mail]>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2009 by Best Practical Solutions.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut