File Coverage

lib/Badger/Utils.pm

Criterion	Covered	Total	%
statement	174	203	85.7
branch	49	72	68.0
condition	29	54	53.7
subroutine	39	42	92.8
pod	23	26	88.4
total	314	397	79.0

#========================================================================
#
# Badger::Utils
#
# DESCRIPTION
#   Module implementing various useful utility functions.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Utils;

use strict;
use warnings;
use base 'Badger::Exporter';
use File::Path;
use Scalar::Util qw( blessed );
use Badger::Constants 'HASH ARRAY PKG DELIMITER BLANK TRUE FALSE';
use Badger::Debug
    import  => ':dump',
    default => 0;
use overload;
use constant {
    UTILS  => 'Badger::Utils',
    CLASS  => 0,
    FILE   => 1,
    LOADED => 2,
};

our $VERSION  = 0.02;
our $ERROR    = '';
our $WARN     = sub { warn @_ };  # for testing - see t/core/utils.t
our $MESSAGES = { };
our $HELPERS  = {       # keep this compact in case we don't need to use it
    'Digest::MD5'        => 'md5 md5_hex md5_base64',
    'Scalar::Util'       => 'blessed dualvar isweak readonly refaddr reftype
                             tainted weaken isvstring looks_like_number
                             set_prototype',
    'List::Util'         => 'first max maxstr min minstr reduce shuffle sum',
    'List::MoreUtils'    => 'any all none notall true false firstidx
                             first_index lastidx last_index insert_after
                             insert_after_string apply after after_incl before
                             before_incl indexes firstval first_value lastval
                             last_value each_array each_arrayref pairwise
                             natatime mesh zip uniq minmax',
    'Hash::Util'         => 'lock_keys unlock_keys lock_value unlock_value
                             lock_hash unlock_hash hash_seed',
    'Badger::Date'       => 'DATE Date Today',
    'Badger::Timestamp'  => 'TIMESTAMP TS Timestamp Now',
    'Badger::Logic'      => 'LOGIC Logic',
    'Badger::Duration'   => 'DURATION Duration',
    'Badger::URL'        => 'URL',
    'Badger::Filter'     => 'FILTER Filter',
    'Badger::Filesystem' => 'FS File Dir Bin Cwd',
    'Badger::Filesystem::Virtual'
                         => 'VFS',
};
our $DELEGATES;         # fill this from $HELPERS on demand
our $RANDOM_NAME_LENGTH = 32;
our $TEXT_WRAP_WIDTH    = 78;


__PACKAGE__->export_any(qw(
    UTILS blessed is_object numlike textlike truelike falselike
    params self_params plural
    odd_params xprintf dotid random_name camel_case CamelCase wrap
    permute_fragments plurality inflect split_to_list extend merge merge_hash
    list_each hash_each join_uri resolve_uri
));

__PACKAGE__->export_fail(\&_export_fail);

# looks_like_number() is such a mouthful.  I prefer numlike() to go with textlike()
*numlike = \&Scalar::Util::looks_like_number;

# it would be too confusing not to have this alias
*CamelCase = \&camel_case;


sub _export_fail {
    my ($class, $target, $symbol, $more_symbols) = @_;
    $DELEGATES ||= _expand_helpers($HELPERS);
    my $helper = $DELEGATES->{ $symbol } || return 0;
    require $helper->[FILE] unless $helper->[LOADED];
    $class->export_symbol($target, $symbol, \&{ $helper->[CLASS].PKG.$symbol });
    return 1;
}

sub _expand_helpers {
    # invert { x => 'a b c' } into { a => 'x', b => 'x', c => 'x' }
    my $helpers = shift;
    return {
        map {
            my $name = $_;                      # e.g. Scalar::Util
            my $file = module_file($name);      # e.g. Scalar/Util.pm
            map { $_ => [$name, $file, 0] }     # third item is loaded flag
            split(DELIMITER, $helpers->{ $name })
        }
        keys %$helpers
    }
}

sub is_object($$) {
    blessed $_[1] && $_[1]->isa($_[0]);
}

sub textlike($) {
    !  ref $_[0]                        # check if $[0] is a non-reference
    || blessed $_[0]                    # or an object with an overloaded
    && overload::Method($_[0], '""');   # '""' stringification operator
}

sub truelike($) {
    falselike($_[0]) ? FALSE : TRUE;
}

sub falselike($) {
    (! $_[0] || $_[0] =~ /^(0|off|no|none|false)$/i) ? TRUE : FALSE;
}

sub params {
    # enable $DEBUG to track down calls to params() that pass an odd number
    # of arguments, typically when the rhs argument returns an empty list,
    # e.g. $obj->foo( x => this_returns_empty_list() )
    my @args = @_;
    local $SIG{__WARN__} = sub {
        odd_params(@args);
    } if DEBUG;

    @_ && ref $_[0] eq HASH ? shift : { @_ };
}

sub self_params {
    my @args = @_;
    local $SIG{__WARN__} = sub {
        odd_params(@args);
    } if DEBUG;

    (shift, @_ && ref $_[0] eq HASH ? shift : { @_ });
}

sub odd_params {
    my $method = (caller(2))[3];
    $WARN->(
        "$method() called with an odd number of arguments: ",
        join(', ', map { defined $_ ? $_ : '' } @_),
        "\n"
    );
    my $i = 3;
    while (1) {
        my @info = caller($i);
        last unless @info;
        my ($pkg, $file, $line, $sub) = @info;
        $WARN->(
            sprintf(
                "%4s: Called from %s in %s at line %s\n",
                '#' . ($i++ - 2), $sub, $file, $line
            )
        );
    }
}


sub module_file {
    my $file = shift;
    $file  =~ s[::][/]g;
    $file .= '.pm';
}

sub xprintf {
    my $format = shift;
    my @args   = @_;
    $format =~
        s{ < (\d+)
             (?: :( [#\-\+ ]? [\w\.]+ ) )?
             (?: \| (.*?) )?
           >
         }
         {   defined $3
                ? _xprintf_ifdef(\@args, $1, $2, $3)
                : '%' . $1 . '$' . ($2 || 's')
        }egx;
    no if $] > 5.021, warnings => "redundant";
    sprintf($format, @_);
}

sub _xprintf_ifdef {
    my ($args, $n, $format, $text) = @_;
    if (defined $args->[$n-1]) {
        $format = 's' unless defined $format;
        $format = '%' . $n . '$' . $format;
        $text =~ s/\?/$format/g;
        return $text;
    }
    else {
        return '';
    }
}

sub dotid {
    my $text = shift;       # munge $text to canonical lower case and dotted form
    $text =~ s/\W+/./g;     # e.g. Foo::Bar ==> Foo.Bar
    return lc $text;        # e.g. Foo.Bar  ==> foo.bar
}

sub camel_case {
    join(
        BLANK,
        map {
            map { ucfirst $_ }
            split '_'
        }
        @_
    );
}

sub random_name {
    my $length = shift || $RANDOM_NAME_LENGTH;
    my $name   = '';
    require Digest::MD5;

    while (length $name < $length) {
        $name .= Digest::MD5::md5_hex(
            time(), rand(), $$, { }, @_
        );
    }
    return substr($name, 0, $length);
}

sub alternates {
    my $text = shift;
    return  [
        $text =~ /\|/
            ? split(qr<\|>, $text, -1)  # alternates: (foo|bar) as ['foo', 'bar']
            : ('', $text)               # optional (foo) as (|foo) as ['', 'foo']
    ];
}

sub wrap {
    my $text   = shift;
    my $width  = shift || $TEXT_WRAP_WIDTH;
    my $indent = shift || 0;
    my @words = split(/\s+/, $text);
    my (@lines, @line, $length);
    my $total = 0;

    while (@words) {
        $length = length $words[0] || (shift(@words), next);
        if ($total + $length > 74 || $words[0] eq '\n') {
            shift @words if $words[0] eq '\n';
            push(@lines, join(" ", @line));
            @line = ();
            $total = 0;
        }
        else {
            $total += $length + 1;      # account for spaces joining words
            push(@line, shift @words);
        }
    }
    push(@lines, join(" ", @line)) if @line;
    return join(
        "\n" . (' ' x $indent),
        @lines
    );
}


sub permute_fragments {
    my $input = shift;
    my (@frags, @outputs);

    # Lookup all the (a) optional fragments and (a|b|c) alternate fragments
    # replace them with %s.  This gives us an sprintf format that we can later
    # user to re-fill the fragment slots.  Meanwhile create a list of @frags
    # with each item corresponding to a (...) fragment which is represented
    # by a list reference containing the alternates.  e.g. the input
    # string 'Fo(o|p) Ba(r|z)' generates @frags as ( ['o','p'], ['r','z'] ),
    # leaving $input set to 'Fo%s Ba%s'.  We treat (foo) as sugar for (|foo),
    # so that 'Template(X)' is permuted as ('Template', 'TemplateX'), for
    # example.

    $input =~
        s/
            \( ( .*? ) \)
        /
            push(@frags, alternates($1));
            '%s';
        /gex;

    # If any of the fragments have multiple values then $format will still contain
    # one or more '%s' tokens and @frags will have the same number of list refs
    # in it, one for each fragment.  To iterate across all permutations of the
    # fragment values, we calculate the product P of the sizes of all the lists in
    # @frags and loop from 0 to P-1.  Then we use a div and a mod to get the right
    # value for each fragment, for each iteration.  We divide $n by the product of
    # all fragment lists to the right of the current fragment and mod it by the size
    # of the current fragment list.  It's effectively counting with a different base
    # for each column. e.g. consider 3 fragments with 7, 3, and 5 values respectively
    #   [7]            [3]           [5]         P = 7 * 3 * 5 = 105
    #   [n / 15 % 7]   [n / 5 % 3]   [n % 5]     for 0 < n < P

    if (@frags) {
        my $product = 1; $product *= @$_ for @frags;
        for (my $n = 0; $n < $product; $n++) {
            my $divisor = 1;
            my @args = reverse map {
                my $item = $_->[ $n / $divisor % @$_ ];
                $divisor *= @$_;
                $item;
            } reverse @frags;   # working backwards from right to left
            push(@outputs, sprintf($input, @args));
        }
    }
    else {
        push(@outputs, $input);
    }
    return wantarray
        ?  @outputs
        : \@outputs;
}

#-----------------------------------------------------------------------------
# pluralisation and inflection
#-----------------------------------------------------------------------------

sub plural {
    my $name = shift;

    if ($name =~ /(ss|sh|ch|x)$/) {
        $name .= 'es';
    }
    elsif ($name =~ s/([^aeiou])y$//) {
        $name .= $1.'ies';
    }
    elsif ($name =~ /([^s\d\W])$/) {
        $name .= 's';
    }
    return $name;
}

sub plurality {
    my $n     = shift || 0;
    my @items = map { permute_fragments($_) }
                (@_ == 1 && ref $_[0] eq ARRAY)
                ? @{ $_[0] }
                : @_;

    # if the user specifies a single word then we pluralise it for them,
    # assuming that 0 items are plural, 1 is singular, and > 1 is plural
    if (@items == 1) {
        my $plural = plural($items[0]);
        unshift(@items, $plural);       # 0 whatevers
        push(@items, $plural);          # n whatevers (where n > 1)
    }

    die "$n is not a number\n" unless numlike($n);
    my $i = $n > $#items ? $#items : $n;
    $i    = 0 if $i < 0;

    return $items[$i];
}

sub inflect {
    my $n = shift || 0;
    my $i = shift;
    my $f = shift || '%s %s';
    my $z = @_ ? shift : 'no';
    return xprintf(
        $f, ($n or $z), plurality($n, $i)
    );
}


sub _debug {
    print STDERR @_;
}

#-----------------------------------------------------------------------------
# List utilities
#-----------------------------------------------------------------------------

sub list_each {
    my ($list, $fn) = @_;
    my $n = 0;

    for (@$list) {
        $fn->($list, $n++, $_);
    }

    return $list;
}

sub split_to_list {
    my $list = shift;
    return [ ] unless defined $list and length $list;

    if (! ref $list) {
        return [ split(DELIMITER, $list) ];
    }
    elsif (ref $list eq ARRAY) {
        return $list;
    }
    else {
        return [$list];
    }
}

#-----------------------------------------------------------------------------
# Hash utilities
#-----------------------------------------------------------------------------

sub hash_each {
    my ($hash, $fn) = @_;

    while (my ($key, $value) = each %$hash) {
        $fn->($hash, $key, $value);
    }

    return $hash;
}


sub extend {
    my $hash = shift;
    my $more;

    while (@_) {
        if (! $_[0]) {
            # ignore undefined/false values
            shift;
            next;
        }
        elsif (ref $_[0] eq HASH) {
            $more = shift;
        }
        else {
            $more = params(@_);
            @_    = ();
        }
        @$hash{ keys %$more } = values %$more;
    }

    return $hash;
}

sub merge {
    my $hash = shift;
    my $more;

    while (@_) {
        if (! $_[0]) {
            # ignore undefined/false values
            shift;
            next;
        }
        elsif (ref $_[0] eq HASH) {
            $more = shift;
            $more = { %$more };
        }
        else {
            $more = params(@_);
            @_    = ();
        }
        merge_hash($hash, $more);
    }

    return $hash;
}

sub merge_hash {
    my ($hash, $more) = @_;
    my $into;

    while (my ($key, $value) = each %$more) {
        $into = $hash->{ $key };

        if ($into && ref $into eq HASH && ref $value eq HASH) {
            merge_hash($into, $value);
        }
        else {
            $hash->{ $key } = $value;
        };
    }
    return $hash;
}


#-----------------------------------------------------------------------------
# Simple URI manipulation
#-----------------------------------------------------------------------------

sub join_uri {
    my $uri = join('/', @_);
    $uri =~ s{(?
    return $uri;
}

sub resolve_uri {
    my $base = shift;
    my $rel  = join_uri(@_);
    return ($rel =~ m{^/})
        ? $rel
        : join_uri($base, $rel);
}

1;

__END__