libcipux-perl 3.4.0.13-4 / usr / share / perl5 / CipUX / Compat.pm

package CipUX::Compat;

use strict;
use warnings;

#use Array::Unique;
use Carp;

#use Class::Std;
use Config::Any;
use Data::Dumper;
use Date::Manip;

#use Digest::MD5;
#use English qw( -no_match_vars);
#use File::Basename;
#use File::Glob;
use File::Path qw(make_path);
use Hash::Merge qw/merge/;
use Log::Log4perl qw(:easy);

#use Pod::Usage;
use Readonly;
use Storable qw(store retrieve freeze thaw dclone);
use Term::ReadKey;

#use Unicode::String;

use version; our $VERSION = qv('3.4.0.13');
use re 'taint';    # Keep data captured by parens tainted
delete @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};    # Make %ENV safe

Readonly::Scalar my $EMPTY_STRING => q{};
Readonly::Scalar my $DT => UnixDate( 'today', '%Y-%m-%dT%H:%M:%S' );
my $L = q{=================================================};
$L .= "$L\n";
Readonly::Scalar my $PASSWD_LENGTH_START => 1;
Readonly::Scalar my $PASSWD_LENGTH_END   => 9;
Readonly::Array my @PASSWD_CHARS =>
    ( 'A' .. 'Z', 'a' .. 'z', 0 .. 9, qw(! @ $ % &) );
Readonly::Array my @MODSALT_CHARS =>
    ( q{.}, q{/}, 0 .. 9, 'A' .. 'Z', 'a' .. 'z' );
Readonly::Scalar my $MODSALT_BASE => 64;
Readonly::Scalar my $STRICT_UMASK => oct 77;
Readonly::Scalar my $CACHE_DIR    => '/var/cache/cipux';

my %opt    = ();
my $str    = "%s ->  %s: %s\n";
my $exc_hr = {
    'UNKNOWN' => 'Unknown exception! Please fix CipUX!',
    '1010'    => sprintf( $str, 'a', 'b', 'c' ),
    '1015'    => 'value of "scope" in methode should be "all" or "one"!',
};

sub perr {

    my ( $s, $param, $oline ) = @_;

    if ( not defined $param ) {
        $param = 'UNKNOWN PARAMETER';
    }

    my (
        $package,   $filename, $line,       $subroutine, $hasargs,
        $wantarray, $evaltext, $is_require, $hints,      $bitmask
    ) = caller 1;

    my $msg = "perr called by [$subroutine] with undef parameter! \n";
    if ( not defined $param ) {
        $s->exc( { msg => $msg } );
    }

    $msg = "perr called by [$subroutine] with unknown parameter! \n";
    if ( $param eq 'UNKNOWN PARAMETER' ) {
        $s->exc( { msg => $msg } );
    }

    chomp $param;
    $msg = "Missing parameter [$param] in function [$subroutine]! \n";
    if ( defined $oline ) {
        $msg .= "You should look at line [$oline].\n";
    }

    $s->exc( { msg => $msg } );

    exit 1;

}

sub exc {

    my ( $s, $arg_r ) = @_;
    my $nr    = $arg_r->{nr}    || 'UNKNOWN';
    my $value = $arg_r->{value} || $EMPTY_STRING;
    my $msg   = $arg_r->{msg}   || $EMPTY_STRING;

    chomp $nr;
    chomp $value;

    my $txt
        = $nr  ne 'UNKNOWN'     ? $exc_hr->{$nr}
        : $msg ne $EMPTY_STRING ? $msg
        :                         'UNKNOWN';

    if ( $value ne $EMPTY_STRING ) {
        croak sprintf "%s (EXCEPTION) %s [%s]\n", $DT, $txt, $value;
    }
    else {
        croak sprintf "%s (EXCEPTION) %s\n", $DT, $txt;
    }

    return 1;

}

