view release on metacpan or  search on metacpan

lib/App/MBUtiny/Util.pm  view on Meta::CPAN

Resolv ip to a hostname or hostname to ip. See L<Sys::Net/"resolv">, L<Socket/"inet_ntoa">
and L<Socket/"inet_aton">

=item B<set2attr>

    my $hash = set2attr({set => ["AttrName Value"]}); # {"AttrName" => "Value"}

Converts attributes from the "set" format to regular hash

=item B<sha1sum>

    my $sha1 = sha1sum( $filename );

See L<Digest::SHA1>

=item B<xcopy>

    xcopy( $src_dir, $dst_dir, [ ... exclude rel. paths ... ] );

Exclusive copying all objects (files/directories) from $src_dir directory into $dst_dir
directory without specified relative paths. The function returns status of work

    xcopy( "/source/folder", "/destination/folder" )
        or die "Can't copy directory";

    # Copying without foo and bar/baz files/directories
    xcopy( "/source/folder", "/destination/folder", [qw( foo bar/baz )] )
        or die "Can't copy directory";

=back

=head1 HISTORY

See C<Changes> file

=head1 AUTHOR

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

=head1 COPYRIGHT

Copyright (C) 1998-2019 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 vars qw/ $VERSION @EXPORT_OK /;
$VERSION = '1.03';

our $DEBUG = 0;

use Carp;
use URI;
use URI::Escape qw/uri_unescape/;
use File::Find;
use File::Copy;
use Digest::MD5;
use Digest::SHA1;
use Socket qw/inet_ntoa inet_aton AF_INET/;
use Data::Dumper; #$Data::Dumper::Deparse = 1;
use CTK::ConfGenUtil;

use constant {
    DIRMODE => 0777,
};

use base qw/Exporter/;
@EXPORT_OK = qw/
        filesize sha1sum md5sum
        resolv
        explain
        xcopy
        node2anode set2attr
        parse_credentials hide_password
    /;

sub sha1sum {
    my $f = shift;
    my $sha1 = new Digest::SHA1;
    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 = new Digest::MD5;
    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 resolv { # Resolving. See Socket::inet_ntoa
    # Original: Sys::Net::resolv
    my $name = shift;
    # resolv ip to a hostname

lib/App/MBUtiny/Util.pm  view on Meta::CPAN

        } else {
            push @exf, $tf;
        }
    };

    if ($DEBUG) {
        printf("#F: %s\n", $_) for @exf;
        printf("#D: %s\n", $_) for @exd;
    }

    find({
        wanted => sub
            {
                my $f = File::Spec->canonpath($_);
                my $p = File::Spec->abs2rel( $f, $ob );
                if ((-e $f and -f $f) && (grep {$_ eq $f} @exf)) {
                    print ">F [SKIP] $f\n" if $DEBUG;
                    return 1;
                } elsif (@exd && grep {_td($_,$f)} @exd) {
                    print ">D [SKIP] $f\n" if $DEBUG;
                    return 1;
                } else {
                    if (-d $f) {
                        my $end = File::Spec->catdir($tg, $p);
                        print ">D        $f -> $end\n" if $DEBUG;
                        unless (-e $end) {
                            mkdir($end,DIRMODE) or carp(sprintf("Can't create directoy \"%s\": ", $end, $!)) && return;
                            chmod scalar((stat($f))[2]), $end;
                        }
                    } else {
                        my $end = File::Spec->catfile($tg, $p);
                        print ">F        $f -> $end\n" if $DEBUG;
                        unless (-e $end) {
                            copy($f,$end) or carp(sprintf("Copy failed \"%s\" -> \"%s\": %s", $f, $end, $!)) && return;
                            chmod scalar((stat($f))[2]), $end;
                        }
                    }
                }
            },
        no_chdir => 1,
        }, $ob,
    );

    print "\n" if $DEBUG;
    return 1;
}
sub node2anode {
    my $n = shift;
    return [] unless $n && ref($n) =~ /ARRAY|HASH/;
    return [$n] if ref($n) eq 'HASH';
    return $n;
}
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_password {
    my $url = shift || return "";
    my $full = shift || 0; # 0 - starts, 1 - no_credentials; 2 - user_only
    my $uri = new URI($url);
    my ($u,$p) = parse_credentials($uri);
    return $url unless defined($p) && length($p);
    $uri->userinfo($full ? ($full == 1 ? undef : $u) : sprintf("%s:*****", $u));
    return $uri->canonical->as_string;
}
sub set2attr {
    my $in = shift;
    my $attr = is_array($in) ? $in : array($in => "set");
    my %attrs;
    foreach (@$attr) {
        $attrs{$1} = $2 if $_ =~ /^\s*(\S+)\s+(.+)$/;
    }
    return {%attrs};
}

sub _td { # Test of base directory
    my $d = shift; # exclude directory
    my $o = shift; # test object

    my @t;
    my @sd;
    my $ret = 0;
    my ($volume,$dirs,$file) = File::Spec->splitpath( $o );
    return 0 unless $dirs;
    if (-f $o) {
        @sd = File::Spec->splitdir(File::Spec->catdir($volume, $dirs));
        #print join("#",@sd),"\n";
    } elsif (-d $o) {
        @sd = File::Spec->splitdir($o);
    } else {
        return 1; # undefined object - skipped!
    }
    for (@sd) {
        push @t, $_;
        if (File::Spec->catdir(@t) eq $d) {
            $ret = 1;
            last;
        }
    }
    return $ret;
}

1;