File Coverage

blib/lib/Getopt/Yath/Util.pm

Criterion	Covered	Total	%
statement	37	73	50.6
branch	9	28	32.1
condition	1	9	11.1
subroutine	8	12	66.6
pod	6	6	100.0
total	61	128	47.6

package Getopt::Yath::Util;
use strict;
use warnings;

use Carp qw/confess longmess croak/;
use Cpanel::JSON::XS();
use Importer Importer => 'import';
use File::Temp qw/ tempfile /;

our $VERSION = '2.000007';

our @EXPORT_OK = qw{
    decode_json
    encode_json
    encode_json_file
    decode_json_file

    fqmod
    mod2file
};

my $json   = Cpanel::JSON::XS->new->utf8(1)->convert_blessed(1)->allow_nonref(1);
my $ascii  = Cpanel::JSON::XS->new->ascii(1)->convert_blessed(1)->allow_nonref(1);

sub decode_json { my $out; eval { $out = $json->decode(@_);   1} // confess($@); $out }
sub encode_json { my $out; eval { $out = $ascii->encode(@_);  1} // confess($@); $out }

sub encode_json_file {
    my ($data) = @_;
    my $json = encode_json($data);

    my ($fh, $file) = tempfile("$$-XXXXXX", TMPDIR => 1, SUFFIX => '.json', UNLINK => 0);
    print $fh $json;
    close($fh);

    return $file;
}

sub decode_json_file {
    my ($file, %params) = @_;

    open(my $fh, '<', $file) or die "Could not open '$file': $!";
    my $json = do { local $/; <$fh> };

    if ($params{unlink}) {
        unlink($file) or warn "Could not unlink '$file': $!";
    }

    return decode_json($json);
}

sub mod2file {
    my ($mod) = @_;
    confess "No module name provided" unless $mod;
    my $file = $mod;
    $file =~ s{::}{/}g;
    $file .= ".pm";
    return $file;
}

sub fqmod {
    my ($input, $prefixes, %options) = @_;

    croak "At least 1 prefix is required" unless $prefixes;

    $prefixes = [$prefixes] unless ref($prefixes) eq 'ARRAY';

    croak "At least 1 prefix is required" unless @$prefixes;
    croak "Cannot use no_require when providing multiple prefixes" if $options{no_require} && @$prefixes > 1;

    if ($input =~ m/^\+(.*)$/) {
        my $mod = $1;
        return $mod if $options{no_require};
        return $mod if eval { require(mod2file($mod)); 1 };
        confess($@);
    }

    my %tried;
    for my $pre (@$prefixes) {
        my $mod = $input =~ m/^\Q$pre\E/ ? $input : "$pre\::$input";

        if ($options{no_require}) {
            return $mod;
        }
        else {
            return $mod if eval { require(mod2file($mod)); 1 };
            ($tried{$mod}) = split /\n/, $@;
            $tried{$mod} =~ s{^(Can't locate \S+ in \@INC).*$}{$1.};
        }
    }

    my @caller = caller;

    die "Could not locate a module matching '$input' at $caller[1] line $caller[2], the following were checked:\n" . join("\n", map { " * $_: $tried{$_}" } sort keys %tried) . "\n";
}

1;

__END__