sub l {

    my ( $s, $o ) = @_;

    return if not defined $o;

    my $x = undef;

    {

        # untaint data captured by parens tainted
        no re 'taint';

        # if you change that, please also change
        # CipUX::CAT::Web sub cw_password

        # Allows: [ at the beginning (sambaAcctFlags)
        #         ] at the end (sambaAcctFlags)
        #         -:,_=/@.! and \w\s inbetween
        #         * inbetween for CipUX::Storage <212> p{*} LDAP filter
        #         % inbetween for message (%s)
        #         ' inbetween for quoting
        #         " inbetween for quoting
        #         () inbetween for function name quoting
        #         $ inbetween for Windows Machine Accounts
        #         & inbetween for passwords

        if ( $o =~ m{^(\[*[*-:,=_/\@\s\w.\$"!'\&\(%\)]+\]*)$}smx ) {
            $x = $1;    # data OK
        }
        elsif ( $o eq $EMPTY_STRING ) {
            $x = $EMPTY_STRING;
        }
        else {
            my $caller = caller;
            my $msg    = 'A bad letter/character was found inside';
            $msg .= " this input data [$o]. If you want to have";
            $msg .= ' support for this input data, please contact';
            $msg .= ' the mailing list cipux-devel' . q{@} . 'cipux.org';
            $msg .= " The Problem was found at: $caller\n";
            croak $msg;

        }
    }

    undef $o;

    return $x;

}

sub h {

    my ( $s, $h, $oline ) = @_;

    if ( not ref($h) eq 'HASH' ) {
        my (
            $package,   $filename, $line,       $subroutine, $hasargs,
            $wantarray, $evaltext, $is_require, $hints,      $bitmask
        ) = caller 1;
        my $type = ref $h;
        my $l = defined $h ? $s->l($h) : 'UNKNOWN HASH';

        my $msg = 'The argument is not a HASH or a reference to one. ';
        $msg .= "h() called by [$subroutine] with wrong argument! ";
        if ( defined $oline ) {
            $msg .= "You should have a look at line [$oline] ...";
        }
        $s->exc( { msg => $msg, value => $l } );
        exit 1;
    } ## end else [ if ( ref($h) eq 'HASH')

    return $h;

}

# common function for checking CLI logic
# used by cipux_task_client
# used by cipux_object_client
# used by cipux_ldap_client
sub test_cli_option {

    my ( $s, $arg_r ) = @_;

    my $script
        = exists $arg_r->{script}
        ? $s->l( $arg_r->{script} )
        : 'UNKONW SCRIPT';

    my $opt_hr
        = exists $arg_r->{opt_hr}
        ? $s->h( $arg_r->{opt_hr} )
        : $s->perr('opt_hr');

    my $logic_hr
        = exists $arg_r->{logic_hr}
        ? $s->h( $arg_r->{logic_hr} )
        : $s->perr('logic_hr');

    my $logger = get_logger('CipUX');

    $logger->debug( '> script: ', $script );
    if ( defined $opt_hr ) {
        $logger->debug( '> opt_hr: ',
            { filter => \&Dumper, value => $opt_hr } );
    }
    if ( defined $logic_hr ) {
        $logger->debug( '> logic_hr: ',
            { filter => \&Dumper, value => $logic_hr } );
    }

    # test the given CLI options
    foreach my $s ( sort keys %{$logic_hr} ) {

        # we test only the actual running script
        next if $script ne $s;
        $logger->debug( 'will test: ', $s );

        foreach my $line ( @{ $logic_hr->{$s}->{must} } ) {
            $logger->debug( 'line: ', $line );

            my @s = split /=/smx, $line;
            my $croak_msg = '[' . join( '] or [', @s ) . ']';
            my $must_have = 0;

            foreach my $m (@s) {
                $logger->debug( 'must have option: ', $m );

                if ( exists $opt_hr->{$m} ) {
                    $logger->debug('      OK (exists), ');
                }
                if ( defined $opt_hr->{$m} ) {
                    $logger->debug(' (defined),');
                }
                if ( exists $opt_hr->{$m} ) {
                    $logger->debug( ' value: ', $opt_hr->{$m} );
                }
                $logger->debug("\n");
                if ( exists $opt_hr->{$m} ) {
                    $must_have = 1;
                }
            } ## end foreach my $m (@s)
            if ( not $must_have ) {

                my $msg = "$L EXCEPTION: mandatory";
                $msg .= " parameter $croak_msg missing!\n$L";
                pod2usage(
                    -verbose => 0,
                    -msg     => $msg
                );
                croak $msg;
            } ## end if ( not $must_have )
        } ## end foreach my $line ( @{ $logic_hr...
        foreach my $n ( @{ $logic_hr->{$s}->{not} } ) {
            $logger->debug( 'must not have option: ', $n );

            if ( exists $opt_hr->{$n} ) {
                my $msg
                    = "\n$L EXCEPTION: you should not provide option [$n]!\n$L";
                pod2usage(
                    -verbose => 0,
                    -msg     => $msg
                );
                croak $msg;
            }
            else {
                my $msg = 'OK (we do not have option): ';
                if ( defined $n ) {
                    $logger->debug( $msg, $n );
                }
                else {
                    $logger->debug( $msg, 'empty array ref' );
                }
            } ## end else [ if ( exists $opt_hr->{...
        } ## end foreach my $n ( @{ $logic_hr...
    } ## end foreach my $s ( sort keys %...

    return;

}

sub login_prompt {

    my ( $s, $arg_r ) = @_;
    my $prompt = $s->l( $arg_r->{prompt} ) || 'Login: ';

    ReadMode('normal');
    print $prompt or croak "Can not print prompt to STDOUT\n";
    my $login = ReadLine 0;
    chomp $login;
    ReadMode('normal');

    return $login;
}

sub password_prompt {

    my ( $s, $arg_r ) = @_;
    my $prompt = $s->l( $arg_r->{prompt} ) || 'Password: ';

    ReadMode('noecho');
    print $prompt or croak "Can not print promt to STDOUT\n";
    my $password = ReadLine 0;
    chomp $password;
    print "\n" or croak "Can not print CR to STDOUT\n";
    ReadMode('normal');

    return $password;

}

sub random_password {

    my @chars = @PASSWD_CHARS;
    my $password = join $EMPTY_STRING, @chars[ map { rand @chars }
        ( $PASSWD_LENGTH_START .. $PASSWD_LENGTH_END ) ];

    return $password;
}

sub out {

    my $s   = shift;
    my $msg = shift;

    print $msg or croak 'Can not print to STDOUT!';

    return;
}

sub _merge_array {

    my $a_ar = shift;
    my $b_ar = shift;

    tie my @u, 'Array::Unique';    ## no critic (Miscellanea::ProhibitTies)
    @u = ( @{$b_ar}, @{$a_ar} );

    undef $b_ar;
    undef $a_ar;

    return \@u;

}

sub _hash_merge_setup {
    Hash::Merge::specify_behavior(
        {
            'SCALAR' => {
                'SCALAR' => sub { $_[1] },
                'ARRAY'  => sub { [ $_[0], @{ $_[1] } ] },
                'HASH'   => sub { $_[1] },
            },
            'ARRAY' => {
                'SCALAR' => sub { $_[1] },

                # default:
                # 'ARRAY'  => sub { [ @{ $_[0] }, @{ $_[1] } ] },
                'ARRAY' => sub { _merge_array( $_[0], $_[1] ) },
                'HASH'  => sub { $_[1] },
            },
            'HASH' => {
                'SCALAR' => sub { $_[1] },
                'ARRAY'  => sub { [ values %{ $_[0] }, @{ $_[1] } ] },
                ## no critic (Subroutines::ProtectPrivateSubs)
                'HASH' => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
            },
        },
        'ARRAY_SPLICE',
    );
    return;
}

sub cng_ext {

    my ( $s, $arg_r ) = @_;

    # OK: .cnf .json .jsn .xml .yml .yaml .ini .pl .perl ...
    # BAD: .conf
    #my @extension = grep { !m/conf/smx } @{ Config::Any->extensions };
    my @extension = qw(ini perl);    # reduced to used .ini and .perl

    return @extension;
}

sub cfg {

    my ( $s, $arg_r ) = @_;

    my $pkg = exists $arg_r->{pkg} ? $arg_r->{pkg} : 'cipux';
    my $sub = exists $arg_r->{sub} ? $arg_r->{sub} : $EMPTY_STRING;
    my $cfg = exists $arg_r->{cfg} ? $arg_r->{cfg} : undef;    # only one cfg
    my $cache_dir
        = (     exists $arg_r->{cache_dir}
            and defined $arg_r->{cache_dir}
            and $arg_r->{cache_dir} ne $EMPTY_STRING )
        ? $s->l( $arg_r->{cache_dir} )
        : $CACHE_DIR;

    my $logger = get_logger(__PACKAGE__);
    $logger->debug("pkg [$pkg]");
    $logger->debug("sub [$sub]");

    my $cfgbase
        = (     defined $pkg
            and $pkg
            and defined $sub
            and $sub
            and $sub ne $EMPTY_STRING )
        ? "$pkg-$sub"
        : $pkg;

    $s->create_cache_dir_if_not_present( { cache_dir => $cache_dir } );

    # determine cfg space quantity
    my $loadcfg_ar = $s->iterate_config_space(
        {
            cfg     => $cfg,
            cfgbase => $cfgbase,
        }
    );
    $logger->debug( 'loadcfg_ar: ',
        { filter => \&Dumper, value => $loadcfg_ar } );

    # determine cfg space quality
    my $clean = $s->evaluate_config_space(
        {
            loadcfg_ar => $loadcfg_ar,
            cache_dir  => $cache_dir,
            cfgbase    => $cfgbase,
        }
    );

    if ( -e "$cache_dir/$cfgbase.cache" and $clean and not defined $cfg ) {
        $logger->debug("use disk: $cache_dir/$cfgbase.cache");
        my $cfg_hr = retrieve("$cache_dir/$cfgbase.cache")
            or croak
            "Can not load $cfgbase.cache in $cache_dir/$cfgbase.cache";
        return $cfg_hr;
    }

    $logger->debug("use Config::Any $cfgbase");

    my @loadcfg = @{$loadcfg_ar};
    my $cfg_hr  = Config::Any->load_files(
        {
            files           => \@loadcfg,
            use_ext         => 1,
            override        => 1,
            flatten_to_hash => 1
        }
    );

    #$logger->debug( 'cfg_hr: ',
    #    { filter => \&Dumper, value => $cfg_hr } );

    $s->_hash_merge_setup();

    #Hash::Merge::set_behavior( 'ARRAY_SPLICE' );

    my $merged_hr = {};
    foreach my $filename (@loadcfg) {
        $merged_hr = merge( $merged_hr, $cfg_hr->{$filename} );
    }

    store( $merged_hr, "$cache_dir/$cfgbase.cache" )
        or croak "Can not save $cfgbase in $cache_dir/$cfgbase";

    return $merged_hr;

}

sub create_cache_dir_if_not_present {

    my ( $s, $arg_r ) = @_;

    my $cache_dir
        = (     exists $arg_r->{cache_dir}
            and defined $arg_r->{cache_dir}
            and $arg_r->{cache_dir} ne $EMPTY_STRING )
        ? $s->l( $arg_r->{cache_dir} )
        : $CACHE_DIR;

    if ( not -d $cache_dir ) {

        # mkdir $cache_dir
        # or croak "Can not crate $cache_dir $!";
        my $umask = umask;
        umask $STRICT_UMASK;
        make_path( $cache_dir, { error => \my $err } );
        umask $umask;
        if ( scalar @{$err} ) {
            for my $diag ( @{$err} ) {
                my ( $file, $message ) = %{$diag};
                if ( $file eq $EMPTY_STRING ) {
                    warn "general error: $message\n";
                }
                else {
                    warn "problem createing $file: $message\n";
                }
            }
        }

        # chown 0, 0, $cache_dir
        #   or croak 'Can not chown 0,0,$cache_dir';
        # chmod 0700, $cache_dir
        #  or croak 'Can not chmod 0700,$cache_dir';
    }

    return;

}

sub iterate_config_space {

    my ( $s, $arg_r ) = @_;
    my $cfg
        = ( exists $arg_r->{cfg} )
        ? $s->l( $arg_r->{cfg} )
        : $s->perr('cfg');
    my $cfgbase
        = ( exists $arg_r->{cfgbase} )
        ? $s->l( $arg_r->{cfgbase} )
        : $s->perr('cfgbase');

    my $l         = get_logger(__PACKAGE__);
    my @extension = qw(ini perl);
    my @suffix    = ();
    my @cfg_space = ();

    if ( defined $cfg ) {
        @cfg_space = ($cfg);
        $l->debug("add to config space [$cfg]");
    }
    else {
        @suffix = (
            "/usr/share/cipux/etc/$cfgbase.",
            "/usr/share/cipux/etc/$cfgbase.d/*.",
            "/etc/cipux/$cfgbase.",
            "/etc/cipux/$cfgbase.d/*.",
            "~/.cipux/$cfgbase.",
        );

        foreach my $s (@suffix) {
            foreach my $e (@extension) {
                $l->debug("add to config space [$s$e]");
                push @cfg_space, $s . $e;
            }
        }
    }
    my @filename = ();
    foreach my $g (@cfg_space) {
        $l->debug("glob [$g]");
        my @f = sort glob $g;
        push @filename, @f;
    }

    my @loadcfg = ();
    foreach my $f (@filename) {
        $f = $s->l($f);
        if ( -e $f ) {
            $l->debug("add file [$f] to cfg space");
            push @loadcfg, $f;
        }
    }
    return \@loadcfg;
}

sub evaluate_config_space {

    my ( $s, $arg_r ) = @_;
    my $loadcfg_ar
        = ( exists $arg_r->{loadcfg_ar} )
        ? $arg_r->{loadcfg_ar}
        : $s->perr('loadcfg_ar');
    my $cache_dir
        = ( exists $arg_r->{cache_dir} )
        ? $s->l( $arg_r->{cache_dir} )
        : $s->perr('cache_dir');
    my $cfgbase
        = ( exists $arg_r->{cfgbase} )
        ? $s->l( $arg_r->{cfgbase} )
        : $s->perr('cfgbase');
    my $l = get_logger(__PACKAGE__);

    my $eval_dir = "$cache_dir/$cfgbase";
    $s->create_cache_dir_if_not_present( { cache_dir => $eval_dir } );

    my $dirty   = 0;
    my %ndigest = ();
    my %odigest = ();
    foreach my $f ( @{$loadcfg_ar} ) {

        #  /etc/cipux/cipux-cat-web.ini
        $l->debug("evaluate cfg file [$f]");

        # calc md5 of cfg file
        open my $RF1, q{<}, $f or croak "Can not open $f for reading!";
        binmode $RF1;
        $ndigest{$f} = Digest::MD5->new->addfile($RF1)->hexdigest;
        close $RF1 or croak "Unable to close $!";

        #|  cache_dir  |cfgbase|name
        #/var/cache/cipux/cipux/3c9f65e4f1c5d05638f63da289e78eb3
        my $fn = "$eval_dir/$ndigest{$f}";
        $l->debug("evaluate md5 file [$fn]");

        if ( -e $fn ) {

            # clean
            $l->debug("[$f] found to be clean");
        }
        else {
            $l->debug("[$f] found to be dirty");
            $dirty = 1;

            # overwrite with clean version
            open my $WF, q{>}, $fn
                or croak "Can not open $fn for writing!";
            print {$WF} $ndigest{$f}
                or croak "print to [$fn] failed $1";
            close $WF or croak "Unable to close $!";
        }

    }

    return not $dirty;
}

1;