view release on metacpan or  search on metacpan

lib/Pinto/Util.pm  view on Meta::CPAN

    author_dir
    body_text
    current_author_id
    current_utc_time
    current_time_offset
    current_username
    debug
    decamelize
    indent_text
    interpolate
    is_blank
    is_not_blank
    is_interactive
    is_remote_repo
    is_system_prop
    isa_perl
    itis
    md5
    mksymlink
    mtime
    parse_dist_path
    mask_url_passwords
    sha256
    title_text
    throw
    trim_text
    truncate_text
    user_colors
    uuid
    whine
);

Readonly our %EXPORT_TAGS => ( all => \@EXPORT_OK );

#-------------------------------------------------------------------------------


sub throw {
    my ($error) = @_;

    # Rethrowing...
    die $error if itis( $error, 'Pinto::Exception' );    ## no critic (Carping)

    require Pinto::Exception;
    Pinto::Exception->throw( message => "$error" );

    return;                                              # Should never get here
}

#-------------------------------------------------------------------------------


sub debug {
    my ($it) = @_;

    # TODO: Use Carp instead?

    return 1 if not $ENV{PINTO_DEBUG};

    $it = $it->() if ref $it eq 'CODE';
    my ( $file, $line ) = (caller)[ 1, 2 ];
    print {*STDERR} "$it in $file at line $line\n";

    return 1;
}

#-------------------------------------------------------------------------------


sub whine {
    my ($message) = @_;

    if ( $ENV{DEBUG} ) {
        Carp::cluck($message);
        return 1;
    }

    chomp $message;
    warn $message . "\n";

    return 1;
}

#-------------------------------------------------------------------------------


sub author_dir {    ## no critic (ArgUnpacking)
    my $author = uc pop;
    my @base   = @_;

    return dir( @base, substr( $author, 0, 1 ), substr( $author, 0, 2 ), $author );
}

#-------------------------------------------------------------------------------


sub itis {
    my ( $var, $class ) = @_;

    return ref $var && Scalar::Util::blessed($var) && $var->isa($class);
}

#-------------------------------------------------------------------------------


sub parse_dist_path {
    my ($path) = @_;

    # eg: /yadda/authors/id/A/AU/AUTHOR/subdir1/subdir2/Foo-1.0.tar.gz
    # or: A/AU/AUTHOR/subdir/Foo-1.0.tar.gz

    if ( $path =~ s{^ (?:.*/authors/id/)? (.*) $}{$1}mx ) {

        # $path = 'A/AU/AUTHOR/subdir/Foo-1.0.tar.gz'
        my @path_parts = split m{ / }mx, $path;
        my $author     = $path_parts[2];          # AUTHOR
        my $archive    = $path_parts[-1];         # Foo-1.0.tar.gz
        return ( $author, $archive );
    }

    throw "Unable to parse path: $path";