File Coverage

blib/lib/Module/Load/Util.pm

Criterion	Covered	Total	%
statement	61	63	96.8
branch	46	52	88.4
condition	3	5	60.0
subroutine	5	5	100.0
pod	2	2	100.0
total	117	127	92.1

package Module::Load::Util;

use strict 'subs', 'vars';
use Regexp::Pattern::Perl::Module ();

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-02-11'; # DATE
our $DIST = 'Module-Load-Util'; # DIST
our $VERSION = '0.008'; # VERSION

use Exporter 'import';
our @EXPORT_OK = qw(
                       load_module_with_optional_args
                       instantiate_class_with_optional_args
               );

sub load_module_with_optional_args {
    my $opts = ref($_[0]) eq 'HASH' ? shift : {};
    my $module_with_optional_args = shift;

    my $target_package =
        defined $opts->{target_package} ? $opts->{target_package} :
        defined $opts->{caller} ? $opts->{caller} :
        caller(0);
    # check because we will use eval ""
    $target_package =~ $Regexp::Pattern::Perl::Module::RE{perl_modname}{pat}
        or die "Invalid syntax in target package '$target_package'";

    my ($module, $args) = @_;
    if (ref $module_with_optional_args eq 'ARRAY') {
        die "array form or module/class name must have 1 or 2 elements"
            unless @$module_with_optional_args == 1 || @$module_with_optional_args == 2;
        $module = $module_with_optional_args->[0];
        $args = $module_with_optional_args->[1] || [];
        $args = [%$args] if ref $args eq 'HASH';
        die "In array form of module/class name, the 2nd element must be ".
            "arrayref or hashref" unless ref $args eq 'ARRAY';
    } elsif (ref $module_with_optional_args) {
        die "module/class name must be string or 2-element array, not ".
            $module_with_optional_args;
    } elsif ($module_with_optional_args =~ /(.+?)=(.*)/) {
        $module = $1;
        $args = [split /,/, $2];
    } else {
        $module = $module_with_optional_args;
        $args = [];
    }

    my @ns_prefixes = $opts->{ns_prefixes} ? @{$opts->{ns_prefixes}} :
        defined($opts->{ns_prefix}) ? ($opts->{ns_prefix}) : ('');
    my $try_all = $opts->{ns_prefixes} ? 1:0;
    my $module_with_prefix;
    for my $i (0 .. $#ns_prefixes) {
        my $ns_prefix = $ns_prefixes[$i];
        if (length $ns_prefix) {
            $module_with_prefix =
                $ns_prefix . ($ns_prefix =~ /::\z/ ? '':'::') . $module;
        } else {
            $module_with_prefix = $module;
        }

        # XXX option load=0?
        (my $module_with_prefix_pm = "$module_with_prefix.pm") =~ s!::!/!g;
        if ($try_all) {
            eval { require $module_with_prefix_pm }; last unless $@;
            warn $@ if $@ !~ /\ACan't locate/;
        } else {
            require $module_with_prefix_pm;
        }
    }
    if ($@) {
        die "load_module_with_optional_args(): Failed to load module '$module' (all prefixes tried: ".join(", ", @ns_prefixes).")";
    }
    $module = $module_with_prefix;

    my $do_import = defined $opts->{import} ? $opts->{import} : 1;
    if ($do_import) {
        eval "package $target_package; $module->import(\@{\$args});"; ## no critic: BuiltinFunctions::ProhibitStringyEval
        die if $@;
    }

    {module=>$module, args=>$args};
}

sub instantiate_class_with_optional_args {
    my $opts = ref($_[0]) eq 'HASH' ? {%{shift()}} : {}; # shallow copy
    my $class_with_optional_args = shift;

    $opts->{import} = 0;
    $opts->{target_package} = caller(0);
    my $res = load_module_with_optional_args($opts, $class_with_optional_args);
    my $class = $res->{module};
    my $args  = $res->{args};

    my $do_construct = defined $opts->{construct} ? $opts->{construct} : 1;
    if ($do_construct) {
        my $constructor = defined $opts->{constructor} ?
            $opts->{constructor} : 'new';
        my $obj = $class->$constructor(@$args);
        return $obj;
    } else {
        return +{class=>$class, args=>$args};
    }
}

1;
# ABSTRACT: Some utility routines related to module loading

__END__