view release on metacpan or  search on metacpan

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

    say color("red on_bright_yellow" => "text");
    say STDERR color("red on_bright_yellow" => "text");

Returns colored formatted string if is session was runned from terminal

Supported normal foreground colors:

    black, red, green, yellow, blue, magenta, cyan, white

Bright foreground colors:

    bright_black, bright_red,     bright_green, bright_yellow
    bright_blue,  bright_magenta, bright_cyan,  bright_white

Normal background colors:

    on_black, on_red,     on_green, on yellow
    on_blue,  on_magenta, on_cyan,  on_white

Bright background color:

    on_bright_black, on_bright_red,     on_bright_green, on_bright_yellow
    on_bright_blue,  on_bright_magenta, on_bright_cyan,  on_bright_white

See also L<Term::ANSIColor>

=head2 deprecated

    deprecated('foo is DEPRECATED in favor of bar');

Warn about deprecated feature from perspective of caller.
You can also set the C<ACRUX_FATAL_DEPRECATIONS> environment
variable to make them die instead with L<Carp>

=head2 dformat

    $string = dformat( $mask, \%replacehash );
    $string = dformat( $mask, %replacehash );

Replace substrings "[...]" in mask and
returns replaced result. Data for replacing get from \%replacehash

For example:

    # -> 01-foo-bar.baz.tgz
    $string = dformat( "01-[NAME]-bar.[EXT].tgz", {
        NAME => 'foo',
        EXT  => 'baz',
    });

See also L<CTK::Util/dformat>

=head2 dtf

See L</fdt>

=head2 dumper

    my $perl = dumper({some => 'data'});

Dump a Perl data structure with L<Data::Dumper>

=head2 eqtime

    eqtime("from/file", "to/file") or die "Oops";

Sets modified time of destination to that of source

=head2 fbytes

    print fbytes( 123456 );

Returns formatted size value

=head2 fdate

    print fdate( time );

Returns formatted date value

=head2 fdatetime

    print fdatetime( time );

Returns formatted date value

=head2 fdt

    print fdt( $format, $time );
    print fdt( $format, $time, 1 ); # in GMT context

Returns time in your format.
Each conversion specification is replaced by appropriate characters as described in the following list

    s, ss, _s - Seconds
    m, mm, _m - Minutes
    h, hh, _h - Hours
    D, DD, _D - Day of month
    M, MM, _M - Month
    Y, YY, YYY, YYYY - Year
    w       - Short form of week day (Sat, Tue and etc)
    W       - Week day (Saturdat, Tuesday and etc)
    MON, mon - Short form of month (Apr, May and etc)
    MONTH, month - Month (April, May and etc)
    Z       - Diff of TimeZone in short format (+0300)
    z       - Diff of TimeZone in lomg format (+03:00)
    G       - Short name of TimeZone GMT (for GMT context only)
    U       - Short name of TimeZone UTC (for GMT context only)

Examples:

    # RFC822 (RSS)
    say fdt("%w, %D %MON %YY %hh:%mm:%ss %G", time(), 1); # Tue, 3 Sep 2013 12:31:40 GMT

    # RFC850
    say fdt("%W, %DD-%MON-%YY %hh:%mm:%ss %G", time(), 1); # Tuesday, 03-Sep-13 12:38:41 GMT

    # RFC1036
    say fdt("%w, %D %MON %YY %hh:%mm:%ss %G", time(), 1); # Tue, 3 Sep 13 12:44:08 GMT

    # RFC1123

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

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-2024 D&D Corporation. All Rights Reserved

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See C<LICENSE> file and L<https://dev.perl.org/licenses/>

=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//;
use Storable qw/dclone/;

use Acrux::Const qw/ IS_TTY DATE_FORMAT DATETIME_FORMAT /;

use base qw/Exporter/;
our @EXPORT = (qw/
        deprecated
        dumper
        clone
    /);
our @EXPORT_OK = (qw/
        fbytes human2bytes humanize_duration humanize_number
        fdt dtf tz_diff fdate fdatetime fduration
        randchars
        dformat strf trim truncstr indent words
        touch eqtime slurp spew spurt
        parse_expire parse_time_offset
        os_type is_os_type
        color load_class
        prompt
    /, @EXPORT);

use constant HUMAN_SUFFIXES => {
    'B' => 0,
    'K' => 10, 'KB' => 10, 'KIB' => 10,
    'M' => 20, 'MB' => 20, 'MIB' => 20,
    'G' => 30, 'GB' => 30, 'GIB' => 30,
    'T' => 40, 'TB' => 40, 'TIB' => 40,
    'P' => 50, 'PB' => 50, 'PIB' => 50,
    'E' => 60, 'EB' => 60, 'EIB' => 60,
    'Z' => 70, 'ZB' => 70, 'ZIB' => 70,
    'Y' => 80, 'YB' => 80, 'YIB' => 80,
};

use constant DTF => {
    DOW  => [qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/],
    DOWS => [qw/Sun Mon Tue Wed Thu Fri Sat/], # Short
    MOY  => [qw/January February March April May June July August September October November December/],
    MOYS => [qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/], # Short
};

# See Perl::OSType and Devel::CheckOS
my %OSTYPES = qw(
    aix         Unix
    bsdos       Unix
    beos        Unix
    bitrig      Unix
    dgux        Unix
    dragonfly   Unix
    dynixptx    Unix
    freebsd     Unix
    linux       Unix
    haiku       Unix
    hpux        Unix
    iphoneos    Unix
    irix        Unix
    darwin      Unix
    machten     Unix
    midnightbsd Unix
    minix       Unix
    mirbsd      Unix
    next        Unix
    openbsd     Unix
    netbsd      Unix
    dec_osf     Unix
    nto         Unix
    svr4        Unix
    svr5        Unix
    sco         Unix
    sco_sv      Unix
    unicos      Unix
    unicosmk    Unix
    solaris     Unix
    sunos       Unix
    cygwin      Unix
    msys        Unix
    os2         Unix
    interix     Unix
    gnu         Unix
    gnukfreebsd Unix
    nto         Unix
    qnx         Unix
    android     Unix

    dos         Windows
    MSWin32     Windows

    os390       EBCDIC
    os400       EBCDIC
    posix-bc    EBCDIC
    vmesa       EBCDIC

    MacOS       MacOS
    VMS         VMS
    vos         VOS
    riscos      RiscOS
    amigaos     Amiga
    mpeix       MPEiX
);


# Common
sub deprecated {
    local $Carp::CarpLevel = 1;
    $ENV{ACRUX_FATAL_DEPRECATIONS} ? croak @_ : carp @_;
}
sub dumper { Data::Dumper->new([@_])->Indent(1)->Sortkeys(1)->Terse(1)->Useqq(1)->Dump }
sub clone { dclone(shift) }
sub load_class {
    my $class = shift // '';
    return "Invalid class name: $class" unless $class =~ /^\w(?:[\w:]*\w)?$/;
    return undef if $class->can('new') || eval "require $class; 1"; # Ok
    return "Class $class not found" if $@ =~ /^Can't\s+locate/i; # Error
    return $@; # Error
}

# Bytes and numbers
sub fbytes {
    my $n = int(shift);
    if ($n >= 1024 ** 3) {
        return sprintf "%.3g GiB", $n / (1024 ** 3);
    } elsif ($n >= 1024 ** 2) {
        return sprintf "%.3g MiB", $n / (1024.0 * 1024);
    } elsif ($n >= 1024) {
        return sprintf "%.3g KiB", $n / 1024.0;
    } else {
        return "$n B"; # bytes
    }
}
sub human2bytes {
    my $h = shift || 0;
    return 0 unless $h;
    my ($bts, $sfx) = $h =~ /([0-9.]+)\s*([a-zA-Z]*)/;
    return 0 unless $bts;
    my $exp = HUMAN_SUFFIXES->{($sfx ? uc($sfx) : "B")} || 0;
    return ceil($bts * (2 ** $exp));
}
sub humanize_duration {
    my $msecs = shift || 0;
    my $secs = int($msecs);
    my $years = int($secs / (60*60*24*365));
       $secs -= $years * 60*60*24*365;
    my $days = int($secs / (60*60*24));
       $secs -= $days * 60*60*24;
    my $hours = int($secs / (60*60));
       $secs -= $hours * 60*60;
    my $mins = int($secs / 60);
       $secs %= 60;
    if ($years) { return sprintf("%d years %d days %s hours", $years, $days, $hours) }
    elsif ($days) { return sprintf("%d days %s hours %d minutes", $days, $hours, $mins) }
    elsif ($hours) { return sprintf("%d hours %d minutes %d seconds", $hours, $mins, $secs) }
    elsif ($mins >= 2) { return sprintf("%d minutes %d seconds", $mins, $secs) }
    elsif ($secs > 5) { return sprintf("%d seconds", $secs + $mins * 60) }
    elsif ($msecs - $secs) { return sprintf("%.4f seconds", $msecs) }
    return sprintf("%d seconds", $secs);
}
sub fduration {
    my $msecs = shift || 0;
    my $secs = int($msecs);
    my $hours = int($secs / (60*60));
       $secs -= $hours * 60*60;
    my $mins = int($secs / 60);
       $secs %= 60;
    if ($hours) {
        return sprintf("%d hours %d minutes", $hours, $mins);
    } elsif ($mins >= 2) {
        return sprintf("%d minutes", $mins);