view release on metacpan or  search on metacpan

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

    # 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";
}

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


sub isa_perl {
    my ($path_or_url) = @_;

    return $path_or_url =~ m{ / perl-[\d.]+ \.tar \.(?: gz|bz2 ) $ }mx;
}

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


sub mtime {
    my ($file) = @_;

    throw 'Must supply a file'   if not $file;
    throw "$file does not exist" if not -e $file;

    return ( stat $file )[9];
}

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


sub md5 {
    my ($file) = @_;

    throw 'Must supply a file'   if not $file;
    throw "$file does not exist" if not -e $file;

    my $fh  = $file->openr();
    my $md5 = Digest::MD5->new->addfile($fh)->hexdigest();

    return $md5;
}

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


sub sha256 {
    my ($file) = @_;

    throw 'Must supply a file'   if not $file;
    throw "$file does not exist" if not -e $file;

    my $fh     = $file->openr();
    my $sha256 = Digest::SHA->new(256)->addfile($fh)->hexdigest();

    return $sha256;
}

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

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

    return if not defined $string;

    $string =~ s/ ([a-z]) ([A-Z]) /$1_$2/xg;

    return lc $string;
}

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


sub indent_text {
    my ( $string, $spaces ) = @_;

    return $string if not $spaces;
    return $string if not $string;

    my $indent = ' ' x $spaces;
    $string =~ s/^ /$indent/xmg;

    return $string;
}

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


sub mksymlink {
    my ( $from, $to ) = @_;

    # TODO: Try to add Win32 support here, somehow.
    debug "Linking $to to $from";
    symlink $to, $from or throw "symlink to $to from $from failed: $!";

    return 1;
}

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


sub is_system_prop {
    my $string = shift;

    return 0 if not $string;
    return $string =~ m/^ pinto- /x;
}

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


sub uuid {
    return UUID::Tiny::create_uuid_as_string(UUID::Tiny::UUID_V4);
}

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


sub user_colors {
    my $colors = $ENV{PINTO_COLORS} || $ENV{PINTO_COLOURS};

    return $PINTO_DEFAULT_COLORS if not $colors;

    return [ split m/\s* , \s*/x, $colors ];
}

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


sub is_blank {
    my ($string) = @_;

    return 1 if not $string;
    return 0 if $string =~ m/ \S /x;
    return 1;
}

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


sub is_not_blank {
    my ($string) = @_;

    return !is_blank($string);
}

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


sub mask_url_passwords {
    my ($url) = @_;

    $url =~ s{ (https?://[^:/@]+ :) [^@/]+@}{$1*password*@}gx;

    return $url;
}

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


sub is_remote_repo {
    my ($url) = @_;

    return if not $url;
    return $url =~ m{^https?://}x;
}

#-------------------------------------------------------------------------------
1;

__END__

=pod

=encoding UTF-8

=for :stopwords Jeffrey Ryan Thalhammer

=head1 NAME

Pinto::Util - Static utility functions for Pinto

=head1 VERSION