File: CipUX.pm

package info (click to toggle)
cipux 3.4.0.11-1
links: PTS, VCS
area: main
in suites: squeeze
size: 316 kB
ctags: 59
sloc: perl: 1,064; makefile: 13
file content (1713 lines) | stat: -rw-r--r-- 53,240 bytes
# +==========================================================================+
# || CipUX                                                                  ||
# ||                                                                        ||
# || Common CipUX functions                                                 ||
# ||                                                                        ||
# || Copyright (C) 2007 - 2009 by Christian Kuelker                         ||
# ||                                                                        ||
# || License: GNU GPL version 2 or any later version.                       ||
# ||                                                                        ||
# +==========================================================================+
# ID:       $Id$
# Revision: $Revision$
# Head URL: $HeadURL$
# Date:     $Date$
# Source:   $Source$

package CipUX;

use strict;
use warnings;
use utf8;
use 5.008001;
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;

{    # BEGIN CLASS

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

    # +======================================================================+
    # || CONST                                                              ||
    # +======================================================================+
    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 $CFGBASE             => 'cipux';
    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 $LINEWIDTH    => 78;
    Readonly::Scalar my $STRICT_UMASK => oct 77;
    Readonly::Scalar my $CACHE_DIR    => '/var/cache/cipux';

    # +======================================================================+
    # || GLOBAL                                                             ||
    # +======================================================================+
    ## no critic (ProhibitPackageVars)
    use vars qw($config_hr0 $config_hr1 $config_hr2);

    ## use critic
    my %mattrvalue = ();
    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"!',
    };

    # +======================================================================+
    # || open module features                                               ||
    # +======================================================================+

    # +======================================================================+
    # || linewidth                                                          ||
    # +======================================================================+

    sub get_linewidth {

        # +------------------------------------------------------------------+
        # | API
        return $LINEWIDTH;

    } ## end sub get_linewidth

    # +======================================================================+
    # || perr                                                               ||
    # +======================================================================+
    sub perr {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $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 ) {
            $self->exc( { msg => $msg } );
        }

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

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

        # TODO think about: (AdcMon!)
        # $self->exc( { msg => $msg } ) if $param <> 0;
        $self->exc( { msg => $msg } );

        # +------------------------------------------------------------------+
        # | API
        exit 1;

    } ## end sub perr

    # +======================================================================+
    # || exc                                                                ||
    # +======================================================================+
    sub exc {

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

        # +------------------------------------------------------------------+
        # | main
        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;
        }

        # +------------------------------------------------------------------+
        # | API
        return 1;

    } ## end sub exc

    # +======================================================================+
    # || config                                                             ||
    # +======================================================================+
    # OLD config space, will be dropped in 3.4.2.x
    sub config {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;
        my $config_ar
            = exists $arg_r->{config_ar}
            ? $self->a( $arg_r->{config_ar} )
            : $self->perr('config_ar');

        # +------------------------------------------------------------------+
        # | prepare
        my $logger = get_logger('CipUX');

        my $config;

        # +------------------------------------------------------------------+
        # | main
        foreach my $cfg ( @{$config_ar} ) {
            $config = $cfg;
            last if -e $cfg;
        }
        my ( $cfg0_hr, $cfg1_hr, $cfg2_hr );

        # source conf file
        if ( $config and -e $config ) {
            ( $cfg0_hr, $cfg1_hr, $cfg2_hr )
                = $self->source( { cfg => $config } );
        }
        else {
            my $msg = 'Did not find any configuration file. ';
            $msg .= 'Last attempt was:';
            $self->exc( { msg => $msg, value => $config } );
        }

        my $msg = 'Variable not defined in configuration file. ';
        $msg .= 'Please provide a valid configuration file.';
        if ( not defined $cfg0_hr ) {
            $self->exc( { msg => $msg, value => 'config_hr0' } );
        }
        if ( not defined $cfg1_hr ) {
            $self->exc( { msg => $msg, value => 'config_hr1' } );
        }
        if ( not defined $cfg1_hr ) {
            $self->exc( { msg => $msg, value => 'config_hr1' } );
        }

        # +------------------------------------------------------------------+
        # | API
        return ( $cfg0_hr, $cfg1_hr, $cfg2_hr );

    } ## end sub config

    # +======================================================================+
    # || source                                                             ||
    # +======================================================================+
    # OLD config space, will be dropped in 3.4.2.x
    sub source {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;
        my $cfg = $self->l( $arg_r->{cfg} );

        # +------------------------------------------------------------------+
        # | main
        my $logger = get_logger('CipUX');

        $logger->debug( 'use configuration file: ', $cfg );

        #$cfg = './' . $cfg if not $cfg =~ m%^/%;
        my ( $file, $dir ) = fileparse($cfg);
        $logger->debug( 'file: ', $file );
        $logger->debug( 'dir: ',  $dir );

        # test if file is readable
        if ( not -r $cfg ) {
            $logger->debug( '-> file not readable!: ', $cfg );
            $self->exc( { msg => '-> file not readable!', value => $cfg } );
        }

        my $msg = "While processing conf. [$cfg], the file can not be";
        if ( -e $cfg ) {
            if ( not my $r = do $cfg ) {    # $r = return
                if ($EVAL_ERROR) {
                    pod2usage( -msg => "$msg parsed! $@" );
                }
                if ( not defined $r ) {
                    pod2usage( -msg => "$msg sourced! $!" );
                }
                if ( not $r ) {
                    pod2usage( -msg => "$msg executed! $cfg" );
                }
            } ## end if ( not my $r = do $cfg)
        } ## end if ( -e $cfg )

        # +------------------------------------------------------------------+
        # | API
        return $config_hr0, $config_hr1, $config_hr2;

    } ## end sub source

    # +======================================================================+
    # ||store_mattrvalue                                                    ||
    # +======================================================================+
    sub store_mattrvalue {    ## no critic (ProhibitManyArgs)

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $attr_hr, $opt_hr, $option, $key, $value ) = @_;

        return if not defined $option;

        my $logger = get_logger('CipUX');
        $logger->debug( '> attr_hr: ',
            { filter => \&Dumper, value => $attr_hr } );
        $logger->debug( '> opt_hr : ',
            { filter => \&Dumper, value => $opt_hr } );
        $logger->debug( '> option : ', $option );
        $logger->debug( '> key    : ', $key );
        $logger->debug( '> value  : ', $value );

        my $opt = $self->l($option);

        if (    ( $opt eq 'x' or $opt eq 'mattrvalue' )
            and ( defined $key and defined $value ) )
        {

            my $attr = $self->l($key);
            my $obj  = $self->l($value);
            $logger->debug( 'attr: ', $attr );
            $logger->debug( 'obj: ',  $obj );

            # store in $attr_hr
            push @{ $attr_hr->{$attr} }, $obj;
            $opt_hr->{x}          = 1;
            $opt_hr->{mattrvalue} = 1;

            $logger->debug('end 1');

            return $attr_hr;
        } ## end if ( ( $opt eq 'x' or ...

        $logger->debug('end 2');

        return;

    } ## end sub store_mattrvalue

    # +======================================================================+
    # ||store_attrvalue                                                    ||
    # +======================================================================+
    sub store_attrvalue {    ## no critic (ProhibitManyArgs)

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $attr_hr, $opt_hr, $option, $key, $value ) = @_;

        return if not defined $option;

        my $logger = get_logger('CipUX');
        $logger->debug( '> attr_hr: ',
            { filter => \&Dumper, value => $attr_hr } );
        $logger->debug( '> opt_hr : ',
            { filter => \&Dumper, value => $opt_hr } );
        $logger->debug( '> option : ', $option );
        $logger->debug( '> key    : ', $key );
        $logger->debug( '> value  : ', $value );

        my $opt = $self->l($option);

        if ( ( $opt eq 'y' or $opt eq 'attrvalue' ) and defined $key ) {

            my $attr = $self->l($key);
            my $obj = defined $value ? $self->l($value) : undef;

            $logger->debug( 'attr: ', $attr );
            if ( defined $obj ) {
                $logger->debug( 'obj: ', $obj );
            }

            # store in $attr_hr
            push @{ $attr_hr->{$attr} }, $obj;
            $opt_hr->{y}         = 1;
            $opt_hr->{attrvalue} = 1;

            $logger->debug('end 1');

            return $attr_hr;
        } ## end if ( ( $opt eq 'y' or ...

        $logger->debug('end 2');

        return;

    } ## end sub store_attrvalue

    # +======================================================================+
    # || homedir                                                            ||
    # +======================================================================+
    sub homedir {

        # +------------------------------------------------------------------+
        # | API
        my $self     = shift;
        my $filename = shift;

        $filename =~ s{ ^ ~ ( [^/]* ) }
                  { $1
                            ? (getpwnam($1))[7]
                            : ( $ENV{HOME} || $ENV{LOGDIR}
                                           || (getpwuid($>))[7]
                              )
                  }exms;

        # +------------------------------------------------------------------+
        # | API
        return $filename;

    } ## end sub homedir

    # +======================================================================+
    # || lf                                                                 ||
    # +======================================================================+
    # laundering LDAP filter
    sub lf {

        # +------------------------------------------------------------------+
        # | API
        # example: &(cn=?)(objectClass=cipuxCatModule)
        my ( $self, $o ) = @_;
        return if not defined $o;

        my $x = undef;

        {

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

            if ( $o =~ m{^([=-\?\(\)&\w.]+)$}smx ) {
                $x = $1;    # data OK
            }
            elsif ( $o eq $EMPTY_STRING ) {
                $x = $EMPTY_STRING;
            }
            else {
                my $caller = caller;
                croak "Bad LDAP filter data [$o] at '$caller'\n";
            }
        }

        undef $o;

        # +------------------------------------------------------------------+
        # | API
        return $x;

    } ## end sub lf

    # laundering passwords
    sub lp {

        # +------------------------------------------------------------------+
        # | API
        # example: &(cn=?)(objectClass=cipuxCatModule)
        my ( $self, $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
            #if ( $l =~ m{^([a-z0-9A-Z!#$%&=-_\@+*]+)$}smx ) {
            if ( $o =~ m{^([[:alnum:]!#$%&=-_\@+*]+)$}smx ) {
                $x = $1;    # data OK
            }
            elsif ( $o eq $EMPTY_STRING ) {
                $x = $EMPTY_STRING;
            }
            else {
                my $caller = caller;
                croak "Bad password data [$o] at '$caller'\n";
            }
        }

        undef $o;

        # +------------------------------------------------------------------+
        # | API
        return $x;

    } ## end sub lp

    # laundering integer
    sub li {

        # +------------------------------------------------------------------+
        # | API
        # example: &(cn=?)(objectClass=cipuxCatModule)
        my ( $self, $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
            if ( $o =~ m{^(\d+)$}smx ) {
                $x = $1;    # data OK
            }
            elsif ( $o eq $EMPTY_STRING ) {
                $x = $EMPTY_STRING;
            }
            else {
                my $caller = caller;
                croak "Bad integer data [$o] at '$caller'\n";
            }
        }

        undef $o;

        # +------------------------------------------------------------------+
        # | API
        return $x;

    } ## end sub li

    # normal data
    sub l {

        # +------------------------------------------------------------------+
        # | API

        #my ( $self, $arg_r ) = @_;
        my ( $self, $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;

        # +------------------------------------------------------------------+
        # | API
        return $x;

    } ## end sub l

    # +======================================================================+
    # || h                                                                  ||
    # +======================================================================+
    sub h {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $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 ? $self->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] ...";
            }
            $self->exc( { msg => $msg, value => $l } );
            exit 1;
        } ## end else [ if ( ref($h) eq 'HASH')

        # +------------------------------------------------------------------+
        # | API
        return $h;

    } ## end sub h

    # +======================================================================+
    # || a                                                                  ||
    # +======================================================================+
    sub a {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $o, $oline ) = @_;

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

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

        # +------------------------------------------------------------------+
        # | API
        return $o;

    } ## end sub a

    # +======================================================================+
    # || test_cli_option                                                    ||
    # +======================================================================+

    # 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 {

        # +------------------------------------------------------------------+
        # | API

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

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

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

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

        # +------------------------------------------------------------------+
        # | main
        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 %...

        # +------------------------------------------------------------------+
        # | API
        return;

    } ## end sub test_cli_option

    # +======================================================================+
    # || date_time                                                          ||
    # +======================================================================+
    sub date_time {

        # +------------------------------------------------------------------+
        # | API

        my ( $self, $arg_r ) = @_;
        my $today = $arg_r->{today} || 0;

        my $return = $EMPTY_STRING;

        if ($today) {
            $return = UnixDate( 'today', '%Y-%m-%dT%H:%M:%S' );
        }

        # +------------------------------------------------------------------+
        # | API
        return $return;

    } ## end sub date_time

    # +======================================================================+
    # || date_epoch                                                          ||
    # +======================================================================+
    sub date_epoch {

        # +------------------------------------------------------------------+
        # | API

        my ( $self, $arg_r ) = @_;
        my $today = $arg_r->{today} || 0;

        my $return = $EMPTY_STRING;

        if ($today eq '1') {
            $return = UnixDate( 'today', '%s' );
        }elsif($today){
            $return = UnixDate( ParseDate($today), '%s' );
        }
        # +------------------------------------------------------------------+
        # | API
        return $return;

    } ## end sub date_epoch

    # +======================================================================+
    # || latin1_to_utf8                                                     ||
    # +======================================================================+
    sub latin1_to_utf8 {

        # +------------------------------------------------------------------+
        # | API

        my ( $self, $arg_r ) = @_;
        my $latin1 = $arg_r->{latin1} || $EMPTY_STRING;

        # utf8 already is the default
        Unicode::String->stringify_as('utf8');
        my $utf8 = Unicode::String::latin1($latin1);

        # +------------------------------------------------------------------+
        # | API
        return $utf8;
    } ## end sub latin1_to_utf8

    # +======================================================================+
    # || login_prompt                                                       ||
    # +======================================================================+
    sub login_prompt {

        # +------------------------------------------------------------------+
        # | API

        my ( $self, $arg_r ) = @_;
        my $prompt = $self->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');

        # +------------------------------------------------------------------+
        # | API
        return $login;
    } ## end sub login_prompt

    # +======================================================================+
    # || password_prompt                                                    ||
    # +======================================================================+
    sub password_prompt {

        # +------------------------------------------------------------------+
        # | API

        my ( $self, $arg_r ) = @_;
        my $prompt = $self->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');

        # +------------------------------------------------------------------+
        # | API
        return $password;

    } ## end sub password_prompt

    # +======================================================================+
    # || random_password                                                    ||
    # +======================================================================+
    sub random_password {

        # +------------------------------------------------------------------+
        # | API
        # see cookbook, de <55>
        my @chars = @PASSWD_CHARS;
        my $password = join $EMPTY_STRING, @chars[ map { rand @chars }
            ( $PASSWD_LENGTH_START .. $PASSWD_LENGTH_END ) ];

        # +------------------------------------------------------------------+
        # | API
        return $password;

    } ## end sub random_password

    # +======================================================================+
    # || hash_password                                                      ||
    # +======================================================================+
    sub hash_password {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $arg_r ) = @_;
        my $password = $self->l( $arg_r->{password} )
            || $self->perr('password');
        my $mode = $self->l( $arg_r->{mode} ) || $self->perr('mode');

        my $l = get_logger(__PACKAGE__);
        if ( $mode eq 'crypt' ) {
            $l->debug("crypt|md5 mode eq [$mode]");
            my $modsalt = join $EMPTY_STRING,
                @MODSALT_CHARS[ rand $MODSALT_BASE, rand $MODSALT_BASE ];
            $l->debug("modsalt  [$modsalt]");

            $password = crypt $password, $modsalt;
            $l->debug("password [$password]");

        }
        elsif ( $mode eq 'md5' ) {

            use Digest::MD5 qw(md5);
            my $ctx = Digest::MD5->new;
            $ctx->add($password);
            $password = encode_base64( '{MD5}' . $ctx->b64digest );
            $l->debug("password [$password]");

            #$self->exc( { msg => 'not supported', value => $mode } );

        }
        else {
            $self->exc(
                { msg => 'unknown password hash mode', value => $mode } );
        }

        # +------------------------------------------------------------------+
        # | API
        return $password;    # without prefix like {crypt}

    } ## end sub hash_password

    # +======================================================================+
    # || min                                                                ||
    # +======================================================================+
    sub min {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $x, $y ) = @_;

        if ( defined $x and defined $y ) {
            return $x < $y ? $x : $y;
        }
        else {

            return $x if defined $x;
            return $y if defined $y;

        } ## end else [ if ( defined $x and defined...

        # +------------------------------------------------------------------+
        # | API
        return;

    } ## end sub min

    # +======================================================================+
    # || max                                                                ||
    # +======================================================================+
    sub max {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $x, $y ) = @_;

        if ( defined $x and defined $y ) {
            return $x > $y ? $x : $y;
        }
        else {

            return $x if defined $x;
            return $y if defined $y;

        }

        # +------------------------------------------------------------------+
        # | API
        return;

    } ## end sub max

    sub out {

        # +------------------------------------------------------------------+
        # | API
        my $self = shift;
        my $msg  = shift;

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

        # +------------------------------------------------------------------+
        # | API
        return;
    }

    sub _merge_array : PRIVATE {

        # +------------------------------------------------------------------+
        # | API
        my $a_ar = shift;
        my $b_ar = shift;

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

        undef $b_ar;
        undef $a_ar;

        # +------------------------------------------------------------------+
        # | API
        return \@u;

    }

    # +======================================================================+
    # || _hash_merge_setup                                                  ||
    # +======================================================================+
    sub _hash_merge_setup {

        # +------------------------------------------------------------------+
        # | main

        # derived from:
        #Hash::Merge::set_behavior('RIGHT_PRECEDENT');

        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',
        );

        # +------------------------------------------------------------------+
        # | API
        return;

    }

    # +======================================================================+
    # || cfg_ext                                                            ||
    # +======================================================================+
    sub cfg_ext {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $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

        # +------------------------------------------------------------------+
        # | API
        return @extension;
    }

    # +======================================================================+
    # || cfg                                                                ||
    # +======================================================================+
    # NEW config space, will be used after 3.4.0.0
    sub cfg {

        # +------------------------------------------------------------------+
        # | API
        my ( $self, $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 )
            ? $self->l( $arg_r->{cache_dir} )
            : $CACHE_DIR;

        # +------------------------------------------------------------------+
        # | prepare
        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;

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

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

        # determine cfg space quality
        my $clean = $self->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");

        # +------------------------------------------------------------------+
        # | main
        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 } );

        $self->_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";

        # +------------------------------------------------------------------+
        # | API
        return $merged_hr;

    }

    sub create_cache_dir_if_not_present {

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

        my $cache_dir
            = (     exists $arg_r->{cache_dir}
                and defined $arg_r->{cache_dir}
                and $arg_r->{cache_dir} ne $EMPTY_STRING )
            ? $self->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 ( $self, $arg_r ) = @_;
        my $cfg
            = ( exists $arg_r->{cfg} )
            ? $self->l( $arg_r->{cfg} )
            : $self->perr('cfg');
        my $cfgbase
            = ( exists $arg_r->{cfgbase} )
            ? $self->l( $arg_r->{cfgbase} )
            : $self->perr('cfgbase');

        my $l         = get_logger(__PACKAGE__);
        my @extension = $self->cfg_ext();
        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 = $self->l($f);
            if ( -e $f ) {
                $l->debug("add file [$f] to cfg space");
                push @loadcfg, $f;
            }
        }
        return \@loadcfg;
    }

    sub evaluate_config_space {

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

        my $eval_dir = "$cache_dir/$cfgbase";
        $self->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;
    }

}    # END INSIDE-OUT CLASS

1;

__END__


=pod

=for stopwords CipUX Kuelker perr VARNAME API exc STDERR config getopt homedir lf LDAP lp li latin UTF UTF-8 login STDOUT TODO cfg

=head1 NAME

CipUX - Common CipUX functions

=head1 VERSION

version 3.4.0.11

=head1 SYNOPSIS

  use CipUX;

  my $cipux = $CipUX->new();

  my $max = $cipux->max(5,6);

Or use as base class:

  use base(CipUX);

  my $max = $self->max(5,6);


=head1 DESCRIPTION

Provides functions common to all CipUX classes and scripts.

=head1 CONSTRUCTOR

=head2 new

Constructor

  my $cipux = CipUX->new();

=head1 SUBROUTINES/METHODS

The following functions will be exported by CipUX.

=head2 get_linewidth

Returns the CipUX line width.

=head2 perr

Prints an exception that variable name VARNAME was not
used in subroutine API. This is used to discover internal
programming errors.

  $cipux->perr('<NAME OF PARAMETER>');
  $cipux->perr('<NAME OF PARAMETER>','<LINE NUMBER>');

Example:

  $cipux->perr('parameter_x');
  $cipux->perr('parameter_x', 98);

=head2 exc

Prints a CipUX default exception on STDERR and exits.

 $self->exc({nr=>$nr, value=>$value, msg=>$msg });

=head2 config

Central function to retrieve config space.

  my ($x_hr, $y_hr, $z_hr) = $self->config({config_ar=>$config_ar});

Local <NAME>_config subroutine should be use to fill $config_ar

  Example:

  sub task_config {
      my $config_ar = [];
      push @{$config_ar}, '/home/dummmy/cipux-task.conf';
      my ($x_hr, $y_hr, $z_hr) =
        $self->config({config_ar=>$config_ar});
      return ($x_hr, $y_hr, $z_hr);
  }

=head2 source

Incorporates a config file.

=head2 store_mattrvalue

Helper function for multiple getopt parameter with values.

=head2 store_attrvalue

Helper function for single getopt parameter with value.

=head2 homedir

This is an auxiliary method replacing ~ with $ENV{HGOME}.

B<Syntax:>

 my $file1  =  $common->homedir($file2);

B<Example:>

 if $file1  =  ~/.cipux/cipux-object.conf
 and $ENV{HOME} = /root
 then file2 =  /root/.cipux/cipux-object.conf

=head2 lf

Laundering LDAP filter.

=head2 lp

Laundering passwords.

=head2 li

Laundering integer values.

=head2 l

Laundering of a scalar

 my $scalar = $self->l($input);

=head2 h

Check if type is hash or hash reference.

 my $hash_hr = $self->a($input_hr);

=head2 a

Check if type is array or array reference.

 my $array_ar = $self->a($input_ar);

=head2 test_cli_option

Executes some basic test on command line option regarding a hash.

=head2 date_time

returns date time format of today

=head2 latin1_to_utf8

Converts latin to UTF-8 encoding.

=head2 login_prompt

Prints a login prompt on STDOUT.

=head2 password_prompt

Prints a password prompt on STDOUT.

=head2 random_password

Calculates and returns a relatively random password.

=head2 hash_password

Calculates and returns a hashed password.

=head2 min

Calculate the minimum of two integer values.

=head2 max

Calculate the maximum of two integer values.

=head2 out

Prints content to STDOUT.


=head2 _merge_array

Helper subroutine for _hash_merge_setup. It uses Array::Unique to return a
merged unique array reference.

=head2 _hash_merge_setup

Perform setup for Hash::Merge. The main change is that Arrays are also merged
with uniq values.

=head2 cfg_ext

Gets all supported extensions from Config::Any and remove non supported
extensions.

=head2 cfg

Query the CipUX config space to load configuration in various formats.

 0. Set cfgbase to "cipux" (+ "-$submodule" if not core module)

 1. Set cfgpaths to...:
    1. /usr/share/cipux/etc/$cfgbase.$ext
    2. /usr/share/cipux/etc/$cfgbase.d/*.$ext
    3. /etc/cipux/$cfgbase.$ext
    4. /etc/cipux/$cfgbase.d/*.$ext
    5. ~/.cipux/$cfgbase.$ext

 2. Possible $ext are: cnf .conf .json .jsn .xml .yml .yaml .ini .pl .perl

 #3. Optionally parse and validate uppercase "$cfgbase_cfg" environment
     variable [fail if validation fails]

 #4. Optionally parse and validate "cfg" commandline option
     [fail if validation fails]

 5. Resolve configfile list as cfgpaths, with "$cfgbase_cfg" and "cfg" appended
    if there

 6. Resolve bootstrap file through parsing and validating "bootstrap" option
    from all available files in cfgpaths, later declaration overriding earlier
    ones

 7. Resolve all options through executing bootstrap file

 #8. Optionally override subset of options through parsing and validating
    environment variables starting with uppercase "$cfgbase_"
    [fail if any validation fails]

 9. Optionally override subset of options through parsing and validating all
    options from all available files in cfgpaths [fail if any validation fails]

Notes about the above:

 * Number with leading "#" are not implemented.

 * config files are "layered", allowing overrides. Personal configfile
   is included last, not first, and more locations are supported.

 #* (subset of) options can be provided through ENV

 #* commandline and environment options are validated as part of parsing

Recommendation:

Even if several formats are supported, that does not mean they are all suited
for this task.

 * Some configuration formats for example are too simple to express the complex
   cipux-task.perl configuration.

 * The CPAN Perl modules used for this configuration space are rather young
   Config::Any 2006 - 2009, Hash::Merge 2001 - 2009  and not every
   configuration file type mixture was tested. As a recommendation, you should
   not mix to many files and formats.

=head2 create_cache_dir_if_not_present

Creates a directory 'cipux' under /var/cache if not present. This is used to
store serialized objects.

=head2 iterate_config_space

Takes a single config file $cfg (can be undef, but must be present) and a
string representing the configuration base $cfgbase. It will then just use $cfg
or it will find out regarding to $cfgbase what files should be considered.

  my $loadcfg_ar = $self->iterate_config_space(
      {
          cfg     => $cfg,
          cfgbase => $cfgbase,
      }
  );

returns a list of all configuration files which should be evaluated.

=head2 evaluate_config_space

Takes a araay ref to a list of configuration files $loadcfg_ar, preferably
cunstructed by iterate_config_space. It also taks a string $cache_dir to the
temporary location of a cache_dir. This value can be empty but not undef and
has to be provided. It also require the $cfgbase string, the "domain" of the
configuration.

It will calculate for every config file the MD5sum for later comparison.

        my $clean = $self->evaluate_config_space(
            {
                loadcfg_ar => $loadcfg_ar,
                cache_dir  => $cache_dir,
                cfgbase    => $cfgbase,
            }
        );

It will return 0 if changed files are found and 1 if no changed files are
found.


=head1 DIAGNOSTICS

This module generates the following exceptions:

TODO


=head1 CONFIGURATION AND ENVIRONMENT

Not applicable.

=head1 DEPENDENCIES

 Array::Unique
 Carp
 Class::Std
 Config::Any
 Data::Dumper
 Date::Manip
 English
 File::Basename
 File::Glob
 File::Path
 Hash::Merge
 Log::Log4perl
 Pod::Usage
 Readonly
 Storable
 Term::ReadKey
 Unicode::String
 version

=head1 INCOMPATIBILITIES

Not known.

=head1 BUGS AND LIMITATIONS

Not known.

=head1 SEE ALSO

See the CipUX web page and the manual at L<http://www.cipux.org>

See the mailing list L<http://sympa.cipworx.org/wws/info/cipux-devel>

=head1 AUTHOR

Christian Kuelker  E<lt>christian.kuelker@cipworx.orgE<gt>

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2007 - 2009 by Christian Kuelker

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation; either version 2, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA

=cut