view release on metacpan or  search on metacpan

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

=head2 strf

    print strf( $format, %data );
    print strf( $format, \%data );

The C<strf> function returns a string representing hash-data as string in specified C<$format>.
This function is somewhat similar to the C function strftime(), except that the data source
is not the date and time, but the set of data passed to the function.

The format string may be containing any combination of regular characters and special format
specifiers (patterns). These patterns are replaced to the corresponding values to represent
the data passed as  second function argument. They all begin with a percentage (%) sign,
and are: '%c' or '%{word}'. The "c" is single character specifier like %d, the "word" is
regular word like "month" or "filename"

If you give a pattern that doesn't exist, then it is simply treated as text.
If you give a pattern that doesn't defined but is exist in data set, then it will be
replaced to empty text string ('')

B<Please note!> All patterns C<'%%'> will be replaced to literal C<'%'> character if you not
redefinet this pattern in Your data set manually

Simple examples:

    my %d = (
        f => 'foo',
        b => 'bar',
        baz => 'test',
        u => undef,
        t => time,
        d => 1,
        i => 2000,
        n => "\n",
    );

    print strf("test %f string", %d); # "test foo string"
    print strf("%{baz} time=%t", %d); # "test time=1234567890"
    print strf("test %f%b%i", %d); # "test foobar2000"
    print strf("%d%% %{baz}", \%d); # "1% test"
    print strf("%f%n%b", \%d); # "foo\nbar"
    print strf("%f%u%b", \%d); # "foobar"
    print strf("%f%X%b", \%d); # "foo%Xbar"

=head2 touch

    touch( "file" ) or die "Can't touch file";

Makes file exist, with current timestamp

See L<ExtUtils::Command>

=head2 trim

    print '"'.trim( "    string " ).'"'; # "string"

Returns the string with all leading and trailing whitespace removed.
Trim on undef returns undef. Original this function see String::Util

=head2 truncstr

    print truncstr( $string, $cutoff_length, $continued_symbol );

If the $string is longer than the $cutoff_length, then the string will be truncated
to $cutoff_length characters, including the $continued_symbol
(which defaults to '.' if none is specified).

    print truncstr( "qwertyuiop", 3, '.' ); # q.p
    print truncstr( "qwertyuiop", 7, '.' ); # qw...op
    print truncstr( "qwertyuiop", 7, '*' ); # qw***op

Returns a line the fixed length from 3 to the n chars

See also L<CTK::Util/variant_stf>

=head2 tz_diff

    print tz_diff( time ); # +0300
    print tz_diff( time, ':' ); # +03:00

Returns TimeZone difference value

    print fdt("%w, %DD %MON %YYYY %hh:%mm:%ss ".tz_diff(time), time);

Prints RFC-2822 format date

=head2 words

    my $arr = words( ' foo bar,  baz bar ' ); # ['foo', 'bar', 'baz']
    my $arr = words( ' foo bar ', '  baz' ); # ['foo', 'bar', 'baz']
    my $arr = words( [' foo bar ', '  baz'] ); # ['foo', 'bar', 'baz']
    my $arr = words( ['foo, bar'], ['baz bar '] ); # ['foo', 'bar', 'baz']

This function parse string by words and returns as an anonymous array.
All words in the resultating array are unique and arranged
in the order of the input string

=head1 HISTORY

See C<Changes> file

=head1 TO DO

See C<TODO> file

=head1 SEE ALSO

L<Mojo::Util>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2026 D&D Corporation

=head1 LICENSE

This program is distributed under the terms of the Artistic License Version 2.0

See the C<LICENSE> file or L<https://opensource.org/license/artistic-2-0> for details

=cut

use Carp qw/ carp croak /;
use IO::File qw//;
use Term::ANSIColor qw/ colored /;
use POSIX qw/ :fcntl_h ceil floor strftime /;
use Fcntl qw/ O_WRONLY O_CREAT O_APPEND O_EXCL SEEK_END /;
use Time::Local;
use Data::Dumper qw//;

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

    } elsif ($t=~/^([+-]?(?:\d+|\d*\.\d*))([smhdwMy])/) {
        return ($mult{$2} || 1) * $1;
    }
    return $t;
}
sub parse_time_offset {
    my $s = trim(shift(@_) // 0);
    return $s if $s =~ /^\d+$/;
    my $r = 0;
    my $c = 0;
    while ($s =~ s/([+-]?(?:\d+|\d*\.\d*)[smhdMy])//) {
        my $i = parse_expire("$1");
        $c++ if $i < 0;
        $r += $i < 0 ? $i*-1 : $i;
    }
    return $c ? $r*-1 : $r;
}
sub fdt {
    my $f = shift || ''; # Format
    my $t = shift || time(); # Time
    my $g = shift || 0; # 0 - Local time; 1 - GMT time

    my (@dt, %dth, %dth2);
    @dt = $g ? gmtime($t) : localtime($t);

    $dth{'%s'}     = $dt[0] || 0;
    $dth{'%ss'}    = sprintf('%02d',$dth{'%s'});
    $dth{'%_s'}    = sprintf('%2d',$dth{'%s'});
    $dth{'%m'}     = $dt[1] || 0;
    $dth{'%mm'}    = sprintf('%02d',$dth{'%m'});
    $dth{'%_m'}    = sprintf('%2d',$dth{'%m'});
    $dth{'%h'}     = $dt[2] || 0;
    $dth{'%hh'}    = sprintf('%02d',$dth{'%h'});
    $dth{'%_h'}    = sprintf('%2d',$dth{'%h'});
    $dth{'%D'}     = $dt[3] || 0;
    $dth{'%DD'}    = sprintf('%02d',$dth{'%D'});
    $dth{'%_D'}    = sprintf('%2d',$dth{'%D'});
    $dth{'%M'}     = $dt[4] || 0; $dth{'%M'}++;
    $dth{'%MM'}    = sprintf('%02d',$dth{'%M'});
    $dth{'%_M'}    = sprintf('%2d',$dth{'%M'});
    $dth{'%Y'}     = $dt[5] || 0; $dth{'%Y'}+=1900;
    $dth{'%YY'}    = sprintf('%02d',$dth{'%Y'}%100);
    $dth{'%YYY'}   = sprintf('%03d',$dth{'%Y'}%1000);
    $dth{'%YYYY'}  = sprintf('%04d',$dth{'%Y'});
    $dth{'%_Y'}    = sprintf('%2d',$dth{'%Y'}%100);
    $dth{'%_YY'}   = sprintf('%3d',$dth{'%Y'}%1000);
    $dth{'%w'}     = DTF->{DOWS}->[$dt[6] || 0];
    $dth{'%W'}     = DTF->{DOW}->[$dt[6] || 0];
    $dth{'%MON'}   = DTF->{MOYS}->[$dt[4] || 0];
    $dth{'%mon'}   = DTF->{MOYS}->[$dt[4] || 0];
    $dth{'%MONTH'} = DTF->{MOY}->[$dt[4] || 0];
    $dth{'%month'} = DTF->{MOY}->[$dt[4] || 0];

    # Second block
    $dth2{'%G'}    = 'GMT' if $g;
    $dth2{'%U'}    = 'UTC' if $g;
    $dth2{'%z'}    = tz_diff($t, ':');
    $dth2{'%Z'}    = $dth2{'%z'}; $dth2{'%Z'} =~ s/\://;
    $dth2{'%%'}    = '%';

    $f =~ s/$_/$dth{$_}/sge for sort { length($b) <=> length($a) } keys %dth;
    $f =~ s/$_/$dth2{$_}/sge for qw/%G %U %Z %z %%/;

    return $f
}
sub dtf { goto &fdt }
sub tz_diff {
    my $tm = shift || time;
    my $chr = shift // '';
    my $diff = Time::Local::timegm(localtime($tm)) - Time::Local::timegm(gmtime($tm));
       $diff  = abs($diff);
    my $direc = $diff < 0 ? '-' : '+';
    my $tz_hr = int( $diff / 3600 );
    my $tz_mi = int( $diff / 60 - $tz_hr * 60 );
    return sprintf("%s%02d%s%02d", $direc, $tz_hr, $chr, $tz_mi);
}

# Text utils
sub trim {
    my $val = shift;
    return unless defined $val;
    $val =~ s|^\s+||s; # trim left
    $val =~ s|\s+$||s; # trim right
    return $val;
}
sub dformat { # Simple templating processor
    my $f = shift;
    my $d = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    $f =~ s/\[([A-Z0-9_\-.]+?)\]/(defined($d->{$1}) ? $d->{$1} : "[$1]")/eg;
    return $f;
}
sub strf { # Yet another simple templating processor
    my $s = shift // '';
    my $h = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
    return '' unless length $s;
    $h->{'%'} //= '%'; # by default '%' eq '%''

    $s =~ s/
            (?:
              %\{(\w+)\}       # short name like %{name}
              |
              %([%a-zA-Z])     # single character specifier like %d
            )
           /
            ( $1
              ? ( defined($h->{$1}) ? $h->{$1} : exists($h->{$1}) ? '' : "\%{$1}" )
              : $2
              ? ( defined($h->{$2}) ? $h->{$2} : exists($h->{$2}) ? '' : "\%$2" )
              : ''
            )
        /sgex;

    return $s;
}
sub randchars {
    my $l = shift || return '';
    return '' unless $l =~/^\d+$/;
    my $arr = shift;
    my $r = '';
    my @chars = ($arr && ref($arr) eq 'ARRAY') ? (@$arr) : (0..9,'a'..'z','A'..'Z');
    $r .= $chars[(int(rand($#chars+1)))] for (1..$l);
    return $r;
}
sub truncstr {
    my $string = shift // '';
    my $cutoff = shift || 0;
    my $marker = shift // '.';

    # Get dots dumber
    my $dots = 0;
    $cutoff = 3 if $cutoff < 3;
    if ($cutoff < 6) { $dots = $cutoff - 2 }
    else { $dots = 3 }

    # Real length of cutted string
    my $reallenght = $cutoff - $dots;

    # 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
    my $mode = $args->{mode} // O_WRONLY | O_CREAT;
       $mode |= O_APPEND if $args->{append};
       $mode |= O_EXCL if $args->{locked};

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

    # Set binmode layer
    $fh->binmode($bm);

    # Set buffer
    my $buf;
    my $buf_ref = \$buf;
    if (ref($data) eq 'SCALAR') {
        $buf_ref = $data;
    } elsif (ref($data) eq 'ARRAY') {
        ${$buf_ref} = join '', @$data;
    } else {
        $buf_ref = \$data;
    }

    # Seek, print, truncate and close
    $fh->seek(0, SEEK_END) if $args->{append}; # SEEK_END == 2
    $fh->print(${$buf_ref}) or return;
    $fh->truncate($fh->tell) if $cleanup;
    $fh->close if $cleanup;

    return 1;
}
sub spurt { goto &spew }

# Colored helper function
sub color {
    my $clr = shift;
    my $txt = (scalar(@_) == 1) ? shift(@_) : sprintf(shift(@_), @_);
    return $txt unless defined($clr) && length($clr);
    return IS_TTY ? colored([$clr], $txt) : $txt;
}

# Misc
sub os_type {
    my $os = shift // $^O;
    return $OSTYPES{$os} || '';
}
sub is_os_type {
    my $type = shift || return;
    return os_type(shift) eq $type;
}

# Copied from ExtUtils::MakeMaker and IO::Prompt::Tiny
sub prompt {
    my $msg = shift // '';
    my $def = shift // '';
    my $dispdef = length($def) ? "[$def] " : " ";

    # Flush vars
    local $|=1;
    local $\;

    # Prompt message
    print length($msg) ? "$msg $dispdef" : "$dispdef";

    my $ans;
    if (!IS_TTY && eof STDIN) {
        print "$def\n";
    } else {
        $ans = <STDIN>;
        if( defined $ans ) {
            chomp $ans;
        } else { # user hit ctrl-D
            print "\n";
        }
    }

    return (!defined $ans || $ans eq '') ? $def : $ans;
}

1;

__END__