view release on metacpan or  search on metacpan

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

    # Input string is too short
    return $string if length($string) <= $cutoff;

    # Truncate
    my $fix = floor($reallenght / 2);
    my $new_start = substr($string, 0, ($reallenght - $fix)); # Start part of string
       $new_start =~ s/\s+$//; # trim
    my $new_midle = $marker x $dots; # Middle part of string
    my $new_end   = substr($string, (length($string) - $fix), $fix); # Last part of string
       $new_end   =~ s/^\s+//; # trim
    return sprintf ("%s%s%s", $new_start, $new_midle, $new_end);
}
sub indent {
    my $str = shift // '';
    my $ind = floor(shift || 0);
    my $chr = shift // ' ';
    return $str unless $ind && $ind <= 65535;
    return join '', map { ($chr x $ind) . $_ . "\n" } split /\n/, $str;
}
sub words {
    my @in;
    foreach my $r (@_) {
        if (ref($r) eq 'ARRAY') { push @in, @$r } else { push @in, $r }
    }
    my %o;
    my $i = 0;
    foreach my $s (@in) {
        $s = trim($s // '');
        next unless length($s) && !ref($s);
        foreach my $w (split(/[\s;,]+/, $s)) {
            next unless length($w);
            $o{$w} = ++$i unless exists $o{$w};
        }
    }
    return [sort {$o{$a} <=> $o{$b}} keys %o ];
}

# File utils
sub touch {
    my $fn  = shift // '';
    return 0 unless length($fn);
    my $t = time;
    my $ostat = open my $fh, '>>', $fn;
    unless ($ostat) {
        carp("Can't touch file \"$fn\": $!");
        return 0;
    }
    close $fh if $ostat;
    utime($t, $t, $fn);
    return 1;
}
sub eqtime {
    my $src = shift // '';
    my $dst = shift // '';
    return 0 unless length($src);
    return 0 unless length($dst);
    unless ($src && -e $src) {
        carp("Can't get access and modification times of file \"$src\": no file found");
        return 0;
    }
    unless (utime((stat($src))[8,9], $dst)) {
        carp("Can't change access and modification times on file \"$dst\": $!");
        return 0;
    }
    return 1;
}
sub slurp {
    my $file = shift // '';
    my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    return unless length($file) && -r $file;
    my $cleanup = 1;

    # Open filehandle
    my $fh;
    if (ref($file)) {
        $fh = $file;
        $cleanup = 0; # Disable closing filehandle for passed filehandle
    } else {
        $fh = IO::File->new($file, "r");
        unless (defined $fh) {
            carp qq/Can't open file "$file": $!/;
            return;
        }
    }

    # Set binmode layer
    my $bm = $args->{binmode} // ':raw'; # read in :raw by default
    $fh->binmode($bm);

    # Set buffer
    my $buf;
    my $buf_ref = $args->{buffer} // \$buf;
     ${$buf_ref} = ''; # Set empty string to buffer
    my $blk_size = $args->{block_size} || 1024 * 1024; # Set block size (1 MiB)

    # Read whole file
    my ($pos, $ret) = (0, 0);
    while ($ret = $fh->read(${$buf_ref}, $blk_size, $pos)) {
        $pos += $ret if defined $ret;
    }
    unless (defined $ret) {
        carp qq/Can't read from file "$file": $!/;
        return;
    }

    # Close filehandle
    $fh->close if $cleanup; # automatically closes the file

    # Return content if no buffer specified
    return if defined $args->{buffer};
    return ${$buf_ref};
}
sub spew {
    my $file = shift // '';
    my $data = shift // '';
    my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    my $cleanup = 1;

    # Get binmode layer, mode and perms
    my $bm = $args->{binmode} // ':raw'; # read in :raw by default
    my $perms = $args->{perms} // 0666; # set file permissions