#!/usr/bin/perl
#-#!/usr/local/perl/bin/perl

#=====================================================
# Program name  :   test_ssh_access
# Synopsis      :
#     Simple:
#     test_ssh_access SERVER [SERVER ..]
#     test_ssh_access -l FILE_WITH_SERVERNAMES
#    
#     Advanced:
#     test_ssh_access
#        -l FILE             : Take server names of FILE
#                              First name per line, skip
#                              comments beginning with '#'.
#                              Can be specified multiple times.
#    
#        -o SSH_OPTION=VALUE : Add ssh option for connect.
#                              Can be specified multiple times.
#    
#        -t TIMEOUT_SECS     : Set timeout in seconds other than default (5 seconds)
#        -r RETURNTYPE       : Set return type other than default: 'ok_all'
#                              Valid return types are:
#                              ok          : return count of reachable servers.
#                              ok_all      : exit 0 if all servers reachable, 1 otherwise.
#                              ok_name     : return names of reachable servers.
#                              notok       : return count of unreachable servers.
#                              notok_all   : exit 0 if NO server reachable, 1 otherwise,
#                              notok_name  : return names of unreachable servers.
#                              all         : return 'SERVER STATUS' line for each server,
#                                            where STATUS is one of 'OK' or 'NOT_OK'.
#        -u USER             : Connect as USER instead of executing user.
#        -s PATH_TO_SSH-BIN  : Alternate path to ssh binary
#        -v                  : verbose output
#        SERVER [SERVER ..]  : Test SERVER [SERVER ..]
#
# Purpose       :   Tests if one or more servers can be reached via 'ssh'
#                   without password.
#
# Needs:
#   Perl modules    :
#       Carp,
#       Getopt::Long,
#       IO::File
#       Pod::Usage,
#       Term::ANSIColor,
#
#   System commands :
#       ssh, which, host
#
# Provides      :
#   < Modules and other programs that need test_ssh_access >
#
# CAVEAT :  If server can not be identified with 'host' it will be considered
#           as unreachable.
#
# Creation date :   2014-02-04_14:58:01
# Author        :   vindani, (Vincenzo Daniele)
# Powered by    :   asteras consulting GmbH
#------------------ CVS Section ----------------------
# Header        :   $Id: test_ssh_access 553 2016-03-16 16:39:33Z vindani $
# Version       :   $Revision: 553 $
# State         :   $State$
# Author        :   $Author: vindani $
# Last check in :   $Date: 2016-03-16 17:39:33 +0100 (Wed, 16 Mar 2016) $
#=====================================================

#================
#@LOAD_MODULES BEGIN  
use warnings;
#use diagnostics;   #@debug
use strict;
use Carp;
use File::Basename;
use IO::File;
use Pod::Usage;
#use Data::Dumper;   #@debug

# use other modules and libs here.
use Getopt::Long qw(:config auto_abbrev bundling ); # If NO 'repeat' options needed
#use Getopt::Long qw(:config auto_abbrev no_ignore_case ); # If 'repeat' options needed

#@LOAD_MODULES END
#================

# This is ours  :-) (needed for auto_version of getopts )
our $VERSION            = '1.1';
my $author =   'vindani, (Vincenzo Daniele,Fa. Lupus)';

#================
#@cvs_begin
# Get CVS Tags, if availlable.
my $cvs_header          = '$Id: test_ssh_access 553 2016-03-16 16:39:33Z vindani $';
my $cvs_version         = '$Revision: 553 $';
my $cvs_state           = '$State$';
my $cvs_author          = '$Author: vindani $';
my $cvs_last_check_in   = '$Date: 2016-03-16 17:39:33 +0100 (Wed, 16 Mar 2016) $';

# If it's in CVS there's a number in it.
my $is_known_in_cvs     = $cvs_header =~ /\d+/;

# Switch version and author to cvs version, if we know it.
$VERSION    = $is_known_in_cvs ?   $cvs_version    : $VERSION;
$author     = $is_known_in_cvs ?   $cvs_author     : $author;
#@cvs_end
#================


#================
#@standards_begin
my $pr_debug   =   'DEMARSG  :';
my $pr_error   =   'ERROR  :';
my $pr_ok      =   'OK     :';
my $pr_ok_end  =   'OK.';
my $pr_info    =   'INFO   :';
my $pr_warning =   'WARNING:';
#@standards_end
#================

#================
#@Variables begin
# So we need ...
# First of all: who am i?
my $me  =   $ENV{'USER'}    ?   $ENV{'USER'}    # Try environment part 1 ...
        :   $ENV{'LOGNAME'} ?   $ENV{'LOGNAME'} # or environment part 2 ...
        :   getpwuid($<)    ?   getpwuid($<)    # or to get login name perl style ...
        :   `whoami`        ?   `whoami`        # or common linux/unix style ...
        :   'UNKNOWN';                          # or unknown else.
chomp $me;                                      # ...in case we did 'whoami'.


#-------------------------
#@DAIMLER_SPECIAL
# Let incoming servers be in longname format
my $longname = '/usr/local/bin/longname';

#-------------------------
#@HIDDEN_begin
# Uncomment the appropriate lines in this section,
# if you may have (even nested) sudoers or su - users, and you want
# to show their names.
# Do this best with (in vim command mode => ':'):
#  /^##@HIDDEN_begin/,/^##@HIDDEN_end/ s/^#//
#
# See if we have a hidden name here (by sudo or su -)
# -- Get our parent process id
# -- Do a 'ps -ef'
# -- Recursive search process id with our parent process id
# -- Cache process owner if it's not (the last) $me
#    and not the same as the last cached one (or we haven't cached yet).
# -- Until we find init as parent.
# -- Throw out last if it is 'root'.
# -- If we find something, $me somewhere did a 'su -' or 'sudo', so:
#      -- Reverse order so we can see the consecutive 'su -' or 'sudo' actions.
#      -- Set $hidden.
my $hidden = ''; # Don't comment this line!
my @found_proc_owners;
my $parent  =   getppid();
my @ps_out  =   `ps -ef`;
my $last_me =   $me;
while ( $parent != 1 ){ # Do until we see the init process as parent
    PROCLINE:
    foreach my $procline ( @ps_out ){
        if ( $procline =~ /\A \s* (\S+) \s+ (\d+) \s+ (\d+) \s+/xms ){
            my $proc_owner = $1;
            my $pid = $2;
            my $ppid = $3;
            next PROCLINE if $parent != $pid;
            push @found_proc_owners, $proc_owner
                if $proc_owner ne $last_me
                && ( ! @found_proc_owners || $proc_owner ne $found_proc_owners[-1] );
            $last_me = $proc_owner;
            $parent = $ppid;
            last PROCLINE;
        };
    };
};
my $dummy_lastone;
if ( @found_proc_owners ){
    $dummy_lastone = pop @found_proc_owners if  $found_proc_owners[-1] eq 'root';
};

if ( @found_proc_owners ){
    $hidden = join(' => ', reverse @found_proc_owners);
};
#@HIDDEN_end
#-------------------------

my $this_name   =   basename $0;
my $this_path   =   dirname $0;

my @pw_out = getpwnam( $me );   # Get user infos perl style
my $my_name = $pw_out[6];       # Gecos part of it

$my_name ||= $me;               # If not found, set to short name.

my $welcome     =   $hidden && $me ne $my_name && $me ne $hidden    ?   " Welcome $my_name ( $me - $hidden )\n"
                :   $hidden && $me ne $my_name && $me eq $hidden    ?   " Welcome $my_name ( $me )\n"
                :   $hidden && $me eq $my_name && $me ne $hidden    ?   " Welcome $me ( $hidden )\n"
                :   $hidden && $me eq $my_name && $me eq $hidden    ?   " Welcome $me\n"
                :   $me ne $my_name                                 ?   " Welcome $my_name ( $me )\n"
                :   $me eq $my_name                                 ?   " Welcome $me\n"
                :   " Welcome stranger\n";

my $DESCRIPTION =   $welcome
                .   " This is: $this_name,\n"
                .   " version $VERSION, Author: $author\n";

$DESCRIPTION .= " Status: $cvs_state, Last check in: $cvs_last_check_in\n" if $is_known_in_cvs;

my $separator   =   '==========================================';
my ($sec,$min,$hour,$mday,$mon,$year) = localtime;
my $datum       =   sprintf("%04d-%02d-%02d_%02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec);

#================
#Files and Directories

#================
# DEFAULTS

#================
# Miscellaneous

#@Variables end
#================

# Remove one '#' from #@OPTIONS_begin to #@OPTIONS_end if you want options.
# Do this best with (in vim command mode => ':'):  /^##@OPTIONS_begin/,/^##@OPTIONS_end/ s/^#//
# Change options to your needs.
#================
#@OPTIONS_begin
# Define options in $opt_config.
# This is a hashref with the option names as keys and a hashref with attributes
# for that option each.
# Then the 'build_and_verify_opthash' subroutine will feed GetOptions with
# $opt_config, verifies the input ( if you like ) and handles any
# errors coming out of it.
# The outgoing and verified option hash is then stored in $option_hash.
#
# Valid stanzas to describe an option are:
#  type         :   ( the only mandatory )
#                   boolean =>  Boolean (whithout values).
#                   boolneg =>  Boolean but negatable by prefixing 'no',
#                               like: --nooptionname.
#                   boolinc =>  Boolean, increments every occurance of --option by +1
#                   string  =>  Demands a string value.
#                   integer =>  Demands an integer value.
#                   extint  =>  Demands an extended integer, also hex
#                               and oct style are taken.
#                   real    =>  Demands a real number.
#
#  desttype     :   Destination type. Not for bool* types. Stores the value in 
#                   either an array or hash.
#                   @ => array valued
#                   % => hash valued
#
#  alias        :   Takes an arrayref with aliases for that option.
#
#  default      :   Default value for option. If you also define valid* stanzas,
#                   make sure that the default value is included.
#
#  repeat       :   Takes more than one value for this option.
#                   Repeat string format:  "min [ , max ]"
#                   where min is the minimum and the max the maximum of values taken.
#                   CAVEAT:
#                   'repeat' is not possible while Getopt::Long has
#                   'bundling' enabled.
#                   The functionality of 'repeat' depends on the version of GetOptions.
#                   'bundling' allows to write eg. -abc instead of -a -b -c
#
#  valid        :   Can be be of type ARRAY, Regexp or CODE (ref returns that) and matches
#                   the input to that option against it. If you specify a subroutine for it
#                   (CODE), the value passes the validation if it returns a true value and
#                   fails otherwise.
#                   It's not allowed to validate an option with desttype => '%' (hash) against
#                   an array or regular expression ( think about it, it makes no sense).
#                   Therefore, the next two stanzas can be used in case you want to test
#                   the keys or values of such a hash.
#
#  valid_keys   :   Tests keys of an option of desttype => '%' (hash) against an
#                   ARRAY, Regexp or CODE.
#
#  valid_values :   Tests values of an option of desttype => '%' (hash) against an
#                   ARRAY, Regexp or CODE.
#
#  mandatory    :   A true value indicates, that this option is forced to be set.
#
#  needs        :   Takes an arrayref with options, and means that these options have to be
#                   specified together with the current one.
#
#  needs_out_of :   Takes an arrayref with a number as first array member, and the rest with
#                   other options than the current one [X, OPTIONS].
#                   Means that you need at least X out of OPTIONS to be specified together
#                   with the current one.
#
#  refuse       :   Arrayref containing other options which can not be set together with the
#                   current one. If 'ALL_OTHER' is specified within that array, this option
#                   is supposed to be set as the only one.
#                   CAVEAT:
#                   Don't let any of these OPTIONS have a default stanza, for they will be set
#                   with it and always conflict.
#
#  info         :   Takes a string as input to write out on error.
#
#  filetest     :   Tests a file or directory, where TESTS is a string consisting of characters
#                   of the perl file test operators.
#                   Valid is is a string that is one or a combination of the following characters:
#                   ! : Invert the meaning of the next character.
#                   r : File is readable by effective UID/GID.
#                   w : File is writable by effective UID/GID.
#                   x : File is executable by effective UID/GID.
#                   o : File is owned by effective UID.
#                   R : File is readable by real UID/GID.
#                   W : File is writable by real UID/GID.
#                   X : File is executable by real UID/GID.
#                   O : File is owned by real UID.
#                   e : File exists.
#                   z : File has zero size.
#                   s : File has nonzero size (returns size).
#                   f : File is a plain file.
#                   d : File is a directory.
#                   l : File is a symbolic link.
#                   p : File is a named pipe (FIFO).
#                   S : File is a socket.
#                   b : File is a block special file.
#                   c : File is a character special file.
#                   t : File is opened to a tty.
#                   u : File has setuid bit set.
#                   g : File has setgid bit set.
#                   k : File has sticky bit set.
#                   T : File is a text file.
#                   B : File is a binary file (opposite of T).
#=========================

my $opt_config =   {
    # Modify each option at your needs.
    # See also the description for build_and_verify_opthash.
    list    => {
        type        =>  'string',           # Demands a string value.
        desttype    =>  '@',                # Stores input values in an array.
        alias       =>  [ 'l' ],            # aliases: '-l'
        filetest    =>  'er',               # Input files must exist and be readable
    },

    option  => {
            type        =>  'string',           # Demands a string value.
            desttype    =>  '%',                # Stores input values in hash.
            alias       =>  [qw(o sshoption) ], # aliases: '-o', '--sshoption'
    },

    rtype  => {                                 # Return type
        type    =>  'string',
        alias   =>  [qw( r return returntype )],
        valid   =>  [qw( ok ok_all  ok_name notok notok_all notok_name all)],
        default =>  'ok_all',
        info    =>  "Valid values:\n"
                .   "ok          : returns the number of reachable servers in serverlist.\n"
                .   "ok_all      : returns TRUE (0) if all servers are reachable (this is the default)\n."
                .   "ok_name     : returns the names of reachable servers out of serverlist. One line each.\n"
                .   "notok       : returns the number of unreachable servers in serverlist.\n"
                .   "notok_all   : returns TRUE (0) if NO server of serverlist is reachable.\n"
                .   "notok_name  : returns the names of unreachable servers in serverlist. One line each.\n"
                .   "all         : returns 'SERVER STATUS' line for each server in serverlist, where\n"
                .   "              STATUS is one of 'OK' or 'NOT_OK'.\n",
    },

    ssh_path    => {                            # alternate ssh-path
        type        =>  'string',
        alias       =>  [ 'S' ],
        filetest    =>  'exB',                  # Must exist and be executable Binary
    },


    timeout =>  {
        type    =>  'integer',
        alias   =>  ['t'],
        default =>  5,
        valid   =>  sub {
                    my $input = shift @_;
                    return if $input < 5;
                    return 1;
                },
        info    =>  'Minimum timeout value is 5 (seconds).',
    },

    user    =>  {                               # alternate user than $me
        type        =>  'string',
        alias   =>  ['u'],
        default =>  $me,
    },

    help    => {
            type        =>  'boolean',          # Boolean option (whithout values)
            alias       =>  [ qw( h ? ) ],      # aliases: '-h', '-?'
        },

    man     => {
            type        =>  'boolean',          # Boolean option (whithout values)
            alias       =>  [ 'M' ],            # aliases: '-M'
        },

    quiet   => {
            type        =>  'boolean',
            alias       =>  ['q'],
            refuse      =>  ['verbose'],        # Not together with 'verbose'
        },

    version => {
            type        =>  'boolean',          # Boolean option (whithout values)
            alias       =>  [ 'V' ],            # aliases: '-V'
        },

    verbose => {
            type        =>  'boolinc',          # incrementing Boolean
            alias       =>  [ 'v' ],            # aliases: '-v'
        },
};

# Get and verify the options, put in $option_hash
my $option_hash = build_and_verify_opthash( $opt_config, $this_name );

#================
# Display man page and exit if wanted.
pod2usage(  -exitstatus => 0,
            -verbose    => 2,
) if $option_hash->{'man'};

#================
# Display help and exit if wanted.
pod2usage(  -message    => $DESCRIPTION,
            -exitstatus => 0,
            -verbose    => 99,
            -sections   => "SYNOPSIS|DESCRIPTION",
) if $option_hash->{'help'};

#================
# Display version and exit if wanted
if ( $option_hash->{'version'} ){
    print $DESCRIPTION;
    exit;
};

# Now all options are set
# $option_hash
#print $pr_debug, "Take a look at the options\n"; my $debug_1 = <STDIN>; #@debug
#@Options_end
#================

#================
# Scoop the rest into @incoming, leave nothing in @ARGV
my @incoming;   # Remaining rest of ARGV after GetOptions()
while ( @ARGV ){
    push @incoming, shift @ARGV
};

#================
# Uncomment next lines if you want to force people to do an input
# besides options.
if ( ! @incoming && ! exists $option_hash->{'list'} ){
    croak   $pr_error . "$this_name $VERSION: Expected at least either machines as arguments or '-l|--list SERVERLIST'.\n"
        .   $pr_info  . "Maybe try $this_name -h or $this_name --man.\n"
};

#================
# Uncomment next lines if you want to force people to set options.
#unless ( keys %$option_hash ){
#    print   $pr_error . "$this_name $VERSION: Expected options.\n"
#        .   $pr_info  . "Maybe try $this_name -h or $this_name --man.\n";
#    pod2usage(  -message    => $DESCRIPTION,
#                -exitstatus => 103,
#                -verbose    => 99,
#                -sections   => "SYNOPSIS|DESCRIPTION",
#    );
#};

#================
#@Functions_begin

#=========================
#@STANDARD_FUNCTIONS_BEGIN

#@verbout_begin
sub verbout {
    # Activate (in vim command mode => ':') :  /^##@verbout_begin/,/^##@verbout_end/ s/^#//  
    # Usage     :   verbout( IN_VERBOSITY, STRING )
    # Purpose   :   Prints out the string STRING if the current verbosity level
    #               is greater or equal than the verbosity specified for this
    #               string (IN_VERBOSITY).
    #               Incoming  :   IN_VERBOSITY: Verbosity of STRING.
    #               -1  :   Print even when --quiet enabled
    #               0   :   Normal mode.
    #               1   :   Print when --verbose or -v in effect.
    #               2   :   Print when --verbose --verbose or -vv in effect.
    #               ..
    #               STRING: A string.
    # Outgoing  :   STRING is printed out depending on verbosity.
    # Needs     :   
    # Provides  :
    # Description:
    #   verbout makes sense, if you specify a 'verbose' or 'quiet' option with test_ssh_access.

    my $in_verbosity = shift @_;    # Print text with this verbosity
    my @text = @_;                  # Incoming text

    if ( $in_verbosity !~ /[+-]* \d+/xms ){
        croak $pr_error . "verbout: False input verbosity: '$in_verbosity'. Expecting digits ( [+-]NUMBER).\n"
    };

    my  $act_verbosity  =
            $option_hash->{'quiet'}     ?   -1
        :   $option_hash->{'verbose'}   ?   $option_hash->{'verbose'}
        :   0;

    print @text if $act_verbosity >= $in_verbosity ;
};
#@verbout_end


#@uniq_begin
sub uniq {
    # Usage             : uniq @some_array
    # Incoming values   : @some_array
    # Outgoing results  : an array with unique elements - NOT sorted
    # Prerequisites     :
    # Purpose           : uniques an array without sorting
    # Description:
    my @incoming = @_;

    my %lookup_table = ();
    my @output = ();
    foreach ( @incoming ){
        push @output, $_ unless $lookup_table{$_}++;
    };
    return @output;
};
#@uniq_end

#-------------------------
# Simple progress indicators
#@begin_phase_begin
sub begin_phase {
    # Usage             : begin_phase( PHASE )
    # Incoming values   : A string.
    # Outgoing results  : Printout to STDERR:
    #                     #=========================
    #                     # Starting  : 'PHASE'
    my $phase = shift @_;
    print STDERR $pr_info . "#=========================\n# Starting: '$phase'.\n";
};
#@begin_phase_end

#@run_phase_begin
sub run_phase {
    # Usage             : run_phase, run_phase( ACTUAL )
    # Incoming values   : A string or nothing.
    # Outgoing results  : Whithout a value prints a single dot '.' to STDERR,
    #                     specifying a value prints:
    #                     #-------------------------
    #                     # Now proceeding: 'ACTUAL'
    my $phase = shift @_;
    if ( $phase ){
        print STDERR    "\n" . $pr_info . "#-------------------------\n"
                    .   $pr_info . "# Now proceeding: '$phase'\n";
    }
    else {
        print STDERR '.';
    };
};
#@run_phase_end

#@end_phase_begin
sub end_phase {
    # Usage             : end_phase( PHASE )
    # Incoming values   : A string.
    # Outgoing results  : Printout to STDERR:
    #                     # Finished: 'PHASE'
    #                     #=========================
    my $phase = shift @_;
    print STDERR "\n" . $pr_info . "# Finished: '$phase'.\n#=========================\n\n";
};
#@end_phase_end
#-------------------------


#@commify_array_begin
sub commify_array {
    # Usage             :   commify_array( @ARRAY )
    # Incoming values   :   An array or list
    # Outgoing results  :   A string with the comma separated values of @ARRAY
    # Prerequisites     :
    # Purpose           :   Get a nice output string for an array, including a final 'and'.
    # Description:
    #   Example: my @ARRAY = qw( blah blubb ding dong); my $out = commify_array( @ARRAY );
    #   => $out is "blah, blubb, ding and dong"
    my $this_function   =   (caller(0))[3];

    # Print out an array with commas
    (@_ == 0) ? ''                                      :
    (@_ == 1) ? $_[0]                                   :
    (@_ == 2) ? join(" and ", @_)                       :
     join(", ", @_[0 .. ($#_-1)]) . " and $_[-1]";
};
#@commify_array_end


#@compare_list_begin
sub compare_list {
    # Usage             :   compare_list( ACTION, \@LEFTLIST, \@RIGHTLIST|$ITEM )
    # Incoming values   :   An action and two arrays to compare
    #                       (or an array an and item).
    #
    #       where ACTION can be one of the following:
    #       intersect   :   gets the intersection of both sides.
    #                       Careful here! LEFTLIST and RIGHTLIST will be uniqued!
    #       all         :   returns true, if all items of RIGHTLIST or ITEM
    #                       are found in LEFTLIST
    #       any         :   returns true, if at least one item of RIGHTLIST or ITEM
    #                       is found in LEFTLIST
    #       none        :   returns true, if no item of RIGHTLIST or ITEM
    #                       is found in LEFTLIST
    #       complement  :   gets all elements of LEFTLIST that are NOT found in RIGHTLIST
    #
    #       LEFTLIST has to be an arrayref!
    #       The right side has to be either an arrayref, too or just a simple scalar.
    #       RIGHTLIST will always be uniqued, if it is an array!
    #
    # Outgoing results  :   depends on ACTION
    # Prerequisites     :   uniq
    # Purpose           :   compare ELEMENTS of two arrays
    # Description:
    #   Example:
    #   my @testlist = qw ( ding dang dong bla);
    #   my @to_find  = qw( bla blubb );
    #   my @intersect = compare_list( 'intersect', \@testlist, \@to_find );
    #   gets 'bla' for @intersect
    #
    # CAVEAT:
    # LEFTLIST and RIGHTLIST will be uniqued throughout the operations.
    # So it would be more precise to talk about comparing ELEMENTS of lists.

    my $this_function   =   (caller(0))[3];

    my @incoming = @_;
    my @valid_actions = qw( intersect all any none complement );

    my $action  =   shift @incoming;
    my $left    =   shift @incoming;
    my $right   =   shift @incoming;
    my $usage   =   $pr_info . 'USAGE: compare_list( ACTION, \@LEFTLIST, \@RIGHTLIST|$ITEM )' . "\n"
                .   $pr_info . "Where ACTION is one of:\n"
                .   $pr_info . "    intersect   :   gets the intersection of both sides.\n"
                .   $pr_info . "                    Careful here! A copy of LEFTLIST and RIGHTLIST will be uniqued!\n"
                .   $pr_info . "    all         :   returns true, if all items of RIGHTLIST or ITEM\n"
                .   $pr_info . "                    are found in LEFTLIST\n"
                .   $pr_info . "    any         :   returns true, if at least one item of RIGHTLIST or ITEM\n"
                .   $pr_info . "                    is found in LEFTLIST\n"
                .   $pr_info . "    none        :   returns true, if no item of RIGHTLIST or ITEM\n"
                .   $pr_info . "                    is found in LEFTLIST\n"
                .   $pr_info . "    complement  :   gets all elements of LEFTLIST that are NOT found in RIGHTLIST\n"
                .   $pr_info . "\n"
                .   $pr_info . "    LEFTLIST has to be an arrayref!\n"
                .   $pr_info . "    The right side has to be either an arrayref, too, or just a simple scalar.\n"
                .   $pr_info . "    A copy of RIGHTLIST will always be uniqued, if it is an array!\n";


    # Prove your incoming values and prerequisites here
    #@Error_handling_begin
    #==================
    # Test valid action
    if ( ! grep { $_ eq $action } @valid_actions ){
        croak(  $pr_error,  "$this_function: Invalid action: '$action'.\n",
                $pr_info,   "Valid actions are: @valid_actions\n");
    };

    #======================
    # Test correct LEFTLIST
    if ( ! $left || ( ref( $left ) ne 'ARRAY' ) ){
        croak   $pr_error  . "$this_function: LEFTLIST has to be a reference to an array.\n"
            .   $usage;
    };

    #===============================
    # Test correct RIGHTLIST or ITEM
    unless ( $right ){
        croak   $pr_error,  "$this_function: No items to compare specified.\n"
            .   $usage;
    };

    #  If it is a reference, it should only be an arrayref
    if ( ref( $right ) &&  ref( $right ) ne 'ARRAY' ){
        croak   $pr_error . "$this_function: RIGHTLIST has to be an array ref or no reference at all.\n"
            .   $usage;
    };
    #@Error_handling_end

    # Set internal variables
    my @_left   = uniq( @$left );
    my @_right;
    @_right     = uniq( @$right )   if ref( $right );
    push @_right, $right            unless ref( $right );

    my @intersect;
    my @complement;
    my %seen;
    # Build lookup table. Make all right things 'seen'
    foreach my $item ( @_right ) { $seen{$item} = 1 };

    # If seen in left add to return list
    # If not seen in left add to complement list,
    foreach my $item ( @_left ){
        push @intersect, $item if $seen{$item};
        push @complement, $item unless $seen{$item};
    };

    for ( $action ){
        /\Aintersect\z/ and
            do {    # intersection of elements
                return @intersect;
                last;
            };

        /\Aany\z/ and
            do {
                return 1 if @intersect;
                return;
                last;
            };

        /\Aall\z/ and
            do {
                return 1 if scalar( @intersect ) == scalar ( @_right );
                return;
                last;
            };

        /\Anone\z/ and
            do {
                return if @intersect;
                return 1;
                last;
            };

        /\Acomplement\z/ and
            do {
                return @complement;
                last;
            };

        croak(  $pr_error,  "$this_function: Unknown action: $action\n");
        last;
    };
};
#@compare_list_end


#@build_and_verify_opthash_begin
sub build_and_verify_opthash {
    # Usage     :   my $opt_hash = build_and_verify_opthash( OPT_CONFIG [, PROGNAME] )
    # Purpose   :   Builds the argument array, passes it to Getopt::Long's GetOptions
    #               and verfies the options settings ( if defined )
    # Incoming  :   OPT_CONFIG: A hashref with stanzas for each option, see Description.
    #               PROGNAME: You may provide it with the program name it should refer to.
    # Outgoing  :   A hashref with the options set and being verified.
    # Needs     :   Carp, compare_list, commify_array (DanUtils),
    #               Data::Dumper, Getopt::Long.
    # Provides  :
    # Description:
    #   As this sub has as a main task to 'translate' the stanza settings into the
    #   syntax of 'GetOptions', see also the description of 'type', 'desttype', 'alias'
    #   and 'repeat' in the manual of Getopt::Long.
    #   This sub takes as input a hashref ( in the following example $opt_config)
    #   which contains stanzas for each option. The only mandatory is 'type', the rest
    #   is optional. Look at the following example (option 'foo'):
    #   $opt_config ={
    #       foo     =>
    #           {
    #               type        =>  TYPE,       # Mandatory.
    #               desttype    =>  DESTTYPE,   # '@' for array or '%' for hash.
    #               alias       =>  [ALIASES],  # Arrayref with aliases.
    #               repeat      =>  REPEAT,     # Take more than one value at once.
    #               valid       =>  LIST,       # Validate input against a list.
    #               valid       =>  REGEXP,     # Validate input with regular expression.
    #               valid       =>  CODE,       # Validate input with an anonymous sub.
    #                                           # It must return a true value to pass.
    #               default     =>  DEFAULT,    # Default value. If combined with
    #                                           # 'valid', 'valid_keys' or 'valid_values'
    #                                           # this value must be covered there, too.
    #
    #               # If DESTTYPE is '%' (hash) you can verify only by CODE ( a coderef).
    #               # But you can validate the keys and values separately by a list,
    #               # a regex or a subroutine with these stanzas:
    #               valid_keys      =>  LIST|REGEXP|CODE,
    #               valid_values    =>  LIST|REGEXP|CODE,
    #
    #               mandatory   =>  TRUE,       # A true value indicates, that this option
    #                                           # is forced to be set.
    #
    #               needs       =>  [OPTIONS],  # Arrayref, where OPTIONS are other options
    #                                           # which have to be specified together
    #                                           # with the current one.
    #
    #               needs_out_of=>  [X,OPTIONS],# Arrayref, where you need at least X
    #                                           # out of OPTIONS to be specified together
    #                                           # with the current one.
    #
    #               refuse      =>  [OPTIONS],  # Arrayref, where OPTIONS are other options
    #                                           # which can not be set together with the
    #                                           # current one. If you specify 'ALL_OTHER'
    #                                           # within OPTIONS, this options quits if any
    #                                           # other options are set.
    #                                           # CAVEAT:
    #                                           # Don't let any of these OPTIONS have a default
    #                                           # stanza, for they will be set
    #                                           # with it before and therefore always conflict.
    #
    #               info        =>  INFO,       # Where INFO is a string displayed on error.
    #               filetest    =>  TESTS,      # Tests a file or directory, where TESTS is a
    #                                           # string consisting of characters of the perl
    #                                           # file test operators.
    #           },
    #       ..
    #   };
    #
    #   Where
    #   TYPE        :   One of 
    #                   boolean =>  Boolean (whithout values).
    #                   boolneg =>  Boolean but negatable by prefixing 'no', like: --nooptionname.
    #                   boolinc =>  Boolean, increments every occurance of --option by +1.
    #                   string  =>  Demands a string value.
    #                   integer =>  Demands an integer value.
    #                   exint   =>  Demands an extended integer, also hex and oct style are taken.
    #                   real    =>  Demands a real number.
    #   DESTTYPE    :   Destination type.
    #                   '@' stores the values into an array.
    #                   '%' stores the values into a hash.
    #   ALIASES     :   Alias names for the option, can be single characters, too.
    #   REPEAT      :   Has the form: 'NUM'     => take NUM input values for this option
    #                           or  : 'MIN,MAX' => take at least MIN and up to MAX values for
    #                           this option, where NUM, MIN and MAX are positive integers,
    #                           MAX > MIN.
    #   REGEXP      :   A reqular expression.
    #   CODE        :   An anonymous subroutine. If it returns a true value, the input for
    #                   that option is indicated to pass, a false return value means to fail.
    #   TESTS       :   A string consisting of the following characters:
    #                   ! : Invert the meaning of the next character.
    #                   r : File is readable by effective UID/GID. 
    #                   w : File is writable by effective UID/GID. 
    #                   x : File is executable by effective UID/GID. 
    #                   o : File is owned by effective UID. 
    #                   R : File is readable by real UID/GID. 
    #                   W : File is writable by real UID/GID. 
    #                   X : File is executable by real UID/GID. 
    #                   O : File is owned by real UID. 
    #                   e : File exists. 
    #                   z : File has zero size. 
    #                   s : File has nonzero size (returns size). 
    #                   f : File is a plain file. 
    #                   d : File is a directory. 
    #                   l : File is a symbolic link. 
    #                   p : File is a named pipe (FIFO). 
    #                   S : File is a socket. 
    #                   b : File is a block special file. 
    #                   c : File is a character special file. 
    #                   t : File is opened to a tty. 
    #                   u : File has setuid bit set. 
    #                   g : File has setgid bit set. 
    #                   k : File has sticky bit set. 
    #                   T : File is a text file. 
    #                   B : File is a binary file (opposite of T). 
    #
    # CAVEAT:
    #   'repeat' is not possible while Getopt::Long has
    #   'bundling' enabled.
    #   The functionality of 'repeat' depends on the version of GetOptions.
    #   'bundling' allows to write eg. -abc instead of -a -b -c
    #

    my @incoming    =   @_;             # just as a starting suggestion ...
    my $this_func   =   (caller(0))[3]; # for error messages
    my $func_ver    =   '1.6';          # Version of build_and_verify_opthash
    my $opt_config  =   shift @incoming;
    my $this_name   =   shift @incoming;
    $this_name ||= 'this program';
    my $option_hash =   {};             # Resulting option hash to return.
    my $err_msg     =   "";             # Gather error messages here.

    my %type_table  = (
        boolean =>  '',     # Boolean (whithout values)
        boolneg =>  '!',    # boolean but negatable by prefixing 'no', like: --nooptionname
        boolinc =>  '+',    # boolean, increments every occurance of --option by +1
        string  =>  's',    # Demands a string value.
        integer =>  'i',    # Demands an integer value.
        extint  =>  'o',    # Demands an extended integer, also hex and oct style are taken.
        real    =>  'f',    # Demands a real number.
    );

    my %failed_file_test = (
        r   =>  'File is not readable by effective UID/GID.',
        w   =>  'File is not writable by effective UID/GID.',
        x   =>  'File is not executable by effective UID/GID',
        o   =>  'File is not owned by effective UID.',
        R   =>  'File is not readable by real UID/GID.',
        W   =>  'File is not writable by real UID/GID.',
        X   =>  'File is not executable by real UID/GID.',
        O   =>  'File is not owned by real UID.',
        e   =>  'File does not exist.',
        z   =>  'File has not zero size.',
        s   =>  'File has not nonzero size. ',
        f   =>  'File is not a plain file.',
        d   =>  'File is not a directory.',
        l   =>  'File is not a symbolic link.',
        p   =>  'File is not a named pipe (FIFO).',
        S   =>  'File is not a socket.',
        b   =>  'File is not a block special file.',
        c   =>  'File is not a character special file.',
        t   =>  'File is not opened to a tty.',
        u   =>  'File has no setuid bit set.',
        g   =>  'File has no setgid bit set.',
        k   =>  'File has no sticky bit set.',
        T   =>  'File is not a text file.',
        B   =>  'File is not a binary file.',
    );

    my @valid_filetests     =   keys %failed_file_test;
    my @valid_types         =   keys %type_table;
    my @valid_desttypes     =   qw( @ % );
    my @valid_stanzas       =   qw( type        desttype        alias       repeat  valid
                                    valid_keys  valid_values    mandatory   needs   info 
                                    refuse      filetest        default     needs_out_of);

    # Prove your incoming values and prerequisites here
    #@Error_handling_begin
    if ( ref $opt_config ne 'HASH' ){
        croak   $pr_error . "Invalid value for OPT_CONFIG. It is of type '"
                          . ( ref $opt_config )
                          . "', but should be of type 'HASH'.\n"
            .   $pr_info  . "Usage: $this_func( OPT_CONFIG ); #or \n"
            .   $pr_info  . '       my $option_hash = ' . "$this_func( OPT_CONFIG );\n"
            .   $pr_info  . "Where OPT_CONFIG is a hashref\n";
    };
    #@Error_handling_end

    #-------------------------
    # Build the array to hand over to Getopts.
    # Each option in that list looks like this:
    # OPTION[!+]
    # OPTION=type[ desttype ][ repeat ]
    #
    # Boolean options (whithout values)
    # !     : boolneg
    # +     : boolinc
    #
    # Options with values:
    # =type[ desttype ][ repeat ]
    # type values:
    # s     : string
    # i     : integer
    # o     : extended integer, also hex and oct style are taken
    # f     : real number
    #
    # desttype values:
    # @         : array valued
    # %         : hash valued
    #
    # repeat format:
    # { min [ , [ max ] ] }
    # where min is the minimum and the max the maximum of values taken.
    #
    # Examples:
    # foo|f=s@      : Option 'foo' takes a string and stores it into an array, alias is 'f'.
    # bar|b=f{3,5}  : Option 'bar' takes at least 3 to a maximum of 5 real values, alias is 'b'.
    #
    my @getopts;
    my @mandatory_opts; # mandatory options go here.
    my %needed_for;     # dependent options go here.
    my %needed_out_of;  # partly dependent options go here.
    my %refused_for;    # independent options go here.
    my @all_options = keys %$opt_config;
    MARSILD_GETOPTS:
    foreach my $option ( @all_options ){
        my $optstring   =   $option;            # to push to @getopts.

        #-------------------------
        # First check if we have only valid stanzas,
        # then if the option type is set and correct.
        if ( my @invalid_keys = compare_list( 'complement', [ keys %{ $opt_config->{$option} } ], \@valid_stanzas ) ){
            $err_msg .= $pr_error . "Building option '$option' failed.\n"
                    .   $pr_error . "Invalid stanzas found: " . join(', ', @invalid_keys ) . ".\n";
            next MARSILD_GETOPTS; 
        };

        # 'type' stanza is mandatory ...
        unless ( exists $opt_config->{$option}->{'type'} ){
            $err_msg .= $pr_error . "Building option '$option' failed.\n"
                    .   $pr_error . "Missing 'type' stanza in option config.";
            next MARSILD_GETOPTS;
        };

        # ... and must be valid.
        my $opt_type    =   $opt_config->{$option}->{'type'};
        if ( compare_list( 'none', \@valid_types, $opt_type ) ){
            $err_msg .= $pr_error . "Building option '$option' failed.\n"
                    .   $pr_error . "Invalid option type: '$opt_type'.\n"
                    .   $pr_info  . "Valid values for stanza 'type' are:\n"
                    .   $pr_info  . commify_array( @valid_types ) . ".\n";
            next MARSILD_GETOPTS;
        };

        # Gather mandatory options, if any.
        push @mandatory_opts, $option if defined $opt_config->{$option}->{'mandatory'};

        # Check and gather dependent options, if any.
        if ( exists $opt_config->{$option}->{'needs'} ){
            my $needed = $opt_config->{$option}->{'needs'};

            # Must be an arrayref
            if ( ref $needed ne 'ARRAY' ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Value for 'needed' stanza must be an arraref with other options.\n";
                next MARSILD_GETOPTS;
            };

            # Only valid options
            if ( my @unknown = compare_list( 'complement', $needed, \@all_options ) ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Invalid values found for stanza 'needed': "
                        .   commify_array( @unknown ) . "\n"
                        .   $pr_info . "Only other options could be set here.\n";
                # no next MARSILD_GETOPTS here.
            };

            # ... and not the current one.
            if ( compare_list( 'any', $needed, $option ) ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Found own option '$option' in 'needes' stanza.\n"
                        .   $pr_error . "It makes no sense for an option to be needed by itself :-) .\n";
                next MARSILD_GETOPTS;
            };

            # Here they're valid, so put them into the lookup table
            $needed_for{ $option } = $needed;
        };

        # Check and gather partly dependent options, if any.
        if ( exists $opt_config->{$option}->{'needs_out_of'} ){
            my $needed = $opt_config->{$option}->{'needs_out_of'};

            # Must be an arrayref
            if ( ref $needed ne 'ARRAY' ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Value for 'needed' stanza must be an arraref with other options.\n";
                next MARSILD_GETOPTS;
            };

            # First in list must be a number
            my $nof_needed = $needed->[0];
            if ( $nof_needed !~ /\A \d+ \z/xms || $nof_needed < 1){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "First value for 'needed_out_of' stanza must be a number > 0,\n"
                        .   $pr_error . "but was: '$nof_needed'\n";
                next MARSILD_GETOPTS;
            };

            # And this number must not exceed the count of options
            if ( $nof_needed > scalar @$needed -1 ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Number of needed options ($nof_needed) exceeds\n"
                        .   $pr_error . "number of options to choose from (" . (scalar @$needed -1) . ").\n";
                next MARSILD_GETOPTS;
            };

            # Only valid options
            my @option_pool = @$needed;         # Get a copy of 'needed' array
            my $dummy = shift @option_pool;     # Get rid of nof_needed in copy of array
            if ( my @unknown = compare_list( 'complement', \@option_pool, \@all_options ) ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Invalid values found for stanza 'needed': "
                        .   commify_array( @unknown ) . "\n"
                        .   $pr_info . "Only other options could be set here.\n";
                # no next MARSILD_GETOPTS here.
            };

            # ... and not the current one.
            if ( compare_list( 'any', \@option_pool, $option ) ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Found own option '$option' in 'needes' stanza.\n"
                        .   $pr_error . "It makes no sense for an option to be needed by itself :-) .\n";
                next MARSILD_GETOPTS;
            };

            # Here they're valid, so put them into the lookup table
            $needed_out_of{ $option } = $needed;
        };

        # Check and gather options, that hate each other, if any.
        if ( exists $opt_config->{$option}->{'refuse'} ){
            my $refused = $opt_config->{$option}->{'refuse'};

            # Must be an arrayref
            if ( ref $refused ne 'ARRAY' ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Value for 'refuse' stanza must be an arraref with other options.\n";
                next MARSILD_GETOPTS;
            };

            # ... and not the current one.
            if ( compare_list( 'any', $refused, $option ) ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Found own option '$option' in 'refuse' stanza.\n"
                        .   $pr_error . "It makes no sense for an option to hate itself :-) .\n";
                next MARSILD_GETOPTS;
            };

            # ... and only valid options, or 'ALL_OTHER'
            if ( my @unknown = compare_list( 'complement', $refused, \@all_options ) ){
                if ( grep {$_ eq 'ALL_OTHER'} @unknown ){
                    my @all_others = compare_list( 'complement', \@all_options, $option );
                    $refused = \@all_others;
                }
                else {
                    $err_msg .= $pr_error . "Building option '$option' failed.\n"
                            .   $pr_error . "Invalid values found for stanza 'refuse': "
                            .   commify_array( @unknown ) . "\n"
                            .   $pr_info . "Only other options could be set here.\n";
                    next MARSILD_GETOPTS;
                };
            };

            # Here they're valid, so put them into the lookup table
            $refused_for{ $option } = $refused;
        };

        # The 'info' stanza must be a scalar, if exists.
        if ( exists $opt_config->{$option}->{'info'} && ( my $info_ref = ref $opt_config->{$option}->{'info'} ) ){
            $err_msg .= $pr_error . "Building option '$option' failed.\n"
                    .   $pr_error . "The 'info' stanza must be a string, but is of type: '$info_ref'\n";
            next MARSILD_GETOPTS;
        };

        # The 'filetest' stanza must be a scalar and consist of only valid characters and '!'
        # to negate ONE character.
        # We are generous enough to admit whitespace and dashes.
        if ( exists $opt_config->{$option}->{'filetest'} ){
            if ( my $filetest_ref = ref $opt_config->{$option}->{'filetest'} ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "The 'filetest' stanza must be a string, but is of type: '$filetest_ref'\n"
            }
            else {
                my $filetest_string = $opt_config->{$option}->{'filetest'};
                my $err_msg_filetest;
                FILETEST_CHAR:
                foreach my $char ( split //, $filetest_string ){
                    next FILETEST_CHAR if $char =~ /[\s+\-!]/;       # Omit whitespace and dashes
                    if ( ! grep { $char eq $_ } @valid_filetests ){
                        $err_msg_filetest .= $pr_error . "Invalid 'filetest' in tests '$filetest_string'. character: '$char'\n";
                    };
                };
                if ( $err_msg_filetest ){
                    $err_msg .= $pr_error . "Building option '$option' failed.\n" . $err_msg_filetest
                             .  $pr_info  . "Valid tests are: " . commify_array( @valid_filetests ) . "\n";
                };
            };
        };

        #-------------------------
        # Then append the aliases, if any.
        if ( my $aliases = $opt_config->{$option}->{'alias'} ){
            if ( ref $aliases ne 'ARRAY' ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "The 'alias' stanza in the option config has\n"
                        .   $pr_error . "to be an arrayref, but it is: '$aliases'.\n";
            next MARSILD_GETOPTS;
            };
            foreach my $alias ( @$aliases ){
                $optstring .= '|' . $alias;                # like 'foobar|foo|F'
            };
        };

        #-------------------------
        # Then append the type.
        if ( $opt_type =~ /\Abool/ ){
            $optstring .= $type_table{ $opt_type };         # like bool|b+
            push @getopts, $optstring;
            next MARSILD_GETOPTS;                             # thats for booleans.
        }
        else {
            $optstring .= '=' . $type_table{ $opt_type };   # like 'foobar|foo|F=s'
        };

        #-------------------------
        # Then look for the destination type ( booleans ended here).
        if ( exists $opt_config->{$option}->{'desttype'} ){
            my $desttype =  $opt_config->{$option}->{'desttype'};
            if ( ! grep { $desttype eq $_ } @valid_desttypes ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Invalid value for stanza 'desttype': '$desttype'.\n"
                        .   $pr_info  . "Valid values are '%' to store in a hash\n"
                        .   $pr_info  . "and '" . '@' . "' to store in an array.\n";
                next MARSILD_GETOPTS;
            };

            $optstring .= $desttype;                        # like 'foobar|foo|F=s@'
        };

        #-------------------------
        # Then look for repeats.
        if ( exists $opt_config->{$option}->{'repeat'} ){
            # Worst case is something like '   a ,   b  ,' => split on whitespace and commas.
            # Break after the 4th split.
            # In this worst case @repeats is ' undef, a,b,undef', and we always pick the first
            # two defined of it.
            my $rep_string = $opt_config->{$option}->{'repeat'};
            my @repeats = split /[\s,]+/, $rep_string, 4;
            my ( $min, $max ) = grep { $_ if defined $_ } @repeats;
            if (        $min !~ /\A \d+ \z/xms                      # min has to be a number
                    ||  ( defined $max && $max !~ /\A \d+ \z/xms )  # max, too - if defined
                    ||  ( defined $max && $max <= $min )            # with max > min.
            ){
                $err_msg .= $pr_error . "Building option '$option' failed.\n"
                        .   $pr_error . "Invalid value for stanza 'repeat': '$rep_string'.\n"
                        .   $pr_info  . "Must be a single number or two numbers, separated by a comma,\n"
                        .   $pr_info  . "and if you specify a maximum, it must be bigger than the minimum.\n"
                        .   $pr_info  . "E.g.: '2'  or '2,4'\n";
                next MARSILD_GETOPTS;
            };

            # Append repeat minimum, and the maximum, if specified.
            $optstring .= '{' . $min;
            $optstring .=   $max ?  ",$max}"    :   '}'; 
        };
        #-------------------------
        # At least append to @getopts
        push @getopts, $optstring;
    };

    #-------------------------
    # Croak out error messages, if any.
    if ( $err_msg ){
        croak $pr_error . "$this_func $func_ver: Found errors in option configuration for $this_name.\n"
            . $err_msg
            . $pr_info  . "Please look up the manpage or help ($this_name --help|-h|-?|--man|-M).\n";
    };

    #=========================
    # Get options or die.
    GetOptions( $option_hash, @getopts ) or
        die   $pr_error . "An error occured while GetOptions.\n";
    #=========================

    #-------------------------
    # Check if all mandatory options have been set
    if ( @mandatory_opts ){
        foreach my $mandatory ( @mandatory_opts ) {
            # help, man and version begin first and immediatedly terminate after invocation,
            # so it's ok to let them pass.
            last if exists $option_hash->{'help'};
            last if exists $option_hash->{'man'};
            last if exists $option_hash->{'version'};
            unless ( exists $option_hash->{$mandatory} ){
                $err_msg .= $pr_error . "Mandatory option '$mandatory' not set.\n";
            };
        };
    };

    #-------------------------
    # Check if all dependent options have been set.
    if ( %needed_for ){
        foreach my $option ( keys %needed_for ){
            next unless exists $option_hash->{$option}; # Check only if that option is set.
            foreach my $dependent ( @{ $needed_for{ $option } } ){
                unless ( exists $option_hash->{$dependent} ){
                    $err_msg .= $pr_error . "Missing dependent option for '$option': '$dependent'.\n"
                };
            };
        };
    };

    #-------------------------
    # Check if all partly dependent options have been set.
    if ( %needed_out_of ){
        foreach my $option ( keys %needed_out_of ){
            next unless exists $option_hash->{$option}; # Check only if that option is set.
            my $count = 0;
            my $nof_dependent = shift @{ $needed_out_of{ $option } };
            foreach my $dependent ( @{ $needed_out_of{ $option } } ){
                if ( exists $option_hash->{$dependent} ){   # If we found a dependent
                    $count++;                               # count it up
                    last if $nof_dependent = $count;        # leave when enough
                };
            };

            if ( $count < $nof_dependent ){
                $err_msg .= $pr_error . "Missing dependent option for '$option'.\n"
                        .   $pr_info .  "We need at least $nof_dependent out of these options set:\n"
                        .   $pr_info . commify_array( @{ $needed_out_of{ $option } } ) . "\n";
            };
        };
    };

    #-------------------------
    # Check if independent options have been set.
    if ( %refused_for ){
        foreach my $option ( keys %refused_for ){
            foreach my $hating ( @{ $refused_for{ $option } } ){
                if ( exists $option_hash->{$option} && exists $option_hash->{$hating} ){
                    $err_msg .= $pr_error . "Conflicting options: '$option' and '$hating'.\n"
                };
            };
        };
    };

    #-------------------------
    # Now set the defaults, if not yet set.
    foreach my $option ( @all_options ){
        next unless exists $opt_config->{$option}->{'default'};
        unless ( exists $option_hash->{$option} ){
            $option_hash->{$option} = $opt_config->{$option}->{'default'};
        };
    };

    #-------------------------
    # Now verify the incoming values ( if 'valid'* or 'filetest' is set).
    VERIFY_OPTION:
    foreach my $option ( keys %$option_hash ){
        if (        ! exists $opt_config->{$option}->{'valid'}
                &&  ! exists $opt_config->{$option}->{'valid_keys'}
                &&  ! exists $opt_config->{$option}->{'valid_values'} 
                &&  ! exists $opt_config->{$option}->{'filetest'} ){
            next VERIFY_OPTION;
        };
        next VERIFY_OPTION if $opt_config->{$option}->{'type'} =~ /\Abool/;    # Skip boolean.

        # Get what to verify (array, regex or code), evt. an info string, and filetests
        my $verify          =   $opt_config->{$option}->{'valid'}
            if exists $opt_config->{$option}->{'valid'};
        my $verify_keys     =   $opt_config->{$option}->{'valid_keys'}
            if exists $opt_config->{$option}->{'valid_keys'};
        my $verify_values   =   $opt_config->{$option}->{'valid_values'}
            if exists $opt_config->{$option}->{'valid_values'};
        my $info            =   $opt_config->{$option}->{'info'}
            if exists $opt_config->{$option}->{'info'};
        my $filetest_string =   $opt_config->{$option}->{'filetest'}
            if exists $opt_config->{$option}->{'filetest'};

        # valid_keys and valid_values are only valid with desttype '%'
        if (
                ( $verify_keys || $verify_values )
            &&  ( $opt_config->{$option}->{'desttype'} ne '%' )
            ){
            $err_msg .= $pr_error . "Config error of option '$option'.\n"
                    .   $pr_error . "Wrong stanza used for destination type.\n"
                    .   $pr_info  . "You either specified the stanza 'valid_keys' or 'valid_values',\n"
                    .   $pr_info  . "but this is only possible together with 'desttype' => '%'  (hash).\n";
            next VERIFY_OPTION;
        };

        #-------------------------
        # If we have filetests, do them here
        if ( $filetest_string ){

            my @files;  # Gather all files here.
            if ( ! ref $option_hash->{$option} ){               # Files can come as a string value ...
                push @files, $option_hash->{$option};
            }
            elsif ( ref $option_hash->{$option} eq 'ARRAY' ){   # ... or more than one in an array ...
                push @files, @{ $option_hash->{$option} };
            }
            elsif ( ref $option_hash->{$option} eq 'HASH' ){    # ... or as values from a hash
                push @files, values %{ $option_hash->{$option} };
            }
            else {                                              # else we have nothing.
                @files = qw();
            };

            if ( @files ){
                my $err_msg_filetest;
                FILE_TEST:
                foreach my $file ( @files ){
                    # Clean file name. We have to handle also things like:
                    # /bin/blah -abc  -blubb, so split on whitespace and take the first thing.
                    my @file_parts  =   split /\s+/, $file;
                    my $file_name   =   $file_parts[0];
                    my $is_negated;
                    TEST_CHAR:
                    foreach my $char ( split //, $filetest_string ){
                        # mark next character as negated if '!' found
                        if ( $char eq '!' ){
                            $is_negated = 1;
                            next TEST_CHAR;
                        };
                        next TEST_CHAR if $char =~ /[\s+-]/;

                        # form test: print "success" if ! -TEST_CHAR FILE or print "success" if -TEST_CHAR FILE
                        # execute it and see if it was successful
                        my $test    =   $is_negated ?   'print "success" if ! -' . $char . ' "' . $file_name . '"'
                                    :   'print "success" if -' . $char . ' "' . $file_name . '"';
                        my $result = eval { `perl -e '$test'` };
                        if (  $@  || $result !~ /success/ ){
                            $err_msg_filetest .= $pr_error . "File '$file_name':\n";
                            if ( $is_negated ){
                                $err_msg_filetest .= $pr_error . "Expected: ! -$char, found: ";
                                ( my $inv_string = $failed_file_test{ $char } ) =~ s/\s+ (?:no|not) \s+/ /xms;
                                $err_msg_filetest .= $inv_string . "\n";
                            }
                            else {
                                $err_msg_filetest .= $pr_error . "Expected:   -$char, found: " . $failed_file_test{ $char } . "\n";
                            };
                        };
                        # Here we found a valid character, so turn off negating.
                        $is_negated = undef if $is_negated;
                    };
                };
                if ( $err_msg_filetest ){
                    $err_msg .= $pr_error . "Input for option '$option' did not pass validation.\n"
                            .   $err_msg_filetest;
                };
            }
            else {
                $err_msg .= $pr_error . "Config error of option '$option'.\n"
                        .   $pr_error . "The 'filetest' stanza is only allowed with options that take a string or array.\n"
            };
        };


        #-------------------------
        # Gather in a hashref what to verify.
        my $verification_of  = {};
        if ( $verify ){
            $verification_of->{'valid'}->{'validation'}  =   $verify;
            $verification_of->{'valid'}->{'to_validate'} =   $option_hash->{$option};
        };

        if ( $verify_keys ){
            $verification_of->{'valid_keys'}->{'validation'}  =   $verify_keys;
            @{ $verification_of->{'valid_keys'}->{'to_validate'} } =   keys %{ $option_hash->{$option} };
        };

        if ( $verify_values ){
            $verification_of->{'valid_values'}->{'validation'}  =   $verify_values;
            @{ $verification_of->{'valid_values'}->{'to_validate'} } =   values %{ $option_hash->{$option} };
        };

        #-------------------------
        # Now check every existing 'valid*' stanza
        foreach my $stanza ( keys %$verification_of ){
            my $validation  =   $verification_of->{$stanza}->{'validation'};
            my $to_validate =   $verification_of->{$stanza}->{'to_validate'};
            my $input_string;   # Create string for error messages
            my $input_ref   =   ref $to_validate;
            if ( $input_ref eq 'ARRAY' ){
                $input_string   =   $pr_info . join( ', ', @$to_validate ) . "\n";
            }
            elsif ( $input_ref eq 'HASH' ){
                my $string  = Data::Dumper->Dump( [ $to_validate ], [ $option ]);
                my @lines   = split /\n/, $string;
                $input_string .= $pr_info . $_ . "\n" for @lines;
            }
            else {
                $input_string   =   $pr_info . $to_validate . "\n";
            };
            
            # Branch out by possible validation types
            VERIFY_OPTION_TYPE:
            for ( ref $validation ){
                /\AARRAY\z/ and
                do {
                    if (
                                exists $opt_config->{$option}->{'desttype'}
                            &&  $opt_config->{$option}->{'desttype'} eq '%'             # Error on hash option
                            &&  ! grep { $stanza eq $_ } qw(valid_keys valid_values)    # unless keys or values are tested.
                        ){
                        $err_msg .= $pr_error . "Config error of option '$option'.\n"
                                .   $pr_error . "Wrong validation type specified for option '$option'.\n"
                                .   $pr_info  . "'$option' is marked to store its values into a hash\n"
                                .   $pr_info  . "('desttype' => '%'), and you asked to validate against a list\n"
                                .   $pr_info  . "('valid' => [ .. ]), which is not possible.\n"
                                .   $pr_info  . "For hash destinated options either you must specify 'valid' as a code ref,\n"
                                .   $pr_info  . "or you use the 'valid_keys' or 'valid_values' stanzas to verify\n"
                                .   $pr_info  . "keys and values separately with a list, regular expression or code.\n";
                    }
                    else{
                        if ( ! compare_list( 'all', $validation, $to_validate ) ){
                            $err_msg .= $pr_error . "Input for option '$option' did not pass validation.\n"
                                    .   $pr_info  . "Expected in stanza '$stanza' one of:\n"
                                    .   $pr_info  . join(', ', @$validation ) . "\n"
                                    .   $pr_info  . "Input was:\n" . $input_string;
                            $err_msg .= $pr_info  . $info . "\n" if $info;
                        };
                    }
                    last VERIFY_OPTION_TYPE;
                };


                /\ARegexp\z/ and
                do {
                    if (
                                exists $opt_config->{$option}->{'desttype'}
                            &&  $opt_config->{$option}->{'desttype'} eq '%'             # Error on hash option
                            &&  ! grep { $stanza eq $_ } qw(valid_keys valid_values)    # unless keys or values are tested.
                        ){
                        $err_msg .= $pr_error . "Config error of option '$option'.\n"
                                .   $pr_error . "Wrong validation type specified for option '$option'.\n"
                                .   $pr_info  . "'$option' is marked to store its values into a hash\n"
                                .   $pr_info  . "('desttype' => '%'), and you asked to validate against a regular\n"
                                .   $pr_info  . "expression ('valid' => qr/../), which is not possible.\n"
                                .   $pr_info  . "For hash destinated options either you must specify the 'valid'"
                                .   $pr_info  . "stanza as a code ref,\n"
                                .   $pr_info  . "or you use the 'valid_keys' or 'valid_values' stanzas to verify\n"
                                .   $pr_info  . "keys and values separately with a list, regular expression or code.\n"
                    }
                    else {
                        my @candidates  =   ref $to_validate eq 'ARRAY' ?  @$to_validate
                                        :   ( $to_validate );

                        foreach my $candidate ( @candidates ){
                            if (  $candidate !~ $validation ){
                                $err_msg .= $pr_error . "Input for option '$option' did not pass validation.\n"
                                        .   $pr_info .  "Expected in stanza '$stanza' to match: '$validation'\n"
                                        .   $pr_info .  "Input was: '$candidate'\n";
                                $err_msg .= $pr_info  . $info . "\n" if $info;
                            };
                        };
                    }
                    last VERIFY_OPTION_TYPE;
                };

                /\ACODE\z/ and
                do {
                    unless ( &$validation( $to_validate ) ){
                        $err_msg .= $pr_error . "Input for option '$option' did not pass validation.\n"
                                .   $pr_info .  "The testing subroutine for '$option' in the option configuration\n"
                                .   $pr_info .  "returned false in stanza '$stanza' on following input:\n"
                                . $input_string;
                        $err_msg .= $pr_info  . $info . "\n" if $info;
                    };
                    last VERIFY_OPTION_TYPE;
                };

                $err_msg .= $pr_error . "Config error of option '$option'.\n"
                        .   $pr_error . "Invalid input for stanza '$stanza': '$validation'.\n"
                        .   $pr_info  . "This stanza must be either an arrayref, a regular expression\n"
                        .   $pr_info  . "or a coderef ('ref' must return 'ARRAY', 'Regexp' or 'CODE'). Like this:\n"
                        .   $pr_info  . "   ..\n"
                        .   $pr_info  . "   valid => [ qw( foo bar baz) ],  # or\n"
                        .   $pr_info  . "   valid => qr/blah/,              # or\n"
                        .   $pr_info  . '   valid => \&mycode,' . "\n"
                        .   $pr_info  . "   ..\n";
            };
        };
    };

    #-------------------------
    # Croak out error messages, if any.
    if ( $err_msg ){
        croak $pr_error . "$this_func $func_ver: Found errors in option configuration for $this_name.\n"
            . $err_msg
            . $pr_info  . "Please look up the manpage or help ($this_name --help|-h|-?|--man|-M).\n";
    };

    return $option_hash;
};
#@build_and_verify_opthash_end
#@STANDARD_FUNCTIONS_END
#=========================

#=========================
#@ADDITIONAL_FUNCTIONS_BEGIN

#@slurp_begin
sub slurp {
    # Usage     :   my $scalar = slurp( FILE );
    #               my @array = slurp( FILEHANDLE );
    #               my VARIABLE = slurp( FILE|FILEHANDLE,
    #                               {
    #                                   chomp   =>  BOOLEAN,
    #                                   prefix  =>  STRING,
    #                                   nokill  =>  BOOLEAN,
    #                               } );
    # Purpose   :   Read in content of a file or a filehandle
    # Incoming  :   FILE or FILEHANDLE, if needed a hashref to
    #               control the behaviour:
    #               chomp   :   Automatically chomps each line.
    #               prefix  :   Prefixes each line with STRING.
    #               nokill  :   If an error occurs, prints the
    #                           error messages and returns false
    #                           instead of croaking out the error.
    #
    # Outgoing  :   in list context: array of lines with file content
    #               in scalar context: the text of the file in one scalar
    # Needs     :   IO::File
    # Provides  :
    # Description:
    #
    # CAVEAT:
    #
    # EXAMPLE:
    #

    my @incoming    =   @_;                     # just as a starting suggestion ...
    my $this_func   =   (caller(0))[3];         # E.g 'main::slurp' for error messages
    my @pack_parts  =   split /::/, $this_func; # Split on double colon.
    my $func_name   =   pop @pack_parts;        # For error messages
    my $func_ver    =   '1.0';                  # Version of slurp

    my %options_of  = (
        'chomp'     =>  qr/\A\w+\z/xms,
        'prefix'    =>  qr/\A[\p{IsAlnum}\p{IsPunct}\t\s]+\z/xms,
        'nokill'    =>  qr/\A\w+\z/xms,,
    );

    my $usage =
        $pr_info . 'Usage     :   my $scalar = slurp( FILE );'                      . "\n"
      . $pr_info . '              my @array = slurp( FILEHANDLE );'                 . "\n"
      . $pr_info . '              my VARIABLE = slurp( FILE|FILEHANDLE,'            . "\n"
      . $pr_info . '                              {'                                . "\n"
      . $pr_info . '                                  chomp   =>  BOOLEAN,'         . "\n"
      . $pr_info . '                                  prefix  =>  STRING,'          . "\n"
      . $pr_info . '                                  nokill  =>  BOOLEAN,'         . "\n"
      . $pr_info . '                              } );'                             . "\n"
      . $pr_info . '              chomp   :   Automatically chomps each line.'      . "\n"
      . $pr_info . '              prefix  :   Prefixes each line with STRING.'      . "\n"
      . $pr_info . '              nokill  :   If an error occurs, prints the'       . "\n"
      . $pr_info . '                          error messages and returns false'     . "\n"
      . $pr_info . '                          instead of croaking out the error.'   . "\n";

    # Unpack variables of @incoming here.
    my $candidate   =   shift @incoming;
    my $options     =   shift @incoming;

    # Type: file or filehandle of type IO::File
    my $cand_type   = undef;

    # Determine context and output type.
    my $out_type;
    $out_type   =   'array' if wantarray;
    $out_type   =   'scalar' unless wantarray;
    $out_type   =   'void'  unless defined wantarray;

    my $return_type = 'CROAK';
    sub slurp_return {
        my @incoming = @_;
        my $mode    = shift @incoming;
        my $string  = shift @incoming;

        if ( $mode eq 'RETURN' ){
            warn $string;
            return;
        }
        elsif ( $mode eq 'CROAK' ){
            croak $string;
        }
        else {
            croak "slurp: Internal error: other than 'RETURN' or 'CROAK' in slurp_return.\n"
        };
    };

    # Prove your incoming values and prerequisites here
    #@Error_handling_begin
    # Proceed options first, because we have to know if we croak or return.
    if ( $options ){
        if ( ref $options ne 'HASH' ){
            croak   $pr_error   . "$func_name $func_ver: Incoming options not provided as hashref.\n" . $usage;
        };

        # Test each option.
        my @valid_options = keys %options_of;
        my $err_msg;
        foreach my $opt_candidate ( keys %$options ){
            if ( ! grep { $_ eq $opt_candidate } @valid_options ){
                $err_msg .= $pr_error . "Invalid option: '$opt_candidate'\n";
            };

            my $opt_value   =   $options->{$opt_candidate};
            my $opt_cond    =   $options_of{ $opt_candidate };
            if ( ref $opt_cond eq 'Regexp' && $opt_value !~ $opt_cond ){
                $err_msg .= $pr_error . "Option '$opt_candidate' did not pass verification:\n"
                        .   $pr_info  . "'$opt_value' does not match '$opt_cond'\n";
            };
            if ( $options->{'nokill'} ){
                $return_type = 'RETURN';
            };
        };

        if ( $err_msg ){
            slurp_return( $return_type, $pr_error . "$func_name $func_ver: Found errors in options:\n" . $err_msg . $usage );
            return;
        };
    };

    if ( ! $candidate ){
        slurp_return( $return_type, $pr_error . "$func_name $func_ver: No file or filehandle specified => Quitting.\n" . $usage);
        return;
    };

    if ( $out_type  eq 'void' ){
        slurp_return( $return_type, $pr_error . "$func_name $func_ver: You tried to call $func_name in void context, which is not allowed.\n" . $usage);
    };

    $cand_type      =   ref $candidate eq 'IO::File'    ?   'handle'
                    :   -f $candidate                   ?   'file'
                    :   'invalid';

    if ( $cand_type eq 'invalid' ){
        slurp_return( $return_type, $pr_error . "$func_name $func_ver: '$candidate': Incoming type is no file and no 'IO::File' object => Quitting.\n" . $usage);
        return;
    };

    if ( $cand_type eq 'file' && ! -r $candidate ){
        slurp_return( $return_type, $pr_error . "$func_name $func_ver: Incoming file is not readable: '$candidate'.\n" . $usage);
        return;
    };

    if ( $cand_type eq 'handle' && $candidate->error ){
        slurp_return( $return_type, $pr_error . "$func_name $func_ver: Incoming filehandle is not readable or invalid\n" . $usage);
        return;
    };

    #@Error_handling_end

    # Get filehandle from file or take incoming filehandle.
    # Return output dependent on output type;
    my $cand_fh;
    if ( $cand_type eq 'file' ){
        $cand_fh = IO::File->new("< $candidate") or
        do {
            slurp_return( $return_type, $pr_error . "$func_name $func_ver: Could not open file for reading: '$candidate'\n$!");
            return;
        };
    }
    else {
        $cand_fh = $candidate;  
    };

    if ( $out_type eq 'scalar' ){
        my $text = do { local $/; <$cand_fh> };
        if ( $options->{'chomp'} ){
            $text =~ s/[\n]//g;
        };

        if ( my $prefix = $options->{'prefix'} ){
            $text =~ s/\A/$prefix/;
            $text =~ s/[\n]/\n$prefix/g;
        };
        return $text;
    };

    if ( $out_type eq 'array' ){
        my @text = <$cand_fh>;
        if ( $options->{'chomp'} ){
            foreach my $line ( @text ){
                chomp $line;
            };
        };

        if ( my $prefix = $options->{'prefix'} ){
            foreach my $line ( @text ){
                $line = $prefix . $line;
            };
        };
        return @text;
    };

    # If we are here, something went wrong with the out_type;
    slurp_return( $return_type, $pr_error . "$func_name $func_ver: Internal error: Did not expect to get here having out_type '$out_type'\n");
    return;
};
#@slurp_end

#@test_connection_begin
sub test_connection {
    # Usage : test_connection (
    #                           {   server      => \@serverlist,
    #                                       user        => USER,                    # connect as user USER
    #                                       verbosity   => 0|1,                     # default: 0 (off)
    #                                       out         => 'OUTVALUE',              # default: 'ok_all'
    #                                       timeout     => TIMEOUT_IN_SECS,         # default: 5
    #                                       ssh_path    => '/path/to/ssh',          # default: tries to find it
    #                                       ssh_args    => {ARG => 'VALUE'},    # Optional arguments of ssh
    #                           }
    #                         )
    #
    # Incoming values   : A hashref whith following keys:
    #                     -- server: an array ref to servers (hopefully).
    #                           This is the MINIMUM to provide to make this sub work.
    #                     -- user:  Take user USER to connect to the server(s).
    #                     -- verbosity: switches on verbosity. Defaults to off if not set.
    #                     -- out: defines the kind of output you get.
    #                           possible values for OUTVALUE:
    #                           ok          : returns the number of reachable servers in @serverlist
    #                           ok_all      : returns TRUE (1) if all of @serverlist are reachable
    #                           ok_name     : returns an array of the names of reachable servers in @serverlist
    #                           notok       : returns the number of unreachable servers in @serverlist
    #                           notok_all   : returns TRUE (1) if NO server of @serverlist is reachable
    #                           notok_name  : returns an array of the names of unreachable servers in @serverlist
    #                           all         : returns an array with 'server OK', 'server NOT_OK' for all
    #                                         servers in @serverlist.
    #                           Default is 'ok_all'.
    #
    #                     -- timeout: defines the timeout for each try in seconds.
    #                        Default is 5 seconds. Minimum is 2 seconds
    #                     -- ssh_path : define an alternate path to the ssh binary
    #                     -- ssh_args : hashref with optional ssh settings, see also manpage of ssh at
    #                                   http://www.openssh.org .
    #                                   They have to be set like this:
    #                                   { Compression => 'yes', ..}
    #
    # Outgoing results  : Depends on what you choose for 'out'
    # Prerequisites     : Module Carp, system commands: which, date, host
    # Purpose           : Test the connection to a list of servers by ssh.
    # Description:
    #
    #
    # Example:
    #   Use best in a conditional statement like:
    #       if ( test_connection( server => \@servers)){ ... }
    #   Or take information out of it like so:
    #       my @reachables = test_connection( server => \@serverlist, out => 'ok_name' );
    #   @reachables then will contain the names of the reached servers.
    #   Or get a status of all servers.
    #   my @all = test_connection( server => \@serverlist, out => 'all' );
    #   @all will contain sth. like: 'server1 ok', 'server2 not_ok'
    my $defaults    =   {
        verbosity   =>  0,          # set to 'off'
        server      =>  undef,
        user        =>  undef,
        ssh_path    =>  undef,
        out         =>  'ok_all',   # true if all server succeed
        timeout     =>  5,          # timeout for connection
        ssh_args    =>  undef,      # optional arguments to ssh
    };

    my @valid_keys = keys %$defaults;

    my $default_ssh_opts =  {
        ConnectTimeout              =>  10,             # Timeout if server down/unreachable
        NumberOfPasswordPrompts     =>  0,              # No password prompting
        BatchMode                   =>  'yes',          # passphrase/password querying will be disabled
        #StrictHostKeyChecking       =>  'no',           # Not only known hosts
        StrictHostKeyChecking       =>  'yes',          # Only known hosts
        PasswordAuthentication      =>  'no',           # Skip password auth
        PreferredAuthentications    =>  'publickey',    # Check only valid keys
    };


    my $this_function   =   (caller(0))[3];
    my $func_version    =   '2.1';
    my $SSH;
    my @valid_out       =   qw( ok  ok_all  ok_name notok   notok_all   notok_name all );
    my @system_cmds     =   qw( which   date    host );
    my $ssh_args        =   {};
    my $ssh_opt_string  =   '';

    # Error handling begin
    # Test input
    my $input           =   shift @_;
    if ( ref $input ne 'HASH' ){
        croak $pr_error,"$this_function: Expected a hashref as input.\n";
    };
    my %incoming        =   ( %$defaults, %$input ) ;         # get incoming, overwrite defaults

    # Test on valid keys
    my @invalid_keys;
    foreach my $key ( keys %incoming ){
        push @invalid_keys, $key unless grep { $_ eq $key } @valid_keys;
    };
    if ( @invalid_keys ){
        croak $pr_error , "$this_function: Invalid key(s) specified: '@invalid_keys'.";
    };

    # Do we have our system commands?
    my @failed_cmds = qw();
    foreach my $cmd ( @system_cmds ){
        push @failed_cmds, $cmd if system( "which $cmd > /dev/null 2>&1");
    };
    if ( @failed_cmds ){
        croak $pr_error,"$this_function: Could not find following system commands: '@failed_cmds'.\n";
    };

    # Test incoming ssh
    if ( $incoming{'ssh_path'} ){           # If an executable is specified
        $SSH = $incoming{'ssh_path'};       # Take it
        if ( (! -e $SSH) || (! -x $SSH) ){  # but look, if it exists and can be run
            croak $pr_error,"$this_function: No ssh command found or not executable at '$incoming{'ssh_path'}'.\n";
        };
    }
    else {                                  # Else try to find the binary by system 'which'
        unless ( system( 'which ssh > /dev/null 2>&1') ){
            $SSH = `which ssh`;             # Here's our ssh
            chomp( $SSH );
        };
        unless ( $SSH ){                    # Go out if it failed.
            croak $pr_error,"$this_function: No ssh command found.\n";
            return;
        };
    };

    # Test serverlist
    if ( ! $incoming{'server'} ) {
        croak( $pr_error, "$this_function: No server specified.\n");
    };

    if ( ref $incoming{'server'} && (ref $incoming{'server'} ne 'ARRAY') ){
        croak( $pr_error, "$this_function: Server has to be either an arrayref or no reference at all.\n");
    };

    # Test 'out' value
    if ( ! grep { $_ eq $incoming{'out'} } @valid_out ){
        croak $pr_error . "$this_function: Invalid out value: '$incoming{'access'}'."
            .   " Valid values are: @valid_out.\n";
    };

    # Test timeout
    unless ( $incoming{'timeout'} =~ /(\d+)/ ){
        croak $pr_error . "$this_function: Invalid value for timeout: '$incoming{'timeout'}'.\n"
        .     $pr_error . "$this_function: Must be an integer\n";
    };

    # Test and set ssh options
    # Merge settings or take defaults.
    my %ssh_args_to_set;
    if ( $incoming{'ssh_args'} ){
        if ( ref $incoming{'ssh_args'} ne 'HASH' ){
            croak   $pr_error . "$this_function: 'ssh_args' is not a hashref: '" . $incoming{'ssh_args'} . "'.\n";
        };
        # Merge old and new values
        %ssh_args_to_set = ( %$default_ssh_opts, %{ $incoming{'ssh_args'} } );
    }
    else {
        %ssh_args_to_set    =   %$default_ssh_opts;
    };

    # If timeout is greater than ConnectTimeout, set ConnectTimeout to timeout
    $ssh_args_to_set{'ConnectTimeout'} = $incoming{'timeout'} if $incoming{'timeout'} > $ssh_args_to_set{'ConnectTimeout'};

    while ( my ($key, $value) = each %ssh_args_to_set ) {
        $ssh_opt_string .= "-o '$key $value' ";        
    };
    # Error handling end


    $incoming{'timeout'} = 2 if $incoming{'timeout'} < 3;   # Set minimum to 2 seconds
    my @servers;
    @servers            =   @{ $incoming{'server'} } if     ref $incoming{'server'} eq 'ARRAY';
    @servers            =   ( $incoming{'server'} ) unless  ref $incoming{'server'} eq 'ARRAY';
    @servers            =   uniq( @servers );   # uniq them
    my $verbosity       =   $incoming{'verbosity'};
    my $timeout         =   $incoming{'timeout'};
    my $user_string =   $incoming{'user'}   ?   $incoming{'user'} . '@' :   ''; # 'USER@' or nothing
    my $connection_of   =   {};                 # store the connection infos here

    sub ssh_test {
        my ( $server, $verbosity, $SSH, $timeout, $connection_of, $ssh_opt_string, $user_string ) = @_;
        my $this_function   =   (caller(0))[3]; # for error messages
        my $cmd = "host $server >/dev/null 2>&1\n"
            . q#if [[ $? != 0 ]]; then# . "\n"
            . "    exit 10\n"
            . "fi\n"
            . "$SSH "
            . $ssh_opt_string
            . $user_string
            . $server
            . q# uname > /dev/null 2>&1# . "\n"
            ;

        if ($verbosity ) {
            print $pr_info, "Test ssh to $server ... ";
        };

        my $rc;
        eval {
            local $SIG{ALRM} = sub { die "timeout" };
            alarm( $timeout );      # Enable timeout
            $rc = system($cmd);     # Run test
            alarm( 0 );             # Disable alarm
        };

        # If you eval'd an error ...
        if ( $@ ){
            $rc = 11 if $@ =~ /timeout/;
        }
        else {
            alarm( 0 );             # clear a might still-pending alarm
        };
        
        $rc = 12 if ! defined $rc;  # Undefined value means timeout
                                    # $rc didn't get a chance to get a value
        if ( $rc == 0 ){
            $connection_of->{$server} = 1;
            print $pr_ok_end . "\n" if $verbosity;
        }
        else {
            $connection_of->{$server} = undef;
            print $pr_warning , "FAILED (within $timeout secs, without passwd. auth.)\n"
                if $verbosity;
        };
    };


    # Test connection
    my ( $nof_ok, @ok_name, $nof_notok, @notok_name, @all );
    TEST_CONNECTION:
    foreach my $server ( @servers ){
        ssh_test($server, $verbosity, $SSH, $timeout, $connection_of, $ssh_opt_string, $user_string);

        $nof_ok++       if      $connection_of->{$server};
        $nof_notok++    unless  $connection_of->{$server};
        push @ok_name, $server      if      $connection_of->{$server};
        push @notok_name, $server   unless  $connection_of->{$server};
        my $status  =   $connection_of->{$server}   ?   'OK'    :   'NOT_OK';
        push @all, "$server $status";
    };

    # Set counts to 0 if nothing found.
    $nof_ok ||= 0;
    $nof_notok ||= 0;

    # Output handling
    for ( $incoming{'out'} ){
        /\Aok\z/ and
            do {    # number of reachable servers in @serverlist
                return $nof_ok;
                last;
            };

        /\Aok_all\z/ and
            do {    # true if all servers are reachable
                my $ok_count    = scalar( @servers );
                return 1 if $ok_count == $nof_ok;
                return   if $ok_count != $nof_ok;
                last;
            };

        /\Aok_name\z/ and
            do {    # returns an array of reachable server names
                return @ok_name;
                last;
            };

        /\Anotok\z/ and
            do {    # number of unreachable servers in @serverlist
                return $nof_notok;
                last;
            };

        /\Anotok_all\z/ and
            do {    # returns true if NO server of @serverlist is reachable
                my $notok_expected = scalar( @servers );
                return 1 if $notok_expected == $nof_notok;
                return   if $notok_expected != $nof_notok;
                last;
            };

        /\Anotok_name\z/ and
            do {    # returns an array of unreachable server names
                return @notok_name;
                last;
            };

        /\Aall\z/ and
            do {# returns 'server:OK' or 'server:NOT_OK' for each in list
                return @all;
                last;
            };

        croak( $pr_error, "$this_function: At this point I don't know how to output '$incoming{'out'}'\n");
        last;
    };
};
#@test_connection_end
#@ADDITIONAL_FUNCTIONS_END
#=========================
#@Functions_end
#================


#================
#@Validate_input_begin
#@Validate_input_end
#================


#================
#@MAIN_test_ssh_access_begin
print "$DESCRIPTION" if $option_hash->{'verbose'};
# Get server list
my @serverlist;
my $seen_servers ={};                                   # Seen servers
if ( exists $option_hash->{'list'} ){                   # If we have one or more files with server names
    foreach my $file ( @{ $option_hash->{'list'} } ){   # Examine each file
        my @candidates = slurp( $file, {'chomp' => 1} );
        foreach my $candidate ( @candidates ){          # Examine each line
            next if $candidate =~ /\A \s* \#/xms;       # Skip comment.
            if ( $candidate =~ /\A \s* ([\w\._-]+)/ ){  # Take first word
                $candidate = $1;
            };
            next if $seen_servers->{$candidate};        # Skip duplicates
            push @serverlist, $candidate;               # Push to serverlist
            $seen_servers->{$candidate}++;              # Mark as seen
        };
    }
};

if ( @incoming ){                                       # If we have command line input
    foreach my $candidate ( @incoming ){                # Get them.
        next if $seen_servers->{$candidate};            # Skip duplicates
        push @serverlist, $candidate;                   # Push to serverlist
        $seen_servers->{$candidate}++;                  # Mark as seen
    };
};

unless ( @serverlist ){
    print $pr_error . "No servers left to test. Exiting.\n";
    exit 1;
};

# Build hashref for sub test_connection
#-------------------------
#@DAIMLER_SPECIAL:
# Convert serverlist into longname servers
# Sort out servers that cant't be found with 'longname'
my @tmp_serverlist;
foreach my $server ( @serverlist ){
    my $lname = `$longname $server`;                    # Get long name
    if ( $? ){                                          # Skip if no long name found.
        print $pr_warning . "Could not get long name for '$server' => Skipping.\n";
        next;
    };
    chomp $lname;                                       # Strip off newline of longname
    push @tmp_serverlist, $lname;                       # Here we can safely add this server
};
unless ( @tmp_serverlist ){                             # No servers left - no kiss
    print $pr_error  . "No servers left to test. Exiting.\n";
    exit 1;
};
@serverlist = @tmp_serverlist;                          # Resulting is new server list
#-------------------------


my $args_ref = {    # These have default values, so are always set:
    server      =>  \@serverlist,
    user        =>  $option_hash->{'user'},
    out         =>  $option_hash->{'rtype'},
    timeout     =>  $option_hash->{'timeout'},
};

# These could be set additionally
$args_ref->{'verbosity'} = 1 if exists $option_hash->{'verbose'};
$args_ref->{'ssh_path'} =   $option_hash->{'ssh_path'}  if exists $option_hash->{'ssh_path'};
$args_ref->{'ssh_args'} =   $option_hash->{'option'}    if exists $option_hash->{'option'};

# Return and exit depending on return value.
#-------------------------
#ok          : returns the number of reachable servers in serverlist\n"
#ok_all      : returns TRUE (0) if all servers are reachable (this is the default)\n."
#ok_name     : returns the names of reachable servers out of serverlist. One line each.\n"
#notok       : returns the number of unreachable servers in serverlist.\n"
#notok_all   : returns TRUE (0) if NO server of serverlist is reachable.\n"
#notok_name  : returns the names of unreachable servers in serverlist. One line each."

my $rc;
TEST_RETVAL:
for ( $option_hash->{'rtype'} ){
    /\A(?:ok|notok)\z/xms and
    do {
        my $result = test_connection( $args_ref );
        print $result;
        $rc = 0;
        last TEST_RETVAL;
    };

    /\A(?:ok_all|notok_all)\z/xms and
    do {
        $rc = test_connection( $args_ref )  ?   0   :   1;
        last TEST_RETVAL;
    };

    /\A(?:ok_name|notok_name|all)\z/xms and
    do {
        my @result = test_connection( $args_ref );
        print "$_\n" for @result;
        $rc = 0;
        last TEST_RETVAL;
    };

    print $pr_error . "Can not handle unknown return type:" . $option_hash->{'rtype'} . "\n";
    exit 1;
};

exit $rc
#MAIN_test_ssh_access_end
#================


#================
# End of source code
# After __END__ follows the documentation,
# viewed by typing 'perldoc test_ssh_access'
__END__

=pod

=head1 test_ssh_access

Tests if one or more servers can be reached via 'ssh'
B<< without password >>.

=head1 SYNOPSIS

 Simple:
 test_ssh_access SERVER [SERVER ..]
 test_ssh_access -l FILE_WITH_SERVERNAMES

 Help:
 test_ssh_access --help|-h|--man|-M

 Advanced:
 test_ssh_access
    -l FILE             : Take server names of FILE
                          First name per line, skip
                          comments beginning with '#'.
                          Can be specified multiple times.

    -o SSH_OPTION=VALUE : Add ssh option for connect.
                          Can be specified multiple times.

    -t TIMEOUT_SECS     : Set timeout in seconds other than default (5 seconds)
    -r RETURNTYPE       : Set return type other than default: 'ok_all'
                          Valid return types are:
                          ok          : return count of reachable servers.
                          ok_all      : exit 0 if all servers reachable, 1 otherwise.
                          ok_name     : return names of reachable servers.
                          notok       : return count of unreachable servers.
                          notok_all   : exit 0 if NO server reachable, 1 otherwise,
                          notok_name  : return names of unreachable servers.
                          all         : return 'SERVER STATUS' line for each server,
                                        where STATUS is one of 'OK' or 'NOT_OK'.
    -u USER             : Connect as USER instead of executing user.
    -s PATH_TO_SSH-BIN  : Alternate path to ssh binary
    -v                  : verbose output
    SERVER [SERVER ..]  : Test SERVER [SERVER ..]

=head1 DESCRIPTION

This script takes as input either list(s) with server names in files or
server names or both, uniques them and runs a test against the resulting
serverlist to see if an ssh connection can be established without
password prompting.

The output and return code depends on the return type (option -r).
B<< ok_all >> and B<< notok_all >> exit intentionally with 0 on success
and 1 on failure.
All other print out their result and exit with 0.

=head1 OPTIONS

=head2 --list|-l FILE

Takes server names of FILE. It takes every first word of each line and
skips lines beginning with '#'.
This option can be specified multiple times.
The resulting list is uniqued.

=head2 --option|-o SSH_OPTION=VALUE

Add ssh option for connect. This option can be specified multiple times.
These ssh options are in effect by default:

 ConnectTimeout           : 10         # Timeout if server down/unreachable
 NumberOfPasswordPrompts  : 0          # No password prompting
 StrictHostKeyChecking    : yes        # Only known hosts
 PasswordAuthentication   : no         # Skip password auth
 PreferredAuthentications : publickey  # Check only valid keys

=head2 --timeout|-t TIMEOUT

Specify a timeout in seconds. It must be '5' at minimum. Default is 5 seconds.

=head2 --rtype|-r RETURNTYPE

Specify other return type than default: 'ok_all'

 Valid return types:
 ok          : returns the number of reachable servers in serverlist.
 ok_all      : returns TRUE (0) if all servers are reachable (this is the default).
 ok_name     : returns the names of reachable servers out of serverlist. One line each.
 notok       : returns the number of unreachable servers in serverlist.
 notok_all   : returns TRUE (0) if NO server of serverlist is reachable.
 notok_name  : returns the names of unreachable servers in serverlist. One line each.
 all         : returns 'SERVER STATUS' line for each server in serverlist, where
               STATUS is one of 'OK' or 'NOT_OK'.

=head2 --user|-u USER

Connect as USER instead of executing user.

=head2 --verbose|-v

Verbose output.
Mutual exclusive with '--quiet|-q'.

=head2 --quiet|-q

Do as little output as possible. Mutual exclusive with '--verbose|-v'.

=head2 --help|-h|-?

Print out help and exit

=head2 --man|-M

Print out this manpage and exit

=head2 --version|-V

Print out version and exit.

=head1 EXAMPLES

=head2 Simple test if servers are reachable

 # test_ssh_access i050blfow374 i050alsta272 i050alpa1172
 # echo $?
 # 0

=head2 Simple verbose

 # test_ssh_access -v i050blfow374 i050alsta272 i050alpa1172
 # INFO   :Test ssh to i050blfow374 ... OK.
 # INFO   :Test ssh to i050alsta272 ... OK.
 # INFO   :Test ssh to i050alpa1172 ... OK.
 # echo $?
 # 0

=head2 Get state of all tested servers in file 'ssh_testlist'

 # test_ssh_access -l ssh_testlist -r all
 # i050blfow374 OK
 # i050blisb286 OK
 # i050ilpai285 OK
 # i054almob818 NOT_OK
 # s050alwa1156 OK
 # s050m009 NOT_OK
 # s054allgt020 NOT_OK
 # swoealvpe001 NOT_OK
 # t050almqs169 OK
 # echo $?
 # 0


=head1 ENVIRONMENT

=head2 DEPENDENCIES

 This program needs following Modules which either are
 located within the standard distribution or availlable
 in CPAN:

 Carp
 Getopt::Long 
 Term::ANSIColor
 IO::File
 Pod::Usage

 System commands used:
    which, date, host, ssh

=head1 CAVEAT

If the servers can not be resolved with the 'host' command it
will be conidered as unreachable.

=head1 SEE ALSO

ssh, host

=head1 AUTHOR

 vindani 

=head1 (DISCLAIMER OF ) WARRANTY

 test_ssh_access COMES WITHOUT WARRANTY OF ANY KIND,
 EITHER EXPRESSED OR IMPLIED, INCLUDING, MARST NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 PURPOSE.
 THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
 PROGRAM IS WITH YOU.
 SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME
 THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014 by Vincenzo Daniele, Daniele Consulting

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.2 or,
at your option, any later version of Perl 5 you may have available.

=cut

