view release on metacpan or  search on metacpan

lib/Badger/Utils.pm  view on Meta::CPAN

    '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 $_ ? $_ : '<undef>' } @_),
        "\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';
}