File Coverage

blib/lib/Module/Load/Util.pm

Criterion	Covered	Total	%
statement	90	97	92.7
branch	59	78	75.6
condition	4	8	50.0
subroutine	9	9	100.0
pod	4	4	100.0
total	166	196	84.6

package Module::Load::Util;

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

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-05-13'; # DATE
our $DIST = 'Module-Load-Util'; # DIST
our $VERSION = '0.012'; # VERSION

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

sub _normalize_module_with_optional_args {
    my $module_with_optional_args = shift;

    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 = [];
    }
    ($module, $args);
}

sub _load_module {
    my $opts = ref $_[0] eq 'HASH' ? shift : {};
    my $module = shift;

    my $do_load = defined $opts->{load} ? $opts->{load} : 1;

    unless ($do_load) {
        if ($opts->{ns_prefix}) {
            $module = $opts->{ns_prefix} . ($opts->{ns_prefix} =~ /::\z/ ? '' : '::') . $module;
        } elsif ($opts->{ns_prefixes} && @{ $opts->{ns_prefixes} }) {
            $module = $opts->{ns_prefixes}[0] . ($opts->{ns_prefixes}[0] =~ /::\z/ ? '' : '::') . $module;
        }
        return $module;
    }

    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;
        }

        (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_with_prefix;
}

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) = _normalize_module_with_optional_args(
        $module_with_optional_args);
    $module = _load_module($opts, $module);

    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);
    #use DD; print "Options: "; dd $opts; print "Result: "; dd $res;
    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};
    }
}

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

    my ($module, $args) = _normalize_module_with_optional_args(
        $module_with_optional_args);
    my $function;
    if (defined $opts->{function}) {
        $function = $opts->{function};
    } else {
        $module =~ s/\A(.+)::(\w+)\z/$1/ or die "Please specify MODULE::FUNCTION, not just module name '$module'";
        $function = $2;
    }
    $module = _load_module($opts, $module);

    &{"$module\::$function"}(@$args);
}

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

    my ($module, $args) = _normalize_module_with_optional_args(
        $module_with_optional_args);
    my $method;
    if (defined $opts->{method}) {
        $method = $opts->{method};
    } else {
        $module =~ s/\A(.+)::(\w+)\z/$1/ or die "Please specify MODULE::FUNCTION, not just module name '$module'";
        $method = $2;
    }

    $module = _load_module($opts, $module);

    $module->$method(@$args);
}

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

__END__