http://www.perlmonks.org?node_id=1059498


in reply to RFC: beginner level script improvement

The revised version of the script is completed. I looked into the documentation that all of you provided and added/changed loads of stuff.

Thank all of you for your valued feedback and pointers. Obviously additional feedback will be highly aprecciated.

main script (still a work in progress, some stuff will be modified as soon as I know how, as seen in the respective comments) There is a lot of printing for now since it's still an alpha and I prefer too much feedback over too little.

#!/usr/bin/perl -w use strict; use File::Find; use Cwd 'abs_path'; BEGIN { ##Discover and use required modules automatically at compile t +ime my $ABS_PATH = abs_path($0); find(\&wanted, $ABS_PATH); sub wanted { if ( $_ eq "eod_templates_V2.pm" or $_ eq "eod_functions_V2.pm +"){unshift(@INC,$File::Find::dir);} } } use Data::Dumper; use Parallel::ForkManager; use Getopt::Long; Getopt::Long::Configure ("bundling"); use eod_templates_V2 qw(:ALL); use eod_functions_V2 qw(:ALL); my $path = Cwd::getcwd(); my $name = $0; $name =~ s/\.pl//; $name =~ s/\.\///; my $exit = 0; unless( ! @ARGV ){ $exit = Main(); }else{ print_help_and_exit($name); } exit($exit); sub process_command_line_args { #set default values for dynamic config settings my ($layout,$wait_for_child,$wait_for_exec,$prompt,$configf,$quiet +,$outf,$debug,$batchsize,$proto,$tacacs,$verbose,$header,@maildst) = +(0,120,3,1,"$name.cfg",1,"$name.csv",0,0,"none",0,0); GetOptions ( 'layout|l' => \$layout, 'file-based-auth|f' => sub { $prompt = 0;}, 'prompt-based-auth|p' => \$prompt, 'readfile|r=s' => \$configf, 'outfile|o=s' => \$outf, 'no-quiet|n' => sub { $quiet = 0; }, 'debug|d' => \$debug, 'Version|V' => \$header, 'max-connections|m=s' => \$batchsize, 'sendmail|s=s' => \@maildst, 'connection-proto|c=s' => \$proto, 'tacacs|t' => \$tacacs, 'verbose|v' => \$verbose, 'wait-for-childs|w=i' => \$wait_for_child, 'exec-time|e=i' => \$wait_for_exec, 'help|h' => sub { print_help_and_exit($name);} ) or print_help_and_exit($name); @maildst=split(/,/,join(',',@maildst)); #in case -s was invoked wi +th a comma separated list instead of multiple times my $mailref = \@maildst; my @args = ($layout,$wait_for_child,$wait_for_exec,$name,$prompt,$ +configf,$quiet,$outf,$debug,$batchsize,$proto,$tacacs,$verbose,$heade +r,$mailref,$path); return \@args; } sub Main { #get user defined dynamic config settings and perform various sani +ty checks my $argref = process_command_line_args(); my $batchsize = validate_command_line_args($argref); $argref->[9] = $batchsize; #all args check out now create and populate static hashes my (%STATIC,%REPORT); populate_static_hashes(\%STATIC,\%REPORT); #fill dynamic hash my %CONFIG; populate_config_hash(\%CONFIG,$argref); #set up global Output handling set_up_output_handle(\%CONFIG); #retrieve config settings from file my %DATA; get_config_from_file(\%DATA,\%CONFIG,\%STATIC); #print Dumper \%DATA; print Dumper \%CONFIG; print Dumper \%REPORT; warn("load configuration... done\nvalidate configuration... done\ +ninit all data structs... done\n"); #launch tacacs verification if it was requested my $result = 0; if ($CONFIG{tacacs} == 1){ warn("Commencing Tacacs verification process...\n"); $result = check_tacacs_functionality(\%CONFIG); unless($result == 0){ #username + password combination fail +ed, abort execution if ( $CONFIG{mail_to} ){ #mail report was requested, se +nd mail before aborting process_mail_request($result,\%CONFIG); } die("$0:ERROR tacacs functionality verification failed wit +h EC: $result. Aborting script execution.\n"); } }else{ warn("Skipping Tacacs verification process due to user selecti +on...\n"); } #prepare fork_manager operations warn("Configuring Fork manager...\n"); my $pm = configure_forkmanager_calls(\%CONFIG); #start processing devices warn("Distributing tasks to childs...\n"); for my $id (keys %DATA){ my $pid = $pm->start($id) and next; my $exitstate = process_device(\%CONFIG,\%DATA,\%STATIC,$id,$p +m); #decide on protocol, call actual processing subs #exitstate 0 = OK # 1 = NOK => IP unreachable # 2 = NOK => wrong device password # 3 = NOK => no shell received $pm->finish($exitstate); } $pm->wait_all_children; #print Dumper \%DATA; print Dumper \%CONFIG; print Dumper \%REPORT; warn("Forkmanager completed all tasks, all childs terminated\n"); warn("Creating report from temp db...\n"); create_report_from_tempdb(\%REPORT,\%CONFIG); warn("Constructing and sending mail...\n"); process_mail_request(0,\%CONFIG,\%REPORT); unlink $CONFIG{tempdb} or warn("$0:WARNING Unable to delete $CONFI +G{tempdb}. ERR:$?/$!\n"); warn("Main program completed.\nWill now close all open handles and + exit...\n"); close(STDOUT); close(STDERR); return $exit; #will have to be set depending on outcome of actual +script operations }
most of the actual code is in the functions pm now. There are still some fairly large subs, but I'm not sure breaking them down further would serve any purpose, because there won't be any reusability. I tried increasing skimmability according to suggestions. I also changed the forking part considerably because the lack of signal handling and timeout turned out to be an issue.
package eod_functions_V2; use strict; use warnings; use Cwd 'abs_path'; use File::Find; BEGIN { ##Discover and use required modules automatically at compile t +ime my $ABS_PATH = abs_path($0); find(\&wanted, $ABS_PATH); sub wanted { if ( $_ eq "eod_templates_V2.pm"){unshift(@INC,$File::Find::di +r);} } } use Digest::MD5; use Expect; use Data::Dumper; use Parallel::ForkManager; use MIME::Lite; use Fcntl qw(:DEFAULT :flock); use Data::Dumper; use Exporter; use eod_templates_V2 qw(:ALL); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $OUT); $VERSION = 1.10; @ISA = qw(Exporter); @EXPORT = (); @EXPORT_OK = qw(print_help_and_exit populate_static_hashes populate +_config_hash validate_command_line_args get_config_from_file set_up_o +utput_handle check_tacacs_functionality process_mail_request configur +e_forkmanager_calls process_device create_report_from_tempdb process_ +mail_request); %EXPORT_TAGS = ( ALL => [qw(&print_help_and_exit &populate_static_hashes &populate_ +config_hash &validate_command_line_args &get_config_from_file &set_up +_output_handle &check_tacacs_functionality &process_mail_request &con +figure_forkmanager_calls &process_device &create_report_from_tempdb & +process_mail_request)], ); our $WAITFORCHILDS; our %CHILDS; our $WARN = 1; ## Signal handling WARN for block-wide alarm supression if wanted + ################################################## $SIG{'__WARN__'} = sub { unless( $WARN == 0 ){ warn $_[0]; } }; ## SUB HELP ######################################################## +################################################ sub print_help_and_exit { my $name = $_[0]; print " \nSECTION-USAGE: This script is highly versatile, make sure you familarize your +self with it properly, before using it\n All options are case sensitive. Option/Argument handling is in + compliance with unix standard.\n mandatory arguments: --readfile|-r read device IP and commands from file and + perform them on all CPEs (default = $name.cfg. see section config fi +le for help) --connection-proto|-c define the protocol to use to connect + to the devices. (ssh OR telnet. No default setting) optional arguments: --prompt-based-auth|-p provide username + password for devi +ce access when asked. (default = enabled) WARNING: Supercedes LOGIN details in config file y +ou provide! --file-based-auth|-f provide username + password for device + access via the config-file. (default = disabled) --outfile|-o expects filename of csv to write the outpu +t to. (default = $name.csv) --no-quiet|-n log to STDOUT instead of logfile (mandato +ry if --debug is enabled, default = quiet) --debug|-d activate debug-log-level WARNING: do NOT use + with multiple CPEsoutput is massive!!! (default = disabled) --help|-h print this help and exit --verbose|-v enable verbose feedback in outputfil +e. Depending on the executed commands this can be several hundred cha +racters!!! (default = disabled) --Version|-V display extenensive version information an +d exit\n advanced optional arguments: --layout-cmd-based|-l sets layout of outputfile to command- +based structure. This will print every command-pattern instance into +a new row. (default is one row per device) --sendmail|-s expects comma separated list of e-mail ad +dresses to send generated report to as argument (default = disabled) alternatively it can be invoked multiple times wit +h different addresses. (First occurence will always be TO, all others + CC) --max-connections|-m run script in forked mode (massively e +nhances performance) with the specified ammount of max child processe +s (1-25) (default = disabled) --tacacs|-t verify tacacs functionality on VPN-Hubsite +before attempting to process devices. will abort script execution if +tacacs service is unresponsive (default = disabled) advanced customization arguments: --wait-for-childs|-w expects timeout in whole seconds (30-1 +80) childs will be allowed to run before being forcefully terminated. + (default = 120) --exec-time|-e expects time in whole seconds (2-60) chi +lds will wait for the devices to process EACH command before proceedi +ng. (default = 3) ATTENTION: big values GREATLY increase total runti +me!!! \nSECTION-CONFIG-FILE: Keep in mind some devices handle commands case sensitive! The file that you provide will be reset to its defaults during + script execution for security reasons!!! open the default config file $name.CFG with an editor of your +choice and study the instructions it contains. You may modify the default file or create a new one and pass i +t to the script with option -r Note: please report all unexpected behavior to ###. ty\n\n"; exit 0; } ### SUB create_data_structs ## DOES: populate data structs ########## +############################################ sub populate_static_hashes { my ($STATIC,$REPORT) = @_; %$STATIC = ( MODE_EN => "", MODE_CFG => "", MODE_WR => "", CHAR_DIS => "", CHAR_EN => "", CHAR_CFG => "", CMD_EN => "", CMD_CFG => "", CMD_WR => "", CHAR_NL => "", CHAR_INVALID => "", CHAR_PAGE => "", CMD_QUIT => "", CHAR_CONFIRM => "", CMD_CONFIRM => "", CMD_ROOTDIR => "", CMD_SKIP => "", CMD_SET_NO_PAGE => "", ); %$REPORT = ( UNREACHABLE => '0', OK => '0', NOK => '0', NOFEEDBACK => '0', ERROR => '0', ); } ### SUB populate_config ### Does: populate config hash with command +line arguments ################################# sub populate_config_hash { my ($CONFIG,$arrayref) = @_; my ($layout,$wait_for_child,$wait_for_exec,$name,$prompt,$configf, +$quiet,$outf,$debug,$batchsize,$proto,$tacacs,$verbose,$header,$mailr +ef,$path) = @{ $arrayref }; my $range = '1000000'; my $rand = int(rand($range)); ##generate random temp-db filename t +o allow for simultanous script execution #put first element in array as mail_to and all others as CC my $mailto = shift @{ $mailref }; my $mailcc = join ',', @{ $mailref}; $proto = lc $proto; $WAITFORCHILDS = int($wait_for_child); %$CONFIG = ( layout => "$layout", wait_for_exec => int($wait_for_exec), debug => "$debug", username => "", password =>"", verbose => "$verbose", quiet => "$quiet", hubsite => '1.1.1.1', log => "$name.log", lockfile => "$name.lock", tempdb => "$path/$rand.db", tacuser => "user", tacpass => "pass", cfg => "$configf", outcsv => "$outf", batchsize => "$batchsize", mail_to => "$mailto", mail_from => 'NMS-script@me.net', mail_sub => "", mail_cc => "$mailcc", mail_data => "", proto => "$proto", tacacs => "$tacacs", ); if ($prompt == 1){ get_username_and_password_from_stdin(\%$CONFIG); #if -p was se +lected, get username and password now otherwise when parsing config-f +ile } } ### SUB get_username_and_password_from_stdin ### DOES: gets username + and password from stdin ######################## sub get_username_and_password_from_stdin { my $CONFIG = $_[0]; eval { local $SIG{ALRM} = sub { die("timeout waiting for user input. +Aborting script execution\n") }; alarm 10; print "please enter device or tacacs username\n"; $CONFIG->{username} = <STDIN>; alarm 0; chomp $CONFIG->{username}; alarm 10; print "please enter device or tacacs password\n"; $CONFIG->{password} = <STDIN>; alarm 0; chomp $CONFIG->{password}; }; if ($@){ die($@); } } ### SUB get_username_and_password_from_file ### DOES: parses userna +me and password string + store in hash ######## sub get_username_and_password_from_file { my ($CONFIG,$line) = @_; my @temp = split(/\=/, $line); #split setting and value my $string = lc $temp[0]; $string =~ s/your-//; unless(! defined( $temp[1]) ){ #config file setting supersedes + prompt, unless its undefined $CONFIG->{$string} = $temp[1]; #wichever it was is now in +the CONFIG hash as a key(username or password) with the corresponding + value } } ### SUB validate_command_line_args ### DOES: perform various sanity + checks on command line arguments ############# sub validate_command_line_args { my ($layout,$wait_for_child,$wait_for_exec,$name,$prompt,$configf, +$quiet,$outf,$debug,$batchsize,$proto,$tacacs,$verbose,$header,$maild +st,$path) = @{ $_[0] }; if ( $header ){ print get_tmpl('version'); exit 0; } unless($proto =~ /ssh|telnet/i){ die("$0:ERROR: Connection protocol must be specified.\n"); } unless( -e $configf){ die("$0:ERROR: $configf not found in $path. +typo or missing path?\n");} if ($debug == 1 && $quiet == 1){ die("$0:ERROR: log-level=debug ca +n NOT be used in quiet mode to avoid massive logfiles!\n");} if ( $batchsize > 30 ){ warn("$0:WARNING: More than 25 simultanous connections are NOT + allowed!\nReducing Max_Connections to 25.\n"); $batchsize=25; }elsif ( $batchsize < 0 ){ warn("$0:WARNING: Negative Max_Connections are not permitted, +forking has been disabled.\n"); $batchsize = 0; } unless( 30 < $wait_for_child && $wait_for_child < 180 ){ die("-w $ +wait_for_child not permitted. value has to be 30-180 seconds\n"); } unless( 2 < $wait_for_exec && $wait_for_exec < 60 ){ die("- +e $wait_for_exec not permitted. value has to be 2-60 seconds\n"); } + return $batchsize; } ## SUB process_static_config_setting ### DOES: check if setting is v +alid and store in hash or discard ############# sub process_static_config_setting { my ($STATIC,$line) = @_; $line =~ s/DEFINE//; my @t=split(/=/,$line); #split statement into key => value pairs $t[0] =~ s/\s*//; $t[1] =~ s/\\//; if ( exists $STATIC->{$t[0]} ){ $STATIC->{$t[0]}=$t[1]; #key is supported, set value }else{ warn("$0:WARNING $t[0] is NOT a valid static configuration opt +ion and will be ignored!\n"); #key is not supported and will be ignor +ed } } ## SUB get_config_from_file ### DOES: process config file and set pop +ulate hashes accordingly ###################### sub get_config_from_file { my ($DATA,$CONFIG,$STATIC) = @_; my $count = 0; open(my $input, "<", "$CONFIG->{cfg}") or die("$0:ERROR unable to + read from $CONFIG->{cfg}. ERR: $?/$!"); while (<$input>){ chomp $_; if ( $_ =~ /your-username/i || $_ =~ /your-password/i ){ #this + line contains either the username or the password, it's irrelevant w +hich get_username_and_password_from_file($CONFIG,$_); next; } if ( $_ =~ m/^#/ || ! $_ =~ /[a-z]|[A-Z]/ ){ next; } #ignore +commented and empty lines, as well as password + username. if ( $_ =~ m/^DEFINE/ && $_ =~ /\=/){ #process config definiti +ons process_static_config_setting($STATIC,$_); next; } if ( $_ =~ m/^(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){ +3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?):/ ){ #line contains a vali +d ipv4 IP addr, this is a device-commands set my (@metachars,@translations); populate_static_arrays(\@metachars,\@translations); $_ = substitute_escaped_metachars($_,\@metachars,\@transla +tions); #substitute escaped metachars to prevent config parser from i +nterpreting them my @temp = split(/,/, $_); #split line from config-file in +to command sub-sets, first one containing device IP as well my (@commands,@matches,$ip); for (my $i=0; $i < @temp; $i++){ #process each subset if ($i == 0){ my @temp1 = split(/:/, $temp[0]); #this is the fir +st subset, it contains the IP $ip = $temp1[0]; $count++; $temp[0] =~ s/^(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9 +][0-9]?)\.){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)://; #remove IP + from subset } my @arr; if ($temp[$i] =~ /\=/ ){ #this subset contains pattern +-matching instructions my @temp2 = split(/\=/, $temp[$i]); #split subset +into further subsets, first containing the command, the rest are patt +erns $temp2[0] = substitute_placeholders($temp2[0],\@me +tachars,\@translations); #all splitting is done on this string, rever +t it back to its original form $commands[$i] = $temp2[0]; #this is the command for (my $c=1; $c < @temp2; $c++){ #these are all t +he patterns $temp2[$c] = substitute_placeholders($temp2[$c +],\@metachars,\@translations); ##undo prior substitutions $arr[$c] = $temp2[$c]; } $matches[$i] = \@arr; }else{ #this subset does not contain pattern matching +instructions $temp[$i] = substitute_placeholders($temp[$i],\@me +tachars,\@translations); ##undo prior substitutions $commands[$i] = $temp[$i]; $arr[$i] = "no-match-hook"; ##set flag for easy id +entification later on in the script $matches[$i] = \@arr; } } $DATA->{$ip}->{commands} = \@commands; $DATA->{$ip}->{matches} = \@matches; } } $CONFIG->{devices_count} = $count; if ( $count == 0 ) { die("$0:ERROR $CONFIG->{cfg} does not contai +n valid Device-instruction-sets\n");} close($input); open(my $input1, ">", "$CONFIG->{cfg}") or warn("$0:WARNING unable + to write to $CONFIG->{cfg}. CLEAR IT manually! ERR: $!/$?"); print $input1 get_tmpl("config"); #replace specified config file + with template for security reasons close($input1); while ( my($key,$value) = (each %$STATIC)){ unless(defined($value) && $value ne ""){ die("$0:ERROR: $key d +efinition missing in $CONFIG->{cfg}.Aborting Execution.\n");} #missin +g key definition, this can not be tolerated next unless lc $key eq "mode_cfg" and lc $value eq "yes"; #add +itonal security check is required for configuration access verify_user_authorization(); } } ### SUB verify_user_authorization ### DOES: prompt for pass and com +pare fingerprint of provided pass to secret ### sub verify_user_authorization { #pseudo security to deter i +ncompetent people with tacacs priv. levels they shouldn't have my $input; eval { local $SIG{ALRM} = sub { die("timeout waiting for user input. +Aborting script execution\n") }; alarm 10; print "Shouldn't you know better by now?\n"; $input = <STDIN>; alarm 0; chomp $input; }; if ($@){ die($@); } my $md5 = Digest::MD5->new; $md5->add("$input"); my $key = $md5->hexdigest; unless($key eq "a7ed07a4b4e8ad6c9a5e5a127daa92f1"){die ("You do no +t have permission to use the configure-feature\n"); } } ### SUB populate_static_arrays ### DOES: populate static arrays meta +chars and translations ######################## sub populate_static_arrays { my ($meta_ref,$trans_ref) = @_; @{ $meta_ref } = (':','=','!',','); #declare config metachars @{ $trans_ref } = ('#00','#01','#02','#03') #declare bi-direction +al placeholders } ### SUB substitute_escaped_metachars ### DOES: substitute ctrl-chars + for escaped metachars in $LINE ############### sub substitute_escaped_metachars { my ($line,$meta_ref,$trans_ref) = @_; for (my $i=0; $i<@{ $meta_ref };$i++){ $line =~ s/\#\Q$meta_ref->[$i]/$trans_ref->[$i]/g; ## hardco +ded ESCSEQ => # } return $line; } ### SUB substitute_placeholders ### DOES: revert string to its origi +nal form prior to escapeing #################### sub substitute_placeholders { my ($line,$meta_ref,$trans_ref) = @_; for (my $i=0; $i<@{ $trans_ref };$i++){ $line =~ s/$trans_ref->[$i]/$meta_ref->[$i]/g; } return $line; } ### SUB set_up_output_handle ### DOES: choose output destination and + return filehandle for printing ################ sub set_up_output_handle { my $CONFIG = $_[0]; if ($CONFIG->{quiet} == 1){ #script running in quiet mode, print e +verything to logfile. no autoflush needed. open(STDOUT, ">>", "$CONFIG->{log}") or die("$0:ERROR Unable t +o open $CONFIG->{log} for writing. ERR: $?/$!\n"); open(STDERR, ">>", "$CONFIG->{log}") or die("$0:ERROR Unable t +o redirect STDERR $CONFIG->{log}. ERR: $?/$!\n"); }else{ #script is running in non quiet mode, print everything to shel +l open(STDERR, ">&", "STDOUT") or die("$0:ERROR Unable to redire +ct output to STDOUT. ERR: $?/$!\n"); #set up autoflush for easier debugging/monitoring select(STDERR); #should be unbuffered by default, but to be su +re $| = 1; select(STDOUT); $| = 1; } } ### SUB set_up_output_handle ### DOES: choose output destination and + return filehandle for printing ################ sub check_tacacs_functionality { my $CONFIG = $_[0]; my $shell = 1; my $exp = new Expect; configure_expect($exp,$CONFIG->{debug}); $exp->spawn("ssh", "-l$CONFIG->{username}", "$CONFIG->{password}") + || die("$0:ERROR can not spawn ssh to $CONFIG->{hubsite}. ERR/SYS: $ +! / $?"); select(undef, undef, undef, 0.10); $exp->expect(10, [ qr/\? /, sub { #not a known host $exp->send("yes\n"); select(undef, undef, undef, 0.25); + $exp->send("$CONFIG->{username}\n"); $shell = '0';}], [ qr/assword:/, sub { $exp->send("$CONFIG->{password}\n"); $shell = '0';}], ); unless ( $shell == 1 ) #we have a shell, proceed { $exp->expect(10, [ qr/>/, sub { #entry in unpriv mode, try to gain priv +. access $exp->send("en\n"); select(undef, undef, undef, 0.50); $exp->send("$CONFIG->{PASS}\n"); $shell = 3; }], [ qr/#/, sub { $exp->send("exit\n"); #entry in pri +v successful, no more actions needed unless( $exp->soft_close() ){ $exp->hard_close(); +} $shell = 0 }], [ qr/assword:/, sub { #inital authentication failed unless($exp->soft_close()){$exp->hard_close(); +} $shell = 2; }], ); if ($shell == 3){ $exp->expect(10, [ qr/>/, sub { $exp->send("exit\n"); ## priv access denied. $shell = 3; }], [ qr/#/, sub { $exp->send("exit\n"); ## priv access successful. $shell = 0;}], ); } } return $shell; ## ERRORCODES: # 0 = OK # 1 = NOK - HUBSITE unreachable # 2 = NOK - login to HUBSITE failed # 3 = NOK - changing privileges failed } ### SUB process_mail_request ### DOES: decide what type of mail to b +uild, who to send it to and trigger sending #### sub process_mail_request { my ($result,$CONFIG,$REPORT) = @_; #get mail subject $CONFIG->{mail_sub} = get_mail_subject($result,$CONFIG,$REPORT); #get mail body $CONFIG->{mail_data} =get_mail_body($result,$CONFIG,$REPORT); #construct mail my $mh = MIME::Lite->new( From => $CONFIG->{mail_from}, To => $CONFIG->{mail_to}, Cc => $CONFIG->{mail_cc}, Subject => $CONFIG->{mail_sub}, Type => 'multipart/mixed', ) or die("$0:ERROR creating new mail object: $!/$?\n"); $mh->attach ( Type => 'TEXT', Data => $CONFIG->{mail_data}, ) or die("$0:ERROR adding the text message part: $!/$?\n"); if ($result == 0){ $mh->attach ( Type => "text/csv", Path => $CONFIG->{outcsv}, Filename => $CONFIG->{outcsv}, Disposition => 'attachment', ) or die("$0:ERROR adding $CONFIG->{outcsv} to mail object: $! +/$?\n"); } #send mail $mh->send } ### SUB get_mail_subject ### DOES: returns Mail subject based on $re +sulti and $REPORT ############################### sub get_mail_subject { my ($result,$CONFIG,$REPORT)= @_; my $subject; if ($result == 0){ $subject = "processed $CONFIG->{devices_count} devices. $REPOR +T->{UNREACHABLE} unreachable."; }else{ $subject = "NMS-SCRIPT-REPORT: tacacs service/account verifica +tion failed. script execution aborted"; } return $subject; } ### SUB get_mail_body ### DOES: returns mail body depending on $resu +lt and $Report ################################## sub get_mail_body { my ($result,$CONFIG,$REPORT) = @_; my $body; my $time = gettime(); if ($result == 0){ $body .= " Overview - completed $time: Pattern matches successful: $REPORT->{OK} Pattern matches unsuccessful: $REPORT->{NOK} DEVICE UNREACHABLE: $REPORT->{UNREACHABLE} ERRORS: $REPORT->{ERROR} command success, but no output: $REPORT->{NOFEEDBAC +K} "; }elsif ($result == 1){ $body = "HUBSITE $CONFIG->{hubsite} is unreachable\n"; }elsif ($result == 2){ $body = "Provided Username/password combination failed device +Authentication\n"; }elsif ($result == 3){ $body = "provided tacacs profile doesn't have the required pri +vileges associated with it\n"; } return $body; } ### SUB gettime ### DOES: returns SQL compatible timestamp in UK ti +me ############################################## sub gettime { my ($sec,$min,$hr,$day,$mon,$yr,$dayOfWeek) = localtime(); $yr += 1900; my @weekDays = ("SUN", "TUE", "WED", "THU", "FRI", "SAT"); $mon++; return "$weekDays[$dayOfWeek] $mon/$day/$yr $hr:$min:$sec"; } ### SUB configure_forkmanager_calls ###DOES: prepare forkmanager sub +s and calls ###################################### sub configure_forkmanager_calls { my ($CONFIG) = @_; my $pm = new Parallel::ForkManager($CONFIG->{batchsize}); $pm->run_on_finish( sub { my ($pid, $exitcode) = @_; if ($CONFIG->{quiet} == 0){ if ($exitcode == 0){ print "child(PID = $pid) terminated with exit +state: $exitcode = OK. PID will be removed from IPC-inventory.\n"; }else{ print "child(PID = $pid) terminated with exit +state: $exitcode = NOK. PID will be removed from IPC-inventory.\n"; } } delete $CHILDS{$pid}; } ); $pm->run_on_wait(\&terminate_unresponsive_child, 0.1); $pm->run_on_start( sub { my ($pid,$ident) = @_; $CHILDS{$pid} = time(); print "forking child with pid = $pid at ts = $CHILDS{$pid} +...\n"; } ); return $pm; } ### SUB terminate_unresponsive_child ### DOES: send termination to u +nresponsive child ############################### sub terminate_unresponsive_child { while ( my ($pid, $start_ts) = each %CHILDS ){ next unless time() - $start_ts > $WAITFORCHILDS; kill TERM => $pid; warn("child(PID = $pid) timed out, forcefully terminating chil +d\n"); delete $CHILDS{$pid}; } } ### SUB process_device ###DOES: connect to device with and perform +various commands ############################### sub process_device { my ($CONFIG,$DATA,$STATIC,$id,$pm) = @_; my $alarm = $WAITFORCHILDS - 30; alarm $alarm; #set up static timeout to avoid dead forking slots warn("Connecting to device ip $id with timeout of $alarm s...\n"); + #could be made dynamic $SIG{TERM} = sub { #write_data_to_tempdb(\%{ $CONFIG }, 0, 0, $id, 3); #this woul +d be graceful shutdown but shouldn't be possible die("child($id) received SIGTERM from parent.\n"); }; $SIG{ALRM} = sub { write_data_to_tempdb(\%{ $CONFIG }, 0, 0, $id, 3); die("child($id) exceeded timeout. terminating child\n"); }; my $exp = new Expect; configure_expect($exp,$CONFIG->{debug}); my ($nl,$skip) = get_static_chars($STATIC->{CHAR_NL},$STATIC->{CMD +_SKIP}); #translate static chars fom config my $shell = 1; #set to 1 if ($CONFIG->{proto} eq "telnet"){ $exp->spawn($CONFIG->{proto}, $id) or die("$0:ERROR Unable to +spawn $CONFIG->{proto} session to $id. ERR: $! / $?"); #spawn telnet }else{ $exp->spawn($CONFIG->{proto}, "-l$CONFIG->{username}", $id) or + die("$0:ERROR Unable to spawn $CONFIG->{proto} session to $id. ERR: +$! / $?"); #spawn ssh } select(undef, undef, undef, 0.50); $shell = authenticate_with_device($exp,\%$CONFIG,\%$STATIC,$nl); # +authenticate with device. retval 0=OK,2=NOK=>auth failed, 3=NOK no pr +ompt received my %temp; my @results; if($shell == 0){ #this var is 0 for OK or 1-3 for errors. execute +device interaction only if prior tasks returned OK my $sbc = change_cli_mode($exp,\%$CONFIG,\%$STATIC,$nl); #swit +ch to desired cli mode, specified in config file $exp->clear_accum(); $exp->send("$nl"); my $router; $exp->expect(5, [ qr/$sbc/, sub { $router = $exp->before(); $router =~ s/\s//g; }] ); for (my $c=0; $c < @{ $DATA->{$id}->{commands} }; $c++){ + my $command = $DATA->{$id}->{commands}[$c]; my $matches_ref = $DATA->{$id}->{matches}[$c]; $exp->clear_accum(); $exp->send("$command$nl"); sleep $CONFIG->{wait_for_exec}; ##wait for router t +o execute command my $lb = 0; my $fb = ""; $WARN = 0; #supress flow control warning in following bloc +k due to exiting anon sub LOOPCTRL: while ($lb < 10){ $exp->expect(5, [ qr/\Q$STATIC->{CHAR_PAGE}/, sub { ##case 1: PAGE +D OUTPUT, send SKIP and next with COUNTER+1 $fb .= $exp->before(); $exp->send("$skip"); $lb++; next LOOPCTRL; }], [ qr/\Q$STATIC->{CHAR_CONFIRM}/, sub { ##case 2: C +ONFIRM, send COMMAND and next with counter +1 $fb .= $exp->before(); $exp->clear_accum(); $exp->send("$STATIC->{CMD_CONFIRM}$nl"); $lb++; next LOOPCTRL }], ); $exp->expect(1, ##this needs to be here because it +matches before above conditons do [ qr/$sbc/, sub { ##PAGED + CONFIRM done if they o +ccured, now one forced SBC match $fb .= $exp->before(); $fb .= $exp->after(); #################some de +vices echo commands, this needs to be fixed by dynamic pty settings + last LOOPCTRL; }], ##none of the aboce occ +ured, exit loop ); } $WARN = 1; # reset to default unless($fb eq ""){ #no regex-ops required if we didn't ge +t any output $fb =~ s/\Q$STATIC->{CMD_SET_NO_PAGE}//g; #clear_accum + doesn't clear the last expect call from buffer, remove this from fb +manually $fb =~ s/$router|$sbc//g; #remove device name and sbc +from fb $fb =~ s/\Q$command//g; #remove echoed command from fb + } unless( $fb =~ /[A-Z]|[a-z]|[0-9]/ ){ #contains meaningful + chars $fb = "noFB"; } my $string .= parse_device_output($matches_ref,$fb,\%{ $ST +ATIC }); if ($CONFIG->{verbose} == 1){ $fb =~ s/\n/ /g; push(@results,"$string||$fb"); }else{ push(@results,"$string"); } } }else{ warn("ERROR while trying to authenticate on device. EC: $shell +\n"); } $temp{$id}->{results} = \@results; unless($STATIC->{MODE_CFG} eq "no"){ $exp->send("$STATIC->{CMD_ROO +TDIR}$nl");} #KI ID = 1 unless($STATIC->{MODE_WR} eq "no" ){ $exp->send("$STATIC->{CMD_ +WR}$nl");} #KI ID = 1 $exp->send("$STATIC->{CMD_QUIT}$nl"); unless($exp->soft_close()){$exp->hard_close();} #print Dumper \%temp; write_data_to_tempdb(\%{ $CONFIG }, \%{ $DATA }, \%temp, $id, $she +ll); alarm 0; #cancel timeout warn("all tasks completed within timeout. Terminating child for $i +d...\n"); return $shell; } ### SUB write_data_to_tempdb ### DOES: write result data to tempdb # +################################################## sub write_data_to_tempdb { my ($CONFIG,$DATA,$temp,$id,$exit) = @_; my ($i,$chk,$fh)=(0); while ( $i<=50 ){ $i++; select(undef, undef, undef, 0.25); open($chk, ">", "$CONFIG->{lockfile}") or next; open($fh, ">>", "$CONFIG->{tempdb}") or die("$0:($id):ERROR Un +able to write to file $CONFIG->{tempdb}. ERR: $!/$?\n"); flock($fh, LOCK_EX) or die("$0:($id):ERROR LOCK_EX FAILED on $ +fh. ERR: $!/$?\n"); my $string; if ( $exit == 0 ) { while (my ($key,$value) = (each %{ $temp }) ){ $string .= "$key"; my @lines; for (my $c=0; $c < @{ $temp->{$id}->{results} }; $c++) +{ my $command = $DATA->{$id}->{commands}[$c]; my $result = $temp->{$id}->{results}[$c]; $result =~ s/\r//g; $result =~ s/\n/ /g; $string .= "||$command||$result"; if ($CONFIG->{layout} == 1){ #instead of appending + to string, push to array, to change layout in csv push(@lines, $string); $string = "$key"; #reset string to contain +just the device IP } } if(@lines > 0){ #layout is command per row, + so array was filled foreach(@lines){ my $t = gettime(); print $fh "$t||$_|||\n"; } }else{ #layout is device per row by def +ault my $t = gettime(); print $fh "$t||$string|||\n"; } } }elsif ($exit == 1){ my $t = gettime(); print $fh "$t;$id;h00kunreach\n"; }elsif ($exit == 2){ my $t =gettime(); print $fh "$t;$id;h00knoenable\n"; }elsif ($exit == 3){ #this should be changed to + be command-instance specific, so potentially successful commands are +n't lost my $t = gettime(); print $fh "$t;$id;h00ktimeout\n"; } close($fh); select(undef, undef, undef, 0.10); close($chk); last; } } ### SUB parse_device_output ### DOES: parse output from remote devic +e and generate result string #################### sub parse_device_output { my ($matches_ref,$fb,$STATIC) = @_, my ($method,$addpos,$addneg,$case,$res) = (0,"inclusive patterns: +* ","exclusive patterns: * ",1, "OK "); my ($negpatterns,$patterns); #print Dumper \$matches_ref; foreach (@{ $matches_ref }){ next unless defined($_); my $match = "$_"; if ( $match =~ m/^\!/ ) { $match =~ s/\!//; $method = 1; $negpatterns .= "$match*"; }else{ $patterns .= "$match*"; $method = 0; } if ( $fb ne "" ){ if ($match eq 'no-match-hook' && $fb eq "noFB" ){ $case = 0; $res = "NO FEEDBACK"; $fb = "device didn't return any output"; last; }elsif ($match eq 'no-match-hook' && ! ( $fb =~ /$STATIC-> +{CHAR_INVALID}/i ) ){ $case = 2; last; }elsif ($match eq 'no-match-hook' && $fb =~ /$STATIC->{CHA +R_INVALID}/i){ $res = "ERROR"; $fb = "invalid command or syntax error"; $case = 0; last; } if ( $method == 0){ ##method pos. pattern if ( $fb =~ /$match/i ){ $addpos .= "$match*"; }else{ $res = "NOK "; } }elsif ($method == 1 && $case == 1){ ##method exclusive pa +ttern match if ( ! ($fb =~ /$match/i) ){ $addneg .= "$match*"; }else{ $res = "NOK "; } } }else{ $res = "ERROR"; $fb = "Device didn't react to command"; $case = 0; last; } } my $resref; if ($case == 0){ $resref = "$res||$fb"; }elsif ($case == 2){ $resref = "$res||No patterns were provided"; }else{ $res .= "matched "; my $tmp = "specified patterns were =>"; if(defined($patterns)){$res .=$addpos; $tmp .= "inclusive: $pa +tterns"; } if(defined($negpatterns)){$res .=$addneg; $tmp .= "exclusive: +$negpatterns";} $resref = "$res||$tmp"; } return $resref; } ### SUB configure_expect ### DOES: set up expect config static as w +ell as dynamic ################################## sub configure_expect { my ($exp,$debug) = @_; $exp->log_stdout($debug); #For debugging only $exp->exp_internal($debug); #For debugging only $exp->log_user($debug); #For Debugging only $exp->raw_pty(0); $exp->match_max(1000000) } ### SUB change_cli_mode ### DOES: switch to privileged or configure + mode if specified in config file ############### sub change_cli_mode { my ($exp,$CONFIG,$STATIC,$nl) = @_; my $sbc = $STATIC->{CHAR_DIS}; #default entry cli mode should be d +isabled if ($STATIC->{MODE_EN} eq "yes"){ #privileged mode was specified i +n configfile $exp->expect(5, [ qr/$sbc/, sub { $exp->send("$STATIC->{CMD_EN}$nl");}], #entry +was to unpriv., so change priv. now [ qr/$STATIC->{CHAR_EN}/, sub { $exp->send("$nl");}], #we entered with +priv., send NL ); $exp->expect(5, [ qr/assword:/, sub { $exp->send("$CONFIG->{PASS}$nl");}], #in some +cases changing priv. requires password/secret [ qr/$STATIC->{CHAR_EN}/, sub { $exp->send("$nl");}], #we didn't need a + password, send NL ); $sbc = $STATIC->{CHAR_EN}; } if ($STATIC->{CMD_SET_NO_PAGE} ne '?'){ $exp->send("$STATIC->{CMD_ +SET_NO_PAGE}$nl");} #this device supports terminal length settings, u +se it if ($STATIC->{MODE_CFG} eq "yes"){ #config mode was specifi +ed in config file $exp->expect(5, [ qr/$sbc/, sub { #we're not in config +ure mode $exp->send("$STATIC->{CMD_CFG}$nl");}], #OR cfg + and priv. chars are equal in which case we'll enter conf mode again/ +pr produce an irrelevant error [ qr/$STATIC->{CHAR_CFG}/, sub { $exp->send("$nl");}], ); $exp->expect(5, [ qr/assword:/, sub { $exp->send("$CONFIG->{PASS}$nl");}], [ qr/$STATIC->{CHAR_CFG}/, sub { $exp->send("$nl");}], ); $sbc = $STATIC->{CHAR_CFG}; } $exp->clear_accum(); return $sbc; } ### SUB authenticate_with_device ###DOES: perform authentication on +device and return var indicating state ########## sub authenticate_with_device { my ($exp,$CONFIG,$STATIC,$nl) = @_; my $shell = 3; $exp->expect(10, [qr/ogin:/, sub { $exp->send("$CONFIG->{username}$nl"); #teln +et some devices select(undef, undef, undef, 0.50); $shell = 2; }], [qr/sername:/, sub { $exp->send("$CONFIG->{username}$nl"); #teln +et some other devices select(undef, undef, undef, 0.50); $shell = 2 }], [qr/\? /, sub { #not a known hos +t - ssh $exp->send("yes$nl"); select(undef, undef, undef, 0.50); $shell = 2; }], [ qr/assword:/, sub { #known host - + ssh $exp->send("$CONFIG->{password}$nl"); $shell = 2; select(undef, undef, undef, 0.50); }], ); $exp->clear_accum(); unless($shell == 3){ $exp->expect(5, [ qr/assword:/, sub { $exp->send("$CONFIG->{password}$nl"); select(undef, undef, undef, 0.25);} ], [ qr/$STATIC->{CHAR_DIS}/, sub { $exp->send("$nl"); ##entry in unpriv. mode +=> proceed $shell = 0; }], [ qr/$STATIC->{CHAR_EN}/, sub { $exp->send("$nl"); ##entry in priv. mode => + proceed $shell = 0; }], ); $exp->expect(5, [ qr/assword:/, sub { unless($exp->soft_close()){$exp->hard_close(); +}}], ##authentication failed [ qr/$STATIC->{CHAR_DIS}/, sub { $exp->send("$nl"); ##entry in unpriv. mode +=> proceed $shell = '0';}], [ qr/$STATIC->{CHAR_EN}/, sub { $exp->send("$nl"); ##entry in priv. mode => + proceed $shell = '0';}], ); } return $shell; #0 = OK, 2= auth failed/wrong password 3= n +o prompt } ### SUB get_static_chars ### DOES: translate newline char from conf +igfile to character ############################# sub get_static_chars { my ($char_nl,$cmd_skip) = @_; my $nl; if ($char_nl eq "NL"){ $nl = "\n"; }elsif($char_nl eq "CR"){ $nl = "\r"; #}elsif($char_nl eq "HEXNL"){ ##still needs testing #$nl = "\0xa"; } my $skip; if ($cmd_skip eq "SPACE"){ $skip = "\032"; }elsif($cmd_skip eq "NL"){ $skip = $nl; }else{ $skip = "$cmd_skip$nl"; } return ($nl,$skip); } ### SUB create_report_from_tempdb ### DOES: read tempdb and create + report in file and populate %REPORT ############ sub create_report_from_tempdb { my ($REPORT,$CONFIG) = @_; open(my $csv, ">", "$CONFIG->{outcsv}") or die("$0:ERROR Unable to + open $CONFIG->{outcsv} for writing! ERR:$!/$?\n"); my $th = "DATE;IP"; open(my $db, "<", "$CONFIG->{tempdb}") or die("$0:ERROR Unable to +open $CONFIG->{tempdb}! ERR:$!/$?\n"); my @lines; my ($count,$countref)=(0,0); # init current element count and peak + element count for column count management while (<$db>){ $_ =~ s/\|\|\|//; #remove tempdb Set separator my @temp = split(/\|\|/, $_); $count = @temp; #save current element counter if ($count > $countref){$countref = $count;} # if current elem +ent counter is higher than peak, change peak to current if ($_ =~ /h00kunreachable/i ){ ##translate hooks i +nto report-text and increment REPORT-counters, next where apropriate $_ =~ s/h00kunreachable/IP is unreachable/; push(@lines, $_); $REPORT->{UNREACHABLE}++; next; }elsif ($_ =~ /h00knoenabl/i or $_ =~ /h00ktimeout/i){ $_ =~ s/h00knoenable/Changing into privileged mode failed/ +; $_ =~ s/h00ktimeout/child process timed out/; push(@lines, $_); $REPORT->{ERROR}++; next; }elsif ($_ =~ /noFB/i ){ #don't know if all commands fa +iled, so this line needs further processing $_ =~ s/noFB/Command did not return any output/; #replace +the hook with a comprehensive output and continue with main loop $REPORT->{NOFEEDBACK}++; } my $string = ""; foreach(@temp){ #create row and store as string next unless defined($_) and $_ ne ""; $string .= "$_;"; } $string =~ s/\s+/ /g; push(@lines, $string); if ( $string =~ /NOK/ ) { $REPORT->{NOK}++; next; } if ( $string =~ /OK/ ) { $REPORT->{OK}++; next; } if ( $string =~ /ERROR/ ) { $REPORT->{ERROR}++; } } $th = "DATE;IP"; my $c = 1; while ( $c < $countref - 1 ){ #create table header with peak co +lumn width $th .= ";COMMAND;RESULT;DETAILS"; if($CONFIG->{verbose} == 1){$th .= ";VERBOSE FEEDBACK"; $c +=1 +;} $c += 3; } unshift(@lines,$th); # put header in front of table-data foreach (@lines){ # print report to file print $csv "$_\n"; } close($db); close($csv); } 1;

Replies are listed 'Best First'.
Re^2: RFC: beginner level script improvement (various comments)
by smls (Friar) on Oct 30, 2013 at 10:26 UTC

    Some random comments on your code follow. Please keep in mind that I only casually perused (parts of) your script, so don't consider this a proper code review by any means. I also don't really understand much of the underlying functionality, so this is restricted to Perl-specific aspects of the code.

    storing config options in a list of scalars vs. a hash

    In process_command_line_args you initialize a long list of variables, and pass them back as an array reference:

    sub process_command_line_args { #set default values for dynamic config settings my ($layout,$wait_for_child,$wait_for_exec,$prompt,$configf,$quiet +,$outf,$debug,$batchsize,$proto,$tacacs,$verbose,$header,@maildst) = +(0,120,3,1,"$name.cfg",1,"$name.csv",0,0,"none",0,0); GetOptions ( ...) ... my @args = ($layout,$wait_for_child,$wait_for_exec,$name,$prompt,$ +configf,$quiet,$outf,$debug,$batchsize,$proto,$tacacs,$verbose,$heade +r,$mailref,$path); return \@args; }

    Then in various subs (Main, validate_command_line_args, populate_config_hash) you access its elements via array subscripts and by repeatedly unpacking it into a long list of scalars again.

    This seems like a really cumbersome way to deal with those values (making your script more difficult to maintain).
    A hash would serve them much better I think, especially since in populate_config_hash you end up creating the %CONFIG hash from them anyways.

    One possibility would be to use %CONFIG right from the start:

    sub Main { my %CONFIG; initialize_config_hash(\%CONFIG); get_command_line_args(\%CONFIG); validate_command_line_args(\%CONFIG); get_username_and_password_from_stdin(\%CONFIG) if $CONFIG{prompt}; ... } sub initialize_config_hash { my $CONFIG = shift; %$CONFIG = ( quiet => 0 , cfg => "$name.cfg" , verbose => 0 , outcsv => "$name.csv" , debug => 0 , proto => "none" , prompt => 1 , header => undef , layout => 0 , maildst => [] , wait_for_child => 120 , mail_to => "" , wait_for_exec => 0 , mail_from => "NMS-script@me.net" , batchsize => 0 , mail_sub => "" , tacacs => 0 , mail_cc => "" , tacuser => "user" , mail_data => "" , tacpass => "pass" , ); } sub get_command_line_args { my $CONFIG = shift; GetOptions ( 'layout|l' => \$CONFIG->{layout}, 'file-based-auth|f' => sub { \$CONFIG->{prompt} = 0; }, 'prompt-based-auth|p' => sub { \$CONFIG->{prompt} = 1; }, ... ) ... }

    calling 'next'/'last' to break out of a callback sub...

    ...is not a good idea.

    In process_device you do:

    $WARN = 0; #supress flow control warning in following block due to exi +ting anon sub LOOPCTRL: while ($lb < 10){ $exp->expect(... [ ..., sub {... $lb++; next LOOPCTRL; }], ... ); $exp->expect(... [ ..., sub {... last LOOPCTRL; }] ); } $WARN = 1; # reset to default

    The warning is there for a reason: The callback now never returns to the code that called it (in this case, Expect.pm), so if that code needs to do any cleanup etc. before passing control back to you, that will be skipped which might lead to hard-to-track bugs.

    I don't have hands-on experience with the Expect.pm module, but the documentation suggests that expect() returns a positive number on success and undef otherwise, so it seems to me that this loop could be re-written like so:

    while (...) { next if $exp->expect(... ... ); last if $exp->expect(... ... ); }

    Suppressing the warning becomes unnecessary, and so is the "LOOPCTRL" label btw.

    (Also make extra sure that those expect calls + loop control really result in the intended behavior... I can't help you there, because I have no understading of the external program you're controlling.)

    suppressing warnings

    In my experience, suppressing core Perl warnings is rarely the best solution - usually they are an indicator that what you're trying to do can be done in a better/safer way.
    But even when you do want to temporarily suppress Perl warnings, using a global variable together with a global signal handler is not the proper way to do it. Instead, simply disable the "warnings" pragma within an as-small-as-possible lexical scope:

    use strict; use warnings; # warnings coming from here will be printed { no warnings; # warnings coming from here will NOT be printed } # warnings coming from here will be printed

    Or, even better, only turn off specific warning categories instead of all at once - for example:

    # Don't warn about exiting subs via loop control: no warnings 'exiting'; # Don't warn about using undef in numeric or string operations: no warnings 'uninitialized';

    To suppress warnings emitted by modules (rather than Perl itself), first look if the module provides an option to turn them off. If not, overriding the warn signal handler is the way to go, but this too is better done locally instead of for the whole program:

    { local $SIG{__WARN__} = sub {}; # call the noisy module function here } # warnings coming from here will not be affected

    referencing + dereferencing

    I see some contructs like this in your code:

    \%{ $CONFIG } \%$CONFIG

    You can just write $CONFIG instead. The % dereferences the hash ref, but then the \ takes the reference again - i.e. they cancel each other out.
    Of course if you're doing it on purpose, to remind yourself that what is being passed along is a hash ref - then don't let me keep you from doing so... :)

    creating temporary files

    In populate_config_hash you manually generate a hopefully-unique temporary file name like this:

    my $range = '1000000'; my $rand = int(rand($range)); ##generate random temp-db filename to al +low for simultanous script execution ... tempdb => "$path/$rand.db",

    There is a module for safely creating temporary files: File::Temp (which is part of Perl since v5.6.1)

    unpacking a subroutine argument

    At the beginning of subroutines that only take one argument, you tend to write:

    my $foo = $_[0];

    There's nothing wrong with this technically, but I thought I'd point out that the following idioms are much more commonly used for that:

    my $foo = shift;
    my ($foo) = @_;

    Using shift for this may seem particularly strange to those new to Perl, but it has a lot of tradition and is also very fast.

    Edit: Fixed typo ("shift" not "unshift")

      First of all thank you very much for taking the time to read through and comment on the script.

      I was very unhappy with the locally disabling warnings thing to begin with but failed to come up with a better solution and the entire loop construct is required so the different device output cases are tested and responded accordingly, with respective timeouts and further actions.
      Using the return value of the expect method itsself hadn't occured to me at all, which is very sad considering how obvious it should have been (always is in hindsight when someone else did the thinking for you). Thank you very much for this hint. I will change that section and remove the ugly warnings thing.

      I like some of the "useless" \%{$} and a-like constructs (as long as they don't constitute mistakes) as well as captitalization of some vars because it helps me keep track of where what comes from and why, what it contains and who accesses it, purely by naming and how it is referred to. However I still haven't fixed all inconsistency mistakes in the system.

      The config-hash related changes you propose make a lot more sense than what I'm doing and I'll change the respective parts. Thank you very much for the pointers.
      Same goes for the tempfile part.

      regarding the unpacking a sub argument part
      I read the unshift and sub documentation again and I still don't understand your hint.
      As far as I understand the @_ is a list that contains all arguments the sub was called with and consequently $_[x] would contain the element of that array with index x. I would understand using any of the three below because they produce the identical result in regards to $bar_ref, (while I think shift only makes sense if something might or might not be present at a specific index after 0)

      foo(\%bar); sub bar { my $bar_ref = $_[0]; #I know what is at index 0 and that's what I +want my ($bar_ref) = @_; #same as above but I can not process anything +else from the list my $bar_ref = shift; # same as #1 but I want to continue processin +g @_ and am unsure about indexes and/or presence }
      But the unshift thing I don't understand at all.
        "I read the unshift and sub documentation again and I still don't understand your hint."

        Ah I meant shift of course, apologies for the confusion.


        As far as I understand the @_ is a list that contains all arguments the sub was called with and consequently $_[x] would contain the element of that array with index x.

        Correct.


        while I think shift only makes sense if something might or might not be present at a specific index after 0
        ...
        I want to continue processing @_ and am unsure about indexes and/or presence

        Not sure what you mean by that. shift removes the first value off the list, so all remaining elements of the list move one index to the left (that's why it's called "shift"):

        my @array = (2, 4, 6, 8); my $first = shift @array; # $first is 2 # @array is (4, 6, 8) my $second = shift @array; # $second is 4 # @array is (6, 8) # $array[0] is 6 # $array[1] is 8

        It works exactly the same when used on @_ (which is the default when shift is called without argument).


        my ($bar_ref) = @_; #same as above but I can not process anything else from the list

        Not sure what you mean by that, either. Unlike shift, the assignment does not modify @_. Its effect is identical to that of:
        my $bar_ref = $_[0];
        It's just a more "stream-lined" way of writing it.

        When both sides of an assignment are lists, Perl goes from left to right, assigning the first element of the RHS ("right-hand-side") to the first element of the LHS, then the second RHS element to the second LHS element, and so on, for as many elements as there are on the LHS:

        my ($first) = (2, 4, 6, 8); my ($first, $second) = (2, 4, 6, 8); # an array on the LHS will "eat up" all remaining elements: my ($first, $second, @remaining) = (2, 4, 6, 8); # undef can be used to "skip" elements you don't want to assign # to anything: my (undef, undef, $third) = (2, 4, 6, 8);