File Coverage

blib/lib/Util/Underscore.pm

Criterion	Covered	Total	%
statement	98	99	98.9
branch	10	12	83.3
condition	1	3	33.3
subroutine	32	32	100.0
pod			n/a
total	141	146	96.5

package Util::Underscore;

#ABSTRACT: Common helper functions without having to import them

use strict;
use warnings;

use version 0.77; our $VERSION = qv('v1.4.0');
use overload ();

use Carp ();
use Const::Fast 0.011    ();
use Data::Dump 1.10      ();
use List::MoreUtils 0.07 ();
use List::Util 1.35      ();
use POSIX ();
use Scalar::Util 1.36 ();
use Try::Tiny 0.03    ();
use IPC::Run 0.92 ();


BEGIN {
    # check if a competing "_" exists
    if (keys %{_::}) {
        Carp::confess qq(The package "_" has already been defined);
    }
}

BEGIN {
    # Load the dummy "_.pm" module.
    # This will set up various booby traps so that "_" isn't used directly.
    # In order to prevent the traps from triggering when *we* go there, we have
    # to declare our peaceful intentions:
    local our $_WE_COME_IN_PEACE = 'pinky swear';
    require _;
}

our $_ASSIGN_ALIASES;

BEGIN {
    $_ASSIGN_ALIASES = sub {
        my ($pkg, %aliases) = @_;
        no strict 'refs';    ## no critic (ProhibitNoStrict)
        while (my ($this, $that) = each %aliases) {
            my $target = "_::${this}";
            my $source = "${pkg}::${that}";
            *{$target} = *{$source}{CODE}
                // Carp::croak "Unknown subroutine $source in _ASSIGN_ALIASES";
        }
    };
}


# From now, every function is in the "_" package
## no critic (ProhibitMultiplePackages)
package    # Hide from PAUSE
    _;

## no critic (RequireArgUnpacking, RequireFinalReturn, ProhibitSubroutinePrototypes)
#   Why this "no critic"? In an util module, efficiency is crucial because we
# have no idea about the context where these function are being used. Therefore,
# no arg unpacking, and no explicit return. Most functions are so trivial anyway
# that this isn't much of a legibility concern.
#   Subroutine prototypes are used to offer a convenient and natural interface.
# I fully understand why they shouldn't be used in ordinary code, but this
# module puts them to mostly good use.

# Predeclare a few things so that we can use them in the sub definitions below.
sub blessed(_);
sub ref_type(_);

# load the actual function collections
use Util::Underscore::Scalars    ();
use Util::Underscore::Numbers    ();
use Util::Underscore::References ();
use Util::Underscore::Objects    ();
use Util::Underscore::ListUtils  ();


BEGIN {
    $_ASSIGN_ALIASES->(
        'Carp',
        carp    => 'carp',
        cluck   => 'cluck',
        croak   => 'croak',
        confess => 'confess',
    );
}

$_ASSIGN_ALIASES->(
    'Try::Tiny',
    try     => 'try',
    catch   => 'catch',
    finally => 'finally',
);

sub carpf($@) {
    my $pattern = shift;
    @_ = sprintf $pattern, @_;
    goto &carp;
}

sub cluckf($@) {
    my $pattern = shift;
    @_ = sprintf $pattern, @_;
    goto &cluck;
}

sub croakf($@) {
    my $pattern = shift;
    @_ = sprintf $pattern, @_;
    goto &croak;
}

sub confessf($@) {
    my $pattern = shift;
    @_ = sprintf $pattern, @_;
    goto &confess;
}


$_ASSIGN_ALIASES->('Scalar::Util', is_open => 'openhandle');

sub _::prototype ($;$) {
    if (@_ == 2) {
        goto &Scalar::Util::set_prototype if @_ == 2;
    }
    if (@_ == 1) {
        my ($coderef) = @_;
        return prototype $coderef;    # Calls CORE::prototype
    }
    else {
        ## no critic (RequireInterpolationOfMetachars)
        Carp::confess '_::prototype($;$) takes exactly one or two arguments';
    }
}

# This sub uses CamelCase because it's a factory function
sub Dir(@) {    ## no critic (NamingConventions::Capitalization)
    require Path::Class;
    Path::Class::Dir->new(@_);
}

# This sub uses CamelCase because it's a factory function
sub File(@) {    ## no critic (NamingConventions::Capitalization)
    require Path::Class;
    Path::Class::File->new(@_);
}


$_ASSIGN_ALIASES->(
    'Data::Dump',
    pp => 'pp',
    dd => 'dd',
);


## no critic (ProhibitBuiltinHomonyms)
sub caller(;$) {
    require Util::Underscore::CallStackFrame;
    Util::Underscore::CallStackFrame->of(@_ ? shift() + 1 : 1);
}

sub callstack(;$) {
    my $level = @_ ? shift() + 1 : 1;
    my @callers;
    while (my $caller = Util::Underscore::CallStackFrame->of($level + @callers))
    {
        push @callers, $caller;
    }
    return @callers;
}


$_ASSIGN_ALIASES->(
    'IPC::Run',
    process_run     => 'run',
    process_start   => 'start',
);



1;

__END__