File Coverage

blib/lib/MToken/Util.pm

Criterion	Covered	Total	%
statement	63	117	53.8
branch	9	32	28.1
condition	4	33	12.1
subroutine	17	34	50.0
pod	20	20	100.0
total	113	236	47.8

package MToken::Util; # $Id: Util.pm 92 2021-10-05 16:43:59Z minus $
use strict;
use utf8;

=encoding utf-8

=head1 NAME

MToken::Util - Exported utility functions

=head1 VERSION

Version 1.03

=head1 SYNOPSIS

    use MToken::Util;

=head1 DESCRIPTION

Exported utility functions

=over

=item B

    my $servername = cleanServerName( "my.server.com" );

Clening the specified ServerName value

=item B

    my $filename = cleanServerName( "mtoken.12345678" );

Clening the specified FileName value

=item B

    print explain( $object );

Returns Data::Dumper dump

=item B

    my $md5 = md5sum( $file );

See L

=item B

    my $sha1 = sha1sum( $file );

See L

=item B

    my $fsize = filesize( $file );

Returns file size

=item B

    print hide_pasword('http://user:[e-mail]'); # 'http://user:*****@example.com'

Returns specified URL but without password

=item B, B, B, B, B, B

    print cyan("Format %s", "text");

Returns colored string

=item B, B, B, B

    my $status = nope("Format %s", "text");

Prints status message and returns status.

For nope returns - 0; for skip, wow, yep - 1

=item B

    my ($user, $password) = parse_credentials( 'http://user:[e-mail]' );
    my ($user, $password) = parse_credentials( new URI('http://user:[e-mail]') );

Returns credentials pair by URL or URI object

=item B

    if (my $text = tcd_load("/my/file.tcd")) {
        print $text; # Blah-Blah-Blah
    } else {
        or die("Oops");
    }

Load text data from TCD04 file

=item B

    tcd_save("/my/file.tcd", "Blah-Blah-Blah") or die("Oops");

Save text data to TCD04 file

=back

=head1 HISTORY

See C file

=head1 TO DO

See C file

=head1 BUGS

* none noted

=head1 SEE ALSO

L, L

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L [e-mail]

=head1 COPYRIGHT

Copyright (C) 1998-2021 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 file and L

=cut

use vars qw/ $VERSION @EXPORT_OK @EXPORT /;
$VERSION = "1.03";

use Carp;
use CTK::Util qw/bload bsave/;
use CTK::Crypt::TCD04;
use URI;
use URI::Escape qw/uri_unescape/;
use Digest::MD5;
use Digest::SHA;
use Data::Dumper; #$Data::Dumper::Deparse = 1;
use Term::ANSIColor qw/colored/;

use MToken::Const qw/IS_TTY/;

use base qw/Exporter/;
@EXPORT = qw(
        yep nope skip wow
        blue green red yellow cyan magenta
    );
@EXPORT_OK = (qw(
        cleanServerName cleanFileName
        filesize md5sum sha1sum
        parse_credentials hide_pasword
		tcd_save tcd_load
        explain
    ), @EXPORT);

sub cleanServerName {
    my $sn = shift // 'localhost';
    $sn =~ s/[^a-z0-9_\-.]//ig;
    return $sn;
}
sub cleanFileName {
    my $f = shift // '';
    $f =~ s/[^a-z0-9_\-.]//ig;
    return $f;
}
sub sha1sum {
    my $f = shift;
    my $sha1 = Digest::SHA->new;
    my $sum = '';
    return $sum unless -e $f;
    open( my $sha1_fh, '<', $f) or (carp("Can't open '$f': $!") && return $sum);
    if ($sha1_fh) {
        binmode($sha1_fh);
        $sha1->addfile($sha1_fh);
        $sum = $sha1->hexdigest;
        close($sha1_fh);
    }
    return $sum;
}
sub md5sum {
    my $f = shift;
    my $md5 = Digest::MD5->new;
    my $sum = '';
    return $sum unless -e $f;
    open( my $md5_fh, '<', $f) or (carp("Can't open '$f': $!") && return $sum);
    if ($md5_fh) {
        binmode($md5_fh);
        $md5->addfile($md5_fh);
        $sum = $md5->hexdigest;
        close($md5_fh);
    }
    return $sum;
}
sub filesize {
    my $f = shift;
    my $filesize = 0;
    $filesize = (stat $f)[7] if -e $f;
    return $filesize;
}
sub parse_credentials {
    my $url = shift || return ();
    my $uri = (ref($url) eq 'URI') ? $url : URI->new($url);
    my $info = $uri->userinfo() // "";
    my $user = $info;
    my $pass = $info;
    $user =~ s/:.*//;
    $pass =~ s/^[^:]*://;
    return (uri_unescape($user // ''), uri_unescape($pass // ''));
}
sub hide_pasword {
    my $url = shift || return "";
	my $full = shift || 0;
	my $uri = URI->new($url);
	my ($u,$p) = parse_credentials($uri);
	return $url unless defined($p) && length($p);
	$uri->userinfo($full ? undef : sprintf("%s:*****", $u));
    return $uri->canonical->as_string;
}
sub tcd_save {
	my $fn = shift;
	my $text = shift // '';
	carp("No file specified") unless $fn;
	return unless length $text;
	bsave($fn, CTK::Crypt::TCD04->new()->encrypt($text))
		or carp("Can't save file \"$fn\"");
	return 1;
}
sub tcd_load {
	my $fn = shift;
	carp("No file specified") unless $fn;
	return unless -f $fn and -r _ and -s _;
	return CTK::Crypt::TCD04->new()->decrypt(bload($fn) // '');
}
sub explain {
    my $dumper = Data::Dumper->new( [shift] );
    $dumper->Indent(1)->Terse(1);
    $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
    return $dumper->Dump;
}

################
# Colored says
################
sub yep {
    print(green(sprintf(shift, @_)), "\n");
    return 1;
}
sub nope {
    print(red(sprintf(shift, @_)), "\n");
    return 0;
}
sub skip {
    print(yellow(sprintf(shift, @_)), "\n");
    return 1;
}
sub wow {
    print(blue(sprintf(shift, @_)), "\n");
    return 1;
}

# Colored helper functions
sub green {  IS_TTY ? colored(['bright_green'],  sprintf(shift, @_)) : sprintf(shift, @_) }
sub red {    IS_TTY ? colored(['bright_red'],    sprintf(shift, @_)) : sprintf(shift, @_) }
sub yellow { IS_TTY ? colored(['bright_yellow'], sprintf(shift, @_)) : sprintf(shift, @_) }
sub cyan {   IS_TTY ? colored(['bright_cyan'],   sprintf(shift, @_)) : sprintf(shift, @_) }
sub blue {   IS_TTY ? colored(['bright_blue'],   sprintf(shift, @_)) : sprintf(shift, @_) }
sub magenta {IS_TTY ? colored(['bright_magenta'],sprintf(shift, @_)) : sprintf(shift, @_) }

1;