# # Author: Hari Sekhon # Date: 2011-09-15 11:30:24 +0100 (Thu, 15 Sep 2011) # # https://github.com/HariSekhon/lib # # License: see accompanying LICENSE file # # ============================================================================ # # Unit Tests # # make test # # This will call a bunch of Test::More unit tests from t/ # # ============================================================================ # # Functional Tests # # If you import this library then at the very minimum I recommend that you add # one or more functional tests to cover all usage scenarios for your code to # validate when this library is updated. # # ./testcmd.exp path_to_tests/*.exptest # # One of the original purposes of this library was to be able to rapidly develop Nagios plugins. # If you use this to ease your development of Nagios plugins I strongly recommend that you add # functional tests and run them whenever either this library or your plugin changes # # Running make test under nagios-plugins will run all unit and functional tests # to make sure everything still works as expected before releasing to production. It will # also check for plugins that are importing this library but don't have any test files # # You don't want your Nagios screen to suddenly go all red because you haven't done your QA! # # If you've added some code and don't have a corresponding suite of test files # in the ./tests directory then they may well break when I update this library. package HariSekhonUtils; use warnings; use strict; # fixes 'Can't locate object method "tid" via package "threads" at /usr/lib64/perl5/XSLoader.pm line 94.' caused by http_proxy/https_proxy environment variables (LWP module) # eval'ing it for perls built without thread support (like Travis CI) use Config; if($Config{usethreads}){ require threads; import threads; } # breaks Perl Taint mode programs - for untainted programs, better to let user set $PERL5LIB #BEGIN { # if($ENV{"HOME"} =~ /^(\/[\w-]+)$/){ # $ENV{"HOME"} = $1; # # use happens too early before $1 is populated or $HOME is changed, even when not in a BEGIN block # # breaks taint mode programs # use lib "$ENV{HOME}/perl5/lib"; # } #} use 5.006_001; use Carp; use Cwd 'abs_path'; use Fcntl ':flock'; use File::Basename; use Getopt::Long qw(:config bundling); # fixes 'Can't locate object method "flush" via package "IO::Handle" at /usr/local/share/perl5/LWP/UserAgent.pm line 536.' in -D/--debug mode use IO::Handle; use POSIX; use JSON 'decode_json'; use Scalar::Util 'blessed'; #use Sys::Hostname; #use Term::ANSIColor 2.01 qw(colorstrip); use Term::ReadKey; use Time::Local; # Workaround for IO::Socket::SSL bug not respecting disabling verifying self-signed certs if( -f dirname(__FILE__) . "/.use_net_ssl" ){ require Net::SSL; import Net::SSL; } our $VERSION = "1.19.8"; #BEGIN { # May want to refactor this so reserving ISA, update: 5.8.3 onwards #use Exporter "import"; #require Exporter; use Exporter; our @ISA = qw(Exporter); # consider replacing the above with these two lines for compatibility with Perl 5.6 and then removing our from @EXPORT* below #use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); #@ISA = qw(Exporter); our %EXPORT_TAGS = ( 'array' => [ qw( assert_array assert_hash assert_int assert_float compact_array flattenStats get_field get_field_array get_field_float get_field_hash get_field_int get_field2 get_field2_array get_field2_float get_field2_hash get_field2_int inArray sort_insensitive uniq_array uniq_array2 uniq_array_ordered ) ], 'cmd' => [ qw( cmd pkill prompt isYes set_sudo which ) ], 'file' => [ qw( open_file get_path_owner ) ], 'io' => [ qw( autoflush ) ], 'is' => [ qw( isArray isAlNum isAwsAccessKey isAwsHostname isAwsFqdn isAwsSecretKey isChars isCollection isDatabaseName isDatabaseColumnName isDatabaseFieldName isDatabaseTableName isDatabaseViewName isDigit isDomain isDomain2 isDomainStrict isDnsShortname isEmail isFilename isDirname isFloat isFqdn isHash isHex isHost isHostname isIP isInt isInterface isKrb5Princ isJavaBean isJavaException isJson isLabel isLdapDn isLinux isLinuxOrMac isMac isMinVersion isNagiosUnit isNoSqlKey isObject isOS isPathQualified isPort isProcessName isPythonTraceback isRef isRegex isScalar isScientific isThreshold isUrl isUrlPathSuffix isUser isVersion isVersionLax isXml user_exists ) ], 'lock' => [ qw( go_flock_yourself flock_off ) ], 'log' => [ qw( log loginit logdie ) ], 'net' => [ qw( resolve_ip ) ], 'options' => [ qw( add_options add_host_options add_user_options get_options check_regex check_string check_threshold check_thresholds env_cred env_creds env_var env_vars expand_units human_units isYes msg_perf_thresholds minimum_value month2int parse_file_option prompt plural remove_timeout set_host_default set_port_default set_threshold_defaults timecomponents2days usage validate_ssl validate_tls validate_thresholds version ) ], 'os' => [ qw( isLinux isMac isOS linux_mac_only linux_only mac_only ) ], 'regex' => [ qw( escape_regex $aws_access_key_regex $aws_host_ip_regex $aws_hostname_regex $aws_fqdn_regex $aws_secret_key_regex $column_regex $dirname_regex $domain_regex $domain_regex2 $domain_regex_strict $email_regex $filename_regex $fqdn_regex $host_regex $hostname_regex $ip_prefix_regex $ip_regex $krb5_principal_regex $label_regex $ldap_dn_regex $mac_regex $process_name_regex $rwxt_regex $subnet_mask_regex $tld_regex $url_path_suffix_regex $url_regex $user_regex $version_regex $version_regex_lax ) ], 'status' => [ qw( $status status status2 status3 critical warning unknown is_critical is_warning is_unknown is_ok isYes get_status_code get_upper_threshold get_upper_thresholds msg_thresholds try catch catch_quit quit ) ], 'string' => [ qw( lstrip ltrim perf_suffix random_alnum rstrip rtrim strBool strip strip_ansi_escape_codes trim trim_float ) ], 'time' => [ qw( sec2min sec2human tprint tstamp ) ], 'timeout' => [ qw( $timeout_current_action set_http_timeout set_timeout set_timeout_default set_timeout_max set_timeout_range ) ], 'validate' => [ qw( skip_java_output validate_alnum validate_aws_access_key validate_aws_bucket validate_aws_secret_key validate_chars validate_collection validate_database validate_database_columnname validate_database_fieldname validate_database_query_select_show validate_database_tablename validate_database_viewname validate_dir validate_directory validate_dirname validate_domain validate_domainname validate_email validate_file validate_filename validate_float validate_fqdn validate_host_port_user_password validate_host validate_hosts validate_hostname validate_hostport validate_int validate_integer validate_interface validate_ip validate_java_bean validate_krb5_princ validate_krb5_realm validate_label validate_ldap_dn validate_metrics validate_node_list validate_nodeport_list validate_nosql_key validate_password validate_port validate_process_name validate_program_path validate_regex validate_resolvable validate_ssl validate_tls validate_thresholds validate_units validate_url validate_url_path_suffix validate_user validate_user_exists validate_username ) ], 'vars' => [ qw( $critical $debug $default_warning $default_critical $email $expected_version $host $github_repo $json $msg $msg_err $msg_threshold $multiline $nagios_plugins_support_msg $nagios_plugins_support_msg_api $nodes $password $plural $port $progname $status $status_prefix $sudo $ssl $ssl_ca_path $tls $ssl_noverify $timeout $timeout_current_action $timeout_default $timeout_max $timeout_min $usage_line $user $verbose $version $warning %ERRORS %emailoptions %expected_version_option %hostoptions %multilineoption %nodeoptions %options %ssloptions %thresholdoptions %thresholds %tlsoptions %useroption %useroptions @usage_order ) ], 'verbose' => [ qw( code_error debug hr tprint tstamp verbose_mode vlog vlog2 vlog3 vlogt vlog2t vlog3t vlog_option vlog_option_bool ) ], 'web' => [ qw( curl curl_json wget ) ], ); # same as below #Exporter::export_tags('foo'); #Exporter::export_ok_tags('bar'); # TODO: move all of this from EXPORT to EXPORT_OK while validating all dependent code still works our @EXPORT = ( @{$EXPORT_TAGS{'array'}}, @{$EXPORT_TAGS{'cmd'}}, @{$EXPORT_TAGS{'io'}}, @{$EXPORT_TAGS{'is'}}, @{$EXPORT_TAGS{'file'}}, @{$EXPORT_TAGS{'lock'}}, @{$EXPORT_TAGS{'net'}}, @{$EXPORT_TAGS{'options'}}, @{$EXPORT_TAGS{'os'}}, @{$EXPORT_TAGS{'status'}}, @{$EXPORT_TAGS{'string'}}, @{$EXPORT_TAGS{'timeout'}}, @{$EXPORT_TAGS{'validate'}}, @{$EXPORT_TAGS{'vars'}}, @{$EXPORT_TAGS{'verbose'}}, @{$EXPORT_TAGS{'web'}}, ); our @EXPORT_OK = ( @EXPORT, @{$EXPORT_TAGS{'log'}}, @{$EXPORT_TAGS{'regex'}}, @{$EXPORT_TAGS{'time'}}, ); # could also do this: #{ my %seen; push @{$EXPORT_TAGS{'all'}}, grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS; } $EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; $EXPORT_TAGS{'most'} = [ @EXPORT ]; $EXPORT_TAGS{'EXPORT_OK'} = [ @EXPORT_OK ]; $EXPORT_TAGS{'EXPORT'} = [ @EXPORT ]; our $status_prefix = ""; our %ERRORS; BEGIN { # needs to be before die_sub(), otherwise could get 'Use of uninitialized value $HariSekhonUtils::ERRORS{"CRITICAL"} in exit' and exit with blank / 0 incorrect error code on early stage failures such as 'This Perl not built to support threads' # # Std Nagios Exit Codes. Not using weak nagios utils.pm. Also improves portability to not rely on it being present %ERRORS = ( "OK" => 0, "WARNING" => 1, "CRITICAL" => 2, "UNKNOWN" => 3, "DEPENDENT" => 4 ); delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; $ENV{'PATH'} = '/bin:/usr/bin:/sbin:/usr/sbin:/usr/local/bin:/usr/local/sbin'; # If we're a Nagios plugin check_* then make stderr go to stdout if(substr(basename($0), 0, 6) eq "check_"){ open STDERR, ">&STDOUT"; select(STDERR); $| = 1; select(STDOUT); $| = 1; } sub die_sub { # this is auto-translated in to equivalent system error string, we're not interested in system interpretation # so explicitly cast back to int so we can compare with std error codes # XXX: $? can't be trusted because die calls leave this as zero, especially bad from Perl modules, which then prefixes "OK:" and returns zero exit code!!! Therefore no longer unifying quit() to use die, since this dual behaviour cannot be determined inside this sub. Now only call die for real errors, if UNKNOWN is set for code_error then leave UNKNOWN, otherwise force CRITICAL my $exit_code = ( defined($?) and $? == $ERRORS{"UNKNOWN"} ? $ERRORS{"UNKNOWN"} : $ERRORS{"CRITICAL"} ); #$exit_code = (defined($exit_code) and $exit_code ne "" ? int($exit_code) : $ERRORS{"CRITICAL"}); my $str = "@_" || "Died"; # better to add the status prefix in here instead of in quit calls #my $status_prefixes = join("|", keys %ERRORS); #$str =~ s/:\s+(?:$status_prefixes):/:/g; if(substr(basename($0), 0, 6) eq "check_"){ my $prefix = ""; foreach(keys %ERRORS){ if($exit_code == $ERRORS{$_}){ $prefix = $_; last; } } $prefix = "CRITICAL" unless $prefix; $status_prefix = "" unless $status_prefix; $str = "${status_prefix}${prefix}: $str"; } # mimic original die behaviour by only showing code line when there is no newline at end of string if(substr($str, -1, 1) eq "\n"){ print STDERR $str; } else { carp $str; } if(grep(/^$exit_code$/, values %ERRORS)){ exit $exit_code; } exit $ERRORS{"CRITICAL"}; }; if(substr(basename($0), 0, 6) eq "check_"){ $SIG{__DIE__} = \&die_sub; } # This is because the die handler causes program exit instead of return from eval {} block required for exception handling sub try(&) { my $old_die = $SIG{__DIE__}; if(defined($SIG{__DIE__})){ undef $SIG{__DIE__}; } eval {$_[0]->()}; #$SIG{__DIE__} = \&die_sub; $SIG{__DIE__} = $old_die; } sub catch(&) { $_[0]->($@) if $@; } } # quick prototype to allow me to use this just below sub quit(@); our $progname = basename $0; $progname =~ /^([\w\.\/_-]+)$/ or quit("UNKNOWN", "Invalid program name - does not adhere to strict regex validation, you should name the program simply and sanely"); $progname = $1; our $nagios_plugins_support_msg = "Please try latest version from https://github.com/HariSekhon/Nagios-Plugins, re-run on command line with -vvv and if problem persists paste full output from -vvv mode in to a ticket requesting a fix/update at https://github.com/HariSekhon/Nagios-Plugins/issues/new"; our $nagios_plugins_support_msg_api = "API may have changed. $nagios_plugins_support_msg"; # ============================================================================ # our $critical; our $debug = 0; our $email; our $expected_version; our $help; our $host; our $github_repo; our $json; our $msg = ""; our $msg_err = ""; our $msg_threshold = ""; our $multiline; our $nodes; my @options; our %options; our $password; our $port; my $selflock; our $status = "UNKNOWN"; our $sudo = ""; our $syslog_initialized = 0; our $ssl; our $ssl_ca_path; our $ssl_noverify; our $tls; our $timeout_current_action = ""; our $timeout_default = 10; our $timeout_max = 60; our $timeout_min = 1; our $timeout = undef; our $usage_line = "usage: $progname [ options ]"; our $user; our %thresholds; # Standard ordering of usage options for help. Exported and overridable inside plugin to customize usage() our @usage_order = qw/host port user users groups password database table query field regex warning critical ssl tls ssl-CA-path ssl-noverify tls-noverify multiline/; # Not sure if I can relax the case sensitivity on these according to the Nagios Developer guidelines my @valid_units = qw/% s ms us B KB MB GB TB c/; our $verbose = 0; our $version; our $warning; # ============================================================================ # # Validation Regex - maybe should qr// here but it makes the vlog option output messy # ============================================================================ # # tried reversing these to be in $regex_blah format and not auto exporting but this turned out to be less intuitive from the perspective of a module caller and it was convenient to just use the regex in pieces of code without having to import them specially. This also breaks some code such as check_hadoop_jobtracker.pl which uses $domain_regex my $domain_component = '\b[a-zA-Z0-9](?:[a-zA-Z0-9\-]{0,61}[a-zA-Z0-9])?\b'; # validated against http://data.iana.org/TLD/tlds-alpha-by-domain.txt which lists all possible TLDs assigned by IANA # this matches everything except the XN--\w{6,10} TLDs as of 8/10/2012 #our $tld_regex = '\b(?:[A-Za-z]{2,4}|london|museum|travel|local|localdomain|intra)\b'; # Using the official list now to be tighter and avoid matching things like node.role in elasticsearch # to allow the prototype to be checked sub open_file ($;$); sub code_error (@); our $tld_regex = "\\b(?i:"; my $total_tld_count = 0; sub load_tlds($){ my $file = shift; my $fh = open_file($file); my $tld_count; while(<$fh>){ chomp; s/#.*//; next if /^\s*$/; if(/^([A-Za-z0-9-]+)$/){ $tld_regex .= "$1|"; $tld_count += 1; } else { warn "TLD: '$_' from tld file '$file' not validated, skipping that TLD"; } } # debug isn't set by this point #warn "$tld_count tlds loaded from tld file '$file'\n"; $total_tld_count += $tld_count; } # downloaded from IANA, run 'make tld' to update my $tld_file = dirname(__FILE__) . "/resources/tlds-alpha-by-domain.txt"; load_tlds($tld_file); $total_tld_count > 1000 or code_error("$total_tld_count tlds loaded, expected > 1000"); my $custom_tlds = dirname(__FILE__) . "/resources/custom_tlds.txt"; if(-f $custom_tlds){ load_tlds($custom_tlds); } $tld_regex =~ s/\|$//; $tld_regex .= ")\\b"; #print "tld_regex = $tld_regex\n"; # debug isn't set by this point #warn "$total_tld_count tlds loaded\n"; $total_tld_count < 2000 or code_error("$total_tld_count tlds loaded, expected < 2000"); # AWS regex from http://blogs.aws.amazon.com/security/blog/tag/key+rotation our $aws_access_key_regex = '(?), dots (script.p[ly], in.tftpd etc) to determine what this regex should be. Incidentally it appears that Linux truncates registered process names to 15 chars. # This is not from ps -ef etc it is the actual process registered name, hence init not [init] as it appears in ps output our $process_name_regex = '\s*[\w_\.\/\<\>-][\w\s_\.\/\<\>-]*'; our $url_path_suffix_regex = '/(?:[\w.,:\/%&?!#=*|\[\]~+-]+)?'; our $url_regex = '\b(?i:https?://' . $host_regex . '(?::\d{1,5})?(?:' . $url_path_suffix_regex . ')?)'; our $user_regex = '\b[A-Za-z0-9][A-Za-z0-9\._-]*[A-Za-z0-9]\b'; our $column_regex = '\b[\w\:]+\b'; our $ldap_dn_regex = '\b\w+=[\w\s-]+(?:,\w+=[\w\s-]+)*\b'; our $krb5_principal_regex = "$user_regex(?:\/$hostname_regex)?(?:\@$domain_regex)?"; our $threshold_range_regex = qr/^(\@)?(-?\d+(?:\.\d+)?)(:)(-?\d+(?:\.\d+)?)?$/; our $threshold_simple_regex = qr/^(-?\d+(?:\.\d+)?)$/; our $label_regex = '\s*[\%\(\)\/\*\w-][\%\(\)\/\*\w\s-]+'; our $version_regex = '\d(\.\d+)*'; our $version_regex_lax = $version_regex . '-?.*'; # ============================================================================ # # Options # ============================================================================ # # universal options added automatically when using get_options() our %default_options = ( "D|debug+" => [ \$debug, "Debug code" ], "t|timeout=i" => [ \$timeout, "Timeout in secs (\$TIMEOUT, default: $timeout_default)" ], "v|verbose+" => [ \$verbose, "Verbose level (\$VERBOSE=, or use multiple -v, -vv, -vvv)" ], "V|version" => [ \$version, "Print version and exit" ], "h|help" => [ \$help, "Print description and usage options" ], ); # These two subroutines are primarily for my other programs such as my spotify programs which have necessarily longer run times and need a good way to set this and have the %default_options auto updated for usage() to automatically stay in sync with the live options sub set_timeout_max ($) { $timeout_max = shift; isInt($timeout_max) or code_error("must pass an integer to set_timeout_max()"); } sub set_timeout_default ($) { $timeout_default = shift; isInt($timeout_default) or code_error("must pass an integer to set_timeout_default()"); ($timeout_default > $timeout_max) and code_error("\$timeout_default ($timeout_default) may not be higher than \$timeout_max ($timeout_max)"); ($timeout_default < $timeout_min) and code_error("\$timeout_default ($timeout_default) may not be lower than \$timeout_min ($timeout_min)"); $timeout = $timeout_default; $default_options{"t|timeout=i"} = [ \$timeout, "Timeout in secs (default: $timeout_default)" ]; } sub set_timeout_range($$){ my $min = shift; my $max = shift; isInt($min) or code_error("non-integer passed to set_timeout_range for min (first arg)"); isInt($max) or code_error("non-integer passed to set_timeout_range for max (second arg)"); $timeout_min = $min; $timeout_max = $max; } # ============================================================================ # # Optional options our %hostoptions = ( "H|host=s" => [ \$host, "Host to connect to" ], "P|port=s" => [ \$port, "Port to connect to" ], ); our %nodeoptions = ( "N|nodes=s" => [ \$nodes, "Nodes to connect to" ], "P|port=s" => [ \$port, "Port to connect to if not appended to each node in the node list in the form 'host:port'" ], ); our %useroptions = ( "u|user=s" => [ \$user, "User to connect with" ], "p|password=s" => [ \$password, "Password to connect with" ], ); our %multilineoption = ( "m|multiline" => [ \$multiline, "Multiline output for easier viewing" ], ); our %thresholdoptions = ( "w|warning=s" => [ \$warning, "Warning threshold or ran:ge (inclusive)" ], "c|critical=s" => [ \$critical, "Critical threshold or ran:ge (inclusive)" ], ); our %emailoptions = ( "E|email=s" => [ \$email, "Email address" ], ); our %expected_version_option = ( "e|expected=s" => [ \$expected_version, "Expected version regex, raises CRITICAL if not matching, optional" ] ); our %ssloptions = ( "S|ssl" => [ \$ssl, "Use SSL connection" ], "ssl-CA-path=s" => [ \$ssl_ca_path, "Path to CA certificate directory for validating SSL certificate (automatically enables --ssl)" ], "ssl-noverify" => [ \$ssl_noverify, "Do not verify SSL certificate (automatically enables --ssl)" ], ); our %tlsoptions = ( "T|tls" => [ \$tls, "Use TLS connection" ], "ssl-CA-path=s" => [ \$ssl_ca_path, "Path to CA certificate directory for validating SSL certificate (automatically enables --tls)" ], "tls-noverify" => [ \$ssl_noverify, "Do not verify SSL certificate (automatically enables --tls)" ], ); my $short_options_len = 0; my $long_options_len = 0; #sub add_host_options($){ # my $name = shift; # defined($name) or code_error("no name arg passed to add_host_options()"); # if(length($name) >= 4){ # $name = join " ", map {ucfirst} split " ", lc $name; # } # foreach(keys %hostoptions){ # $hostoptions{$_}[1] =~ s/^(.)/$name \L$1/; # } # %options = ( %options, %hostoptions ); #} #sub add_user_options($){ # my $name = shift; # defined($name) or code_error("no name arg passed to add_user_options()"); # if(length($name) >= 4){ # $name = join " ", map {ucfirst} split " ", lc $name; # } # foreach(keys %useroptions){ # $useroptions{$_}[1] =~ s/^(.)/$name \L$1/; # } # %options = ( %options, %useroptions ); #} my $default_host; sub set_host_default($;$){ #defined($default_host) and code_error("default host cannot be set twice"); # already defined, first one wins defined($default_host) and not defined($_[1]) and return; $default_host = shift; isHost($default_host) or code_error("invalid host passed as first arg to set_host_default"); if(not defined($host)){ $host = $default_host; } $hostoptions{"H|host=s"}[1] =~ s/\)$/, default: $default_host\)/; return $host; } my $default_port; sub set_port_default($;$){ #defined($default_port) and code_error("default port cannot be set twice"); # already defined, first one wins defined($default_port) and not defined($_[1]) and return; $default_port = shift; isPort($default_port) or code_error("invalid port passed as first arg to set_port_default"); if(not defined($port)){ $port = $default_port; } $hostoptions{"P|port=s"}[1] =~ s/\)$/, default: $default_port\)/; return $port; } sub set_threshold_defaults($$){ our $default_warning = shift; our $default_critical = shift; isThreshold($default_warning) or code_error("invalid warning threshold passed as first arg to set_threshold_defaults()"); isThreshold($default_critical) or code_error("invalid critical threshold passed as second arg to set_threshold_defaults()"); $warning = $default_warning; $critical = $default_critical; $thresholdoptions{"w|warning=s"}[1] =~ s/\)$/, default: $default_warning\)/; $thresholdoptions{"c|critical=s"}[1] =~ s/\)$/, default: $default_critical\)/; } # ============================================================================ # # Environment Host/Port and User/Password Credentials my @host_envs; my @port_envs; my @user_envs; my @password_envs; my $port_env_found = 0; sub env_cred($){ my $name = shift; $name = uc $name; $name =~ s/[^A-Za-z0-9]/_/g; $name .= "_" if $name; push(@host_envs, "\$${name}HOST"); push(@port_envs, "\$${name}PORT"); push(@user_envs, "\$${name}USERNAME"); push(@user_envs, "\$${name}USER"); push(@password_envs, "\$${name}PASSWORD"); # Can't vlog here since verbose mode and debug mode aren't set until after option processing if($ENV{"${name}HOST"} and not $host){ #vlog2("reading host from \$${name}HOST environment variable"); $host = $ENV{"${name}HOST"}; } if($ENV{"${name}PORT"} and not $port_env_found){ #vlog2("reading port from \$${name}PORT environment variable"); $port = $ENV{"${name}PORT"}; $port_env_found++; } if($ENV{"${name}USERNAME"} and not $user){ #vlog2("reading user from \$${name}USERNAME environment variable"); $user = $ENV{"${name}USERNAME"}; } elsif($ENV{"${name}USER"} and not $user){ #vlog2("reading user from \$${name}USER environment variable"); $user = $ENV{"${name}USER"}; } if($ENV{"${name}PASSWORD"} and not $password){ #vlog2("reading password from \$${name}PASSWORD environment variable"); $password = $ENV{"${name}PASSWORD"}; } return 1; } sub env_creds($;$){ my $name = shift; my $longname = shift; ( defined($name) and $name ) or code_error("no name arg passed to env_creds()"); unless($longname){ unless(isScalar(\$name)){ code_error("must supply longname second arg to env_creds() if first arg for ENV is not a scalar"); } if($name ne uc $name){ $longname = $name; } elsif(length($name) < 5){ $longname = $name; } else { $longname = join " ", map {ucfirst} split " ", lc $name; } } if(isScalar(\$name)){ env_cred($name); } elsif(isArray($name)){ foreach (@{$name}){ env_cred($_); } } else { code_error("non-scalar/non-array ref passed as first arg to env_creds()"); } env_cred(""); # if($ENV{"HOST"}){ # $host = $ENV{"HOST"} unless $host; # } # if($ENV{"PORT"}){ # $port = $ENV{"PORT"} unless $port; # } # if($ENV{"USERNAME"}){ # $user = $ENV{"USERNAME"} unless $user; # } elsif($ENV{"USER"}){ # $user = $ENV{"USER"} unless $user; # } # if($ENV{"PASSWORD"}){ # $password = $ENV{"PASSWORD"} unless $password; # } $hostoptions{"H|host=s"}[1] = "$longname host (" . join(", ", @host_envs) . ")"; $hostoptions{"P|port=s"}[1] = "$longname port (" . join(", ", @port_envs) . ( defined($port) ? ", default: $port)" : ")"); #$nodeoptions{"N|node=s"}[1] = "$longname node (" . join(", ", @host_envs) . ")"; #$nodeoptions{"P|port=s"}[1] = "$longname port (" . join(", ", @port_envs) . ( defined($port) ? ", default: $port)" : ")"); $useroptions{"u|user=s"}[1] = "$longname user (" . join(", ", @user_envs) . ")"; $useroptions{"p|password=s"}[1] = "$longname password (" . join(", ", @password_envs) . ")"; return 1; } sub env_var($$){ my $name = shift; my $var_ref = shift; $name = uc $name; $name =~ s/[^A-Za-z0-9]/_/g; if($ENV{$name} and not defined($$var_ref)){ $$var_ref = $ENV{$name}; } return 1; } sub env_vars($$){ my $name = shift; my $var_ref = shift; if(isScalar(\$name)){ env_var($name, $var_ref); } elsif(isArray($name)){ foreach (@{$name}){ env_var($_, $var_ref); } } else { code_error("non-scalar/non-array ref passed as first arg to env_vars()"); } return 1; } # ============================================================================ # # Nagios Exit Code Functions # ============================================================================ # # Set status safely - escalate only # there is no ok() since that behaviour needs to be determined by scenario sub unknown () { if($status eq "OK"){ $status = "UNKNOWN"; } } sub warning () { if($status ne "CRITICAL"){ $status = "WARNING"; } } sub critical () { $status = "CRITICAL"; } ############################ sub is_ok () { ($status eq "OK"); } sub is_warning () { ($status eq "WARNING"); } sub is_critical () { ($status eq "CRITICAL"); } sub is_unknown () { ($status eq "UNKNOWN"); } sub get_status_code (;$) { if($_[0]){ defined($ERRORS{$_[0]}) || code_error("invalid status '$_[0]' passed to get_status_code()"); return $ERRORS{$_[0]}; } else { defined($ERRORS{$status}) || code_error("invalid status '$status' found in \$status variable used by get_status_code()"); return $ERRORS{$status}; } } sub status () { my $status = get_status_code(); vlog("status: $status"); return $status; } # status2/3 not exported/used at this time sub status2 () { my $status = get_status_code(); vlog2("status: $status"); return $status; } sub status3 () { my $status = get_status_code(); vlog3("status: $status"); return $status; } # requires that you 'use Data::Dumper' in calling program, since not all programs will need this sub catch_quit ($) { my $my_errmsg = $_[0]; catch { if(isObject($@) and defined($@->{"message"})){ $my_errmsg .= ": " . ref($@) . ": " . $@->{"message"}; } elsif($!) { $my_errmsg .= ": $!"; } elsif($@ and not isObject($@)) { $my_errmsg .= ": $@"; } chomp $my_errmsg; #$my_errmsg =~ s/ $filename_regex line \d+\.$//; quit "CRITICAL", $my_errmsg; }; return 1; } # ============================================================================ # #sub option_present ($) { # my $new_option = shift; # grep { # my @option_switches = split("|", $_); # my @new_option_switches = split("|", $new_option); # } (keys %options); #} # TODO: consider calling this from get_options and passing hashes we want options for straight to that sub # TODO: fix this to use option_present #sub add_options ($) { # my $options_hash = shift; # isHash($options_hash, 1); # #@default_options{keys %options} = values %options; # #@default_options{keys %{$_[0]}} = values %{$options_hash}; # foreach my $option (keys %{$options_hash}){ # unless(option_present($option)){ # print "want to add $option\n"; # #$default_options{$option} = ${$options_hash{$option}}; # } # } # ## #my (%optionshash) = @_; ## # by ref is faster ## my $hashref = shift; ## unless(isHash($hashref)){ ## #my ($package, $file, $line) = caller; ## code_error("non hash ref passed to add_options subroutine"); # at " . $file . " line " . $line); ## } ## # TODO: consider replacing this with first position insertion in array in get_options for efficiency ## foreach my $option (keys %options){ ## unless grep { grep($options keys %{$_} } @options){ ## push(@options, { $_ => $options{$_} }) ## }; ## } ## #foreach(keys %hashref){ ## # push(@options, { $_ => $hashref{$_} }); ## #} #} #sub update_option_description { # my $option = #} #sub add_thresholds { # our $range_inversion = 0; # foreach(keys %thresholds){ # $options{$_} = $thresholds{$_}; # } #} # For reference only, faster to just put this directly in to code #sub isUserNameEUID(){ # #my $user = shift; # #defined($user) or code_error "no user passed to amIuser()"; # # checking EUID against arg # getpwuid($>) eq shift; #} sub autoflush () { select(STDERR); $| = 1; select(STDOUT); $| = 1; return 1; } sub assert_array($$) { my $array = shift; my $name = shift; isArray($array) or quit "UNKNOWN", "$name is not an array! $nagios_plugins_support_msg_api"; } sub assert_float($$) { my $float = shift; my $name = shift; isFloat($float) or quit "UNKNOWN", "$name is not a float! $nagios_plugins_support_msg_api"; } sub assert_hash($$) { my $hash = shift; my $name = shift; isHash($hash) or quit "UNKNOWN", "$name is not a hash! $nagios_plugins_support_msg_api"; } sub assert_int($$) { my $int = shift; my $name = shift; isInt($int, "signed") or quit "UNKNOWN", "$name is not an integer! $nagios_plugins_support_msg_api"; } sub check_regex ($$;$) { my $string = shift; my $regex = shift; my $no_msg = shift; defined($string) or code_error("undefined string passed to check_regex()"); defined($regex) or code_error("undefined regex passed to check_regex()"); if($string !~ /$regex/){ critical; $msg .= " (expected regex: '$regex')" unless $no_msg; return; } return 1; } sub check_string ($$;$) { my $string = shift; defined($string) or code_error("undefined string passed to check_string()"); my $expected_string = shift; my $no_msg = shift; if(defined($expected_string) and $string ne $expected_string){ critical; $msg .= " (expected: '$expected_string')" unless $no_msg; return; } return 1; } sub check_threshold ($$) { #subtrace(@_); my $threshold = shift; my $result = shift; $threshold =~ /(?:warning|critical)$/ or code_error("invalid threshold name passed to check_threshold subroutine"); isFloat($result, 1) or isScientific($result, 1) or code_error("Non-float passed to check_threshold subroutine"); my $upper = defined($thresholds{$threshold}{"upper"}) ? $thresholds{$threshold}{"upper"} : undef; my $lower = defined($thresholds{$threshold}{"lower"}) ? $thresholds{$threshold}{"lower"} : undef; my $invert_range = $thresholds{$threshold}{"invert_range"} || undef; my $error = 0; if(!$invert_range){ debug("doing straight non range-inverted $threshold threshold checks"); debug("if result $result > $threshold upper ($upper)") if defined($upper); debug("if result $result < $threshold lower ($lower)") if defined($lower); if(defined($upper) and $result > $upper){ $error = "$result>$upper"; } elsif(defined($lower) and $result < $lower){ $error = "$result<$lower"; } } else { debug("doing range-inverted $threshold threshold checks"); debug("if result $result <= $threshold upper ($upper)") if defined($upper); debug("if result $result >= $threshold lower ($lower)") if defined($lower); if(defined($upper) and defined($lower)){ if($lower <= $result and $result <= $upper ){ #$error = " $result not within range $lower-$upper"; $error = "not within range $lower-$upper"; } } else { if(defined($upper) and $result <= $upper){ $error = "$result<=$upper"; } elsif(defined($lower) and $result >= $lower){ $error = "$result>=$lower"; } } } if($error){ $thresholds{$threshold}{"error"} = $error; vlog2("result outside of $threshold thresholds: $error\n"); if($threshold =~ /warning/){ warning; } else { critical; } # $threshold_ok false return 0; } else { undef $thresholds{$threshold}{"error"}; } # $threshold_ok true return 1; } sub check_thresholds ($;$$) { #subtrace(@_); my $result = shift; my $no_msg_thresholds = shift || 0; my $name = shift() || ""; $name .= " " if $name; vlog2("checking ${name}thresholds"); defined($result) or code_error("no result passed to check_thresholds()"); my $status_ok = check_threshold("${name}critical", $result) and check_threshold("${name}warning", $result); # this is switched off because it's done via msg_thresholds chaining in to return below, do not re-enable this or you'll get double printing #msg_thresholds() unless $no_msg_thresholds; return ($status_ok, msg_thresholds($no_msg_thresholds, $name)); } #sub checksum ($;$) { # my $file = shift; # my $algo = shift; # $algo or $algo = "md5"; # my $fh; # unless(open($fh, $file)){ # vlog "Failed to read file '$file': $!\n"; # return; # } # binmode($fh); # my $checksum; # if($algo eq "md5"){ # $checksum = Digest::MD5->new; # } elsif ($algo eq "sha1"){ # $checksum = Digest::Sha->new("sha1"); # } else { # croak "checksum passed unsupported algorithm type '$algo'"; # } # $checksum->addfile($fh); # return $checksum->hexdigest; #} #sub sha1sum { # return checksum($_[0], "sha1"); #} # #sub md5sum { # return checksum($_[0], "md5"); #} sub cmd ($;$$$) { my $cmd = shift; my $errchk = shift; my $inbuilt = shift; my $return_exitcode = shift; $cmd =~ s/^\s+//; my $prog = (split(/\s+/, $cmd))[0]; if($prog eq "exec"){ $prog = (split(/\s+/, $cmd))[1]; } if($inbuilt){ # TODO: consider adding inbuilt check, however this means two shell calls per command, very inefficient, think it's better to just catch failure #type($prog, 1); } else { which($prog, 1); } # this would be if we were gonna support shell built-ins #unless(which($prog)){ # type($prog) or quit("UNKNOWN", "'$prog' command was not found in \$PATH and is not a shell built-in"); # $prog = (split(/\s+/, $cmd))[1]; # which($prog, 1); #} if($cmd =~ s/\|\s*$//){ # return reference to filehandle for more efficient processing vlog2("opening cmd pipe"); vlog3("cmd: $cmd"); open my $fh, "$cmd |"; return $fh; } vlog3("cmd: $cmd"); # XXX: this doesn't work to solve Alpine's buggy behaviour of not returning error output and non-zero exit code when testing validate_regex() posix with broken capture of no closing brace #open my $fh, "$cmd 2>&1 |"; my $return_output = `$cmd 2>&1`; my $exitcode = $?; #my $return_output = do { local $/; <$fh> }; #close $fh; my @output = split("\n", $return_output); $exitcode = $exitcode >> 8; vlog3("output:\n\n$return_output"); vlog3("exitcode: $exitcode\n"); if ($errchk and $exitcode != 0) { my $err = ""; if(substr($progname, 0, 6) eq "check_"){ foreach (@output) { $err .= " " . trim($_); } } else { $err = join("\n", @output); } quit("CRITICAL", "'$cmd' returned $exitcode - $err"); } if($return_exitcode){ return ($exitcode, @output); } else { return @output; } } sub code_error (@) { use Carp; #quit("UNKNOWN", "Code Error - @_"); $? = $! = $ERRORS{"UNKNOWN"}; if($debug){ confess "Code Error - @_"; } else { croak "Code Error - @_"; } } # Remove blanks from array sub compact_array (@) { return grep { $_ !~ /^\s*$/ } @_; } sub curl ($;$$$$$$) { my $url = shift; my $name = shift; my $user = shift; my $password = shift; my $err_sub = shift; my $type = shift() || 'GET'; my $body = shift; grep { $type eq $_ } qw/GET POST PUT DELETE HEAD/ or code_error "unsupported type '$type' passed to curl() as sixth argument"; #debug("url passed to curl: $url"); defined($url) or code_error "no URL passed to curl()"; my $url2 = isUrl($url) or code_error "invalid URL '$url' supplied to curl()"; $url = $url2; my $host = $url; $host =~ s/^https?:\/\///; $host =~ s/(?::\d+)?(?:\/.*)?$//; isHost($host) or die "invalid host determined from URL '$url' in curl()"; my $auth = (defined($user) and defined($password)); # don't replace $host with resolved host as this changes the vlog output, affects proxy exceptions can break load balancer routing with '503 Service Temporarily Unavailable' validate_resolvable($host); if($name){ if($type eq "POST"){ vlog2("POSTing to $name"); } elsif($type eq "PUT"){ vlog2("PUTing to $name"); } else { vlog2("querying $name"); } vlog3("HTTP $type $url" . ( $auth ? " (basic authentication)" : "") ); } else { vlog2("HTTP $type $url" . ( $auth ? " (basic authentication)" : "") ); } if($type eq "POST" or $type eq "PUT"){ vlog3($body); } #unless(defined(&main::get)){ # inefficient, it'll import for each curl call, instead force top level author to # use LWP::Simple 'get' #debug("importing LWP::Simple 'get'\n"); #require LWP::Simple; #import LWP::Simple "get"; #code_error "called curl() without declaring \"use LWP::Simple 'get'\""; #} #$content = main::get $url; #my ($result, $err) = ($?, $!); #vlog2("result: $result"); #vlog2("error: " . ( $err ? $err : "" ) . "\n"); #if($result ne 0 or $err){ # quit("CRITICAL", "failed to get '$url': $err"); #} defined_main_ua(); $main::ua->show_progress(1) if $debug; $main::ua->env_proxy; my $req = HTTP::Request->new($type, $url); # LWP timeout should always be less than global timeout to prevent "UNKNOWN" erorrs if ($timeout >= 1) { $main::ua->timeout($timeout-.5); } else { $main::ua->timeout(.5); } $req->authorization_basic($user, $password) if (defined($user) and defined($password)); $req->content($body) if $body; my $response = $main::ua->request($req); my $content = $response->content; vlog3("returned HTML:\n\n" . ( $content ? $content : "" ) . "\n"); vlog2("http status code: " . $response->code); vlog2("http status message: " . $response->message . "\n"); if($err_sub){ isCode($err_sub) or code_error "invalid subroutine passed to curl() as error handler"; &$err_sub($response); } else { unless($response->code eq "200"){ my $additional_information = ""; my $json; if($json = isJson($content)){ foreach(qw/status error message reason/){ if(defined($json->{$_})){ $_ eq "status" and $json->{$_} eq $response->code and next; $additional_information .= ". " . ucfirst($_) . ": " . $json->{$_}; } } } quit("CRITICAL", $response->code . " " . $response->message . $additional_information); } unless($content){ quit("CRITICAL", "blank content returned from '$url'"); } } return $content; } sub curl_json ($;$$$$$$) { my $url = shift; my $name = shift; my $user = shift; my $password = shift; my $err_handler = shift; my $type = shift() || 'GET'; my $body = shift; my $content = curl $url, $name, $user, $password, $err_handler, $type, $body; vlog2("parsing output from " . ( $name ? $name : $url ) . "\n"); $json = isJson($content) or quit "CRITICAL", "invalid json returned " . ( $name ? "by $name at $url" : "from $url"); } sub debug (@) { return unless $debug; my ( $package, $filename, $line ) = caller; my $debug_msg = "@_"; $debug_msg =~ s/^(\n+)//; #my $prefix_newline = $1 || ""; my $sub = (caller(1))[3]; if($sub){ $sub .= "()"; } else { $filename = basename $filename; $sub = "global $filename line $line"; } #printf "${prefix_newline}debug: %s => %s\n", $sub, $debug_msg; printf "debug: %s => %s\n", $sub, $debug_msg; } sub defined_main_ua(){ unless(defined($main::ua)){ code_error "LWP useragent \$ua not defined (or inaccessibly defined with my instead of our), must import to main before calling curl(), do either \"use LWP::Simple '\$ua'\" or \"use LWP::UserAgent; our \$ua = LWP::UserAgent->new\""; } } sub escape_regex ($) { my $regex = shift; defined($regex) or code_error "no regex arg passed to escape_regex() subroutine"; #$regex =~ s/([^\w\s\r\n])/\\$1/g; # backslashes everything that isn't /[A-Za-z_0-9]/ $regex = quotemeta($regex); # $regex = \Q$regex\E; return $regex; } sub expand_units ($;$$) { my $num = shift; my $units = shift; my $name = shift; my $power; defined($num) || code_error "no num arg 1 passed to expand_units()"; if((!defined($units)) and $num =~ /^(\d+(?:\.\d+)?)([A-Za-z]{1,2})$/){ $num = $1; $units = $2; } defined($units) || code_error "no units arg 2 passed to expand_units()"; isFloat($num) || code_error "non-float num arg 1 passed to expand_units()"; if ($units =~ /^B?$/i) { return $num; } elsif($units =~ /^Ki?B?$/i){ $power = 1; } elsif($units =~ /^Mi?B?$/i){ $power = 2; } elsif($units =~ /^Gi?B?$/i){ $power = 3; } elsif($units =~ /^Ti?B?$/i){ $power = 4; } elsif($units =~ /^Pi?B?$/i){ $power = 5; } else { code_error "unrecognized units '$units' " . ($name ? "for $name " : "") . "passed to expand_units(). $nagios_plugins_support_msg"; } return $num * (1024**$power); } my %stats; # To check prototype before calling recursively sub processStat($$); sub processStat($$){ my $name = shift; my $var = shift; vlog3("processing $name"); if(isArray($var)){ if(scalar @{$var} > 0){ foreach(my $i=0; $i < scalar @{$var}; $i++){ processStat("$name.$i", $$var[$i]); } } else { processStat("$name.0", ""); } } elsif(isHash($var)){ if(scalar keys %{$var} and defined($$var{"value"})){ processStat($name, $$var{"value"}); #vlog2 "$name='$$var{value}'"; #$stats{$name} = $$var{"value"}; } else { foreach my $key (keys %{$var}){ processStat("$name.$key", $$var{$key}); } } } else { return if $name =~ /\.version$/; isFloat($var) or return; vlog2("$name='$var'"); $stats{$name} = $var; } } sub flattenStats($){ my $hashref = shift; isHash($hashref) or code_error "invalid arg passed to flattenStats, not a hashref!"; foreach my $stat (sort keys %{$hashref}){ processStat($stat, $hashref->{$stat}); } return %stats; } sub get_field($;$){ get_field2($json, $_[0], $_[1]); } sub get_field_array($;$){ get_field2_array($json, $_[0], $_[1]); } sub get_field_float($;$){ get_field2_float($json, $_[0], $_[1]); } sub get_field_hash($;$){ get_field2_hash($json, $_[0], $_[1]); } sub get_field_int($;$){ get_field2_int($json, $_[0], $_[1]); } sub get_field2($$;$){ my $hash_ref = shift; my $field = shift || code_error "field not passed to get_field2()"; my $noquit = shift; isHash($hash_ref) or code_error "non-hash ref passed to get_field2()"; # negative lookbehind allows for escaping dot in the field name my @parts = split(/(? 1){ my $ref = $hash_ref; foreach(@parts){ s/\\\././g; # XXX: this returns field not found where field exists but value is 'undef' if(isHash($ref) and defined($ref->{$_})){ $ref = $ref->{$_}; } elsif(isArray($ref) and $_ =~ /^(\d+)$/){ if(defined(${$ref}[$1])){ $ref = ${$ref}[$1]; } else { quit "UNKNOWN", "array has no $1 item for field '$field'. $nagios_plugins_support_msg_api" unless $noquit; $ref = undef; last; } } else { quit "UNKNOWN", "'$field' '$_' field not found. $nagios_plugins_support_msg_api" unless $noquit; $ref = undef; last; } } return $ref; } else { # XXX: this returns field not found where field exists but value is 'undef' if(defined($hash_ref->{$field})){ return $hash_ref->{$field}; } else { quit "UNKNOWN", "'$field' field not found. $nagios_plugins_support_msg_api" unless $noquit; return; } } code_error "hit end of get_field2 sub"; } sub get_field2_array($$;$){ my $hash_ref = shift; my $field = shift; my $noquit = shift; my $value = get_field2($hash_ref, $field, $noquit); if($noquit){ return unless $value; return unless isArray($value); } assert_array($value, $field); return @{$value}; } sub get_field2_float($$;$){ my $hash_ref = shift; my $field = shift; my $noquit = shift; my $value = get_field2($hash_ref, $field, $noquit); if($noquit){ return unless defined($value); return unless isFloat($value); } assert_float($value, $field); return $value; } sub get_field2_hash($$;$){ my $hash_ref = shift; my $field = shift; my $noquit = shift; my $value = get_field2($hash_ref, $field, $noquit); if($noquit){ return unless $value; return unless isHash($value); } assert_hash($value, $field); if($value){ return %{$value}; } else { return {}; } } sub get_field2_int($$;$){ my $hash_ref = shift; my $field = shift; my $noquit = shift; my $value = get_field2($hash_ref, $field, $noquit); if($noquit){ return unless defined($value); return unless isInt($value); } assert_int($value, $field); return $value; } # get a field from a flattened hash #sub get_field3($$;$){ # my $hash_ref = shift; # my $field = shift || code_error "field not passed to get_field3()"; # my $noquit = shift; # isHash($hash_ref) or code_error "non-hash ref passed to get_field3()"; # # XXX: this returns field not found where field exists but value is 'undef' # if(defined($hash_ref->{$field})){ # return $hash_ref->{$field}; # } else { # quit "UNKNOWN", "'$field' field not found. $nagios_plugins_support_msg_api" unless $noquit; # return; # } # code_error "hit end of get_field3 sub"; #} sub get_options { my %options3; #@default_options{ keys %options } = values %options; foreach my $default_option (keys %default_options){ # Check that the %options given don't clash with any existing or in-built options foreach my $option (keys %options){ foreach my $switch (split(/\s*\|\s*/, $option)){ if(grep({$_ eq $switch} split(/\s*\|\s*/, $default_option))){ code_error("Key clash on switch '$switch' with in-built option '$default_option' vs provided option '$option'"); } } } $options{$default_option} = $default_options{$default_option}; #unless exists $options{$default_option}; # check above is stronger } foreach(keys %options){ unless (isArray($options{$_})){ code_error("invalid value for %options key '$_', should be an array not " . lc ref($options{$_}) ); } $options3{$_} = $options{$_}[0]; } my %option_count; foreach my $option (keys %options3){ foreach my $switch (split(/\s*\|\s*/, $option)){ $option_count{$switch}++; } } foreach(keys %option_count){ $option_count{$_} > 1 and code_error("Duplicate option key detected '$_'"); } GetOptions(%options3) or usage(); # TODO: finish this debug code # if($debug){ # foreach(sort keys %options3){ # if(defined($options3{$_}[0])){ # debug("var $options3{$_}[0] = $options3{$_}[0]"); # } # } # } defined($help) and usage(); defined($version) and version(); if(defined($ENV{"DEBUG"}) and $ENV{"DEBUG"}){ $debug = 1; } if($debug){ $verbose = 3; } if(defined($ENV{'VERBOSE'})){ if(isInt($ENV{'VERBOSE'})){ my $env_verbose = int($ENV{'VERBOSE'}); if($env_verbose > $verbose){ $verbose = $env_verbose; vlog3("environment variable \$VERBOSE = '$env_verbose', increasing verbosity"); } } else { warn "environment variable \$VERBOSE is not an integer ('$ENV{VERBOSE}')"; } } verbose_mode(); #vlog2("options:\n"); # validation is done on an option by option basis if(defined($ENV{'TIMEOUT'})){ if(isInt($ENV{'TIMEOUT'})){ if(not defined($timeout)){ vlog3("environment variable \$TIMEOUT = '$ENV{TIMEOUT}' and timeout not already set, setting timeout = $ENV{TIMEOUT}"); $timeout = int($ENV{'TIMEOUT'}); } } else { warn "\$TIMEOUT environment variable is not an integer ('$ENV{TIMEOUT}')"; } } if(not defined($timeout)){ $timeout = $timeout_default; } 1; } sub get_path_owner ($) { # defined($_[0]) || code_error "no path passed to get_path_owner()"; my $path = shift; open my $fh, $path || return; my @stats = stat($fh); close $fh; defined($stats[4]) || return; return getpwuid($stats[4]) || 0; } sub get_upper_threshold ($) { my $type = shift; if($type eq "warning" or $type eq "critical"){ if(defined($thresholds{$type}{"upper"})){ return $thresholds{$type}{"upper"}; } else { return ""; } } code_error "invalid threshold type '$type' passed to get_upper_threshold(), must be one of: warning critical"; } sub get_upper_thresholds () { return get_upper_threshold("warning") . ";" . get_upper_threshold("critical"); } # go flock ur $self ;) sub go_flock_yourself (;$$) { my $there_can_be_only_one = shift; my $wait = shift; my $locking_options; if($wait){ vlog2("waiting to go flock myself"); $locking_options = LOCK_EX; } else { $locking_options = LOCK_EX|LOCK_NB; } if($there_can_be_only_one){ open *{0} or die "Failed to open *{0} for lock: $!\n"; flock *{0}, $locking_options or die "Failed to acquire global lock, related code is already running somewhere!\n"; } else { open $selflock, $0 or die "Failed to open $0 for lock: $!\n"; flock $selflock, $locking_options or die "Another instance of " . abs_path($0) . " is already running!\n"; } vlog2("truly flocked now"); 1; } sub flock_off (;$) { my $there_can_be_only_one = shift; if($there_can_be_only_one){ open *{0} or die "Failed to open *{0} for lock: $!\n"; flock *{0}, LOCK_UN; } else { open $selflock, $0 or die "Failed to open $0 for lock: $!\n"; flock $selflock, LOCK_UN; } } sub hr() { print "# " . "="x76 . " #\n"; } sub human_units ($;$$) { my $num = shift; my $units = shift; my $terse = shift; if($units){ $num = expand_units($num, $units); } defined($num) or code_error "no arg passed to human_units()"; isFloat($num) or isScientific($num) or code_error "non-float passed to human_units()"; if( $num >= (1024**7)){ code_error "determine suspicious units for number $num, larger than Exabytes??!!"; } elsif($num >= (1024**6)){ $num = sprintf("%.2f", $num / (1024**6)); $units = "EB"; } elsif($num >= (1024**5)){ $num = sprintf("%.2f", $num / (1024**5)); $units = "PB"; } elsif($num >= (1024**4)){ $num = sprintf("%.2f", $num / (1024**4)); $units = "TB"; } elsif($num >= (1024**3)){ $num = sprintf("%.2f", $num / (1024**3)); $units = "GB"; } elsif($num >= (1024**2)){ $num = sprintf("%.2f", $num / (1024**2)); $units = "MB"; } elsif($num >= (1024**1)){ $num = sprintf("%.2f", $num / (1024**1)); $units = "KB"; } elsif($num < 1024){ if($terse){ return "${num}B"; } else { return "$num bytes"; } } else { code_error "unable to determine units for number $num"; } return trim_float($num) . $units; } sub inArray ($@) { my $item = shift; my @array = @_; my $found = 0; foreach(@array){ #vlog("checking $item against $_"); if($item eq $_){ $found++; } } return $found; } sub isAlNum ($) { my $arg = shift; defined($arg) or return; #code_error("no arg passed to isAlNum()"); $arg =~ /^([A-Za-z0-9]+)$/ or return; return $1; } sub isArray ($) { my $isArray; if(defined($_[0])){ $isArray = ref $_[0] eq "ARRAY"; } if($_[1]){ unless($isArray){ code_error "non array reference passed to isArray()"; } } return $isArray; } sub isAwsAccessKey($){ my $aws_access_key = shift; defined($aws_access_key) or return; $aws_access_key =~ /^($aws_access_key_regex)$/ or return; return $1; } sub isAwsHostname($){ my $aws_hostname = shift; defined($aws_hostname) or return; $aws_hostname =~ /^($aws_hostname_regex)$/ or return; return $1; } sub isAwsFqdn($){ my $aws_fqdn = shift; defined($aws_fqdn) or return; $aws_fqdn =~ /^($aws_fqdn_regex)$/ or return; return $1; } sub isAwsSecretKey($){ my $aws_secret_key = shift; defined($aws_secret_key) or return; $aws_secret_key =~ /^($aws_secret_key_regex)$/ or return; return $1; } sub isChars($$){ my $string = shift; my $chars = shift; defined($string) or return; defined($chars) or code_error "no chars passed to isChars"; $chars = isRegex("[$chars]") or code_error "invalid regex char range passed to isChars()"; $string =~ /^($chars+)$/ or return; return $1; } # isSub/isCode is used by set_timeout() to determine if we were passed a valid function for the ALRM sub sub isCode ($) { my $isCode = ref $_[0] eq "CODE"; return $isCode; } sub isCollection($){ my $collection = shift; defined($collection) or return; $collection =~ /^(\w(?:[\w\.]*\w)?)$/ or return; $collection = $1; return $collection; } #sub isDigit { # isInt(@_); #} *isDigit = \&isInt; sub isDatabaseName ($) { my $database = shift; defined($database) || return; $database =~ /^(\w+)$/ or return; $database = $1; return $database; } sub isDatabaseColumnName ($) { my $column = shift; defined($column) || return; $column =~ /^($column_regex)$/ or return; $column = $1; return $column; } sub isDatabaseFieldName ($) { my $field = shift; defined($field) || return; ( $field =~ /^(\d+)$/ or $field =~/^([A-Za-z][\w()*,._-]+[A-Za-z0-9)])$/ ) or return; return $1; } sub isDatabaseTableName ($;$) { my $table = shift; my $allow_qualified = shift; defined($table) || return; if($allow_qualified){ $table =~ /^([A-Za-z0-9][\w\.]*[A-Za-z0-9])$/i or return; return $1; } else { $table =~ /^([A-Za-z0-9]\w*[A-Za-z0-9])$/i or return; return $1; } return; } *isDatabaseViewName = \&isDatabaseTableName; sub isDomain ($) { my $domain = shift; defined($domain) or return; return if(length($domain) > 255); $domain =~ /^($domain_regex)$/ or return; return $1; } sub isDomainStrict ($) { my $domain = shift; defined($domain) or return; return if(length($domain) > 255); $domain =~ /^($domain_regex2)$/ or return; return $1; } *isDomain2 = \&isDomainStrict; sub isDnsShortname($){ my $name = shift; defined($name) or return; return if(length($name) < 3 or length($name) > 63); $name =~ /^($hostname_component)$/ or return; return $1; } # SECURITY NOTE: this only checks if the email address is valid, it's doesn't make it safe to arbitrarily pass to commands or SQL etc! sub isEmail ($) { my $email = shift; defined($email) or return; return if(length($email) > 256); $email =~ /^$email_regex$/ || return; # Intentionally not untainting this as it's not safe given the addition of ' to the $email_regex to support Irish email addresses return $email; } sub isFilename($){ my $filename = shift; return unless defined($filename); return if $filename =~ /^\s*$/; return if $filename =~ /\/$/; return unless($filename =~ /^($filename_regex)$/); return $1; } sub isDirname($){ my $dirname = shift; return unless defined($dirname); return if $dirname =~ /^\s*$/; return unless($dirname =~ /^($dirname_regex)$/); return $1; } sub isFloat ($;$) { my $number = shift; my $negative = shift() ? "-?" : ""; defined($number) or return; $number =~ /^$negative\d+(?:\.\d+)?$/; } sub isFqdn ($) { my $fqdn = shift; defined($fqdn) or return; return if(length($fqdn) > 255); $fqdn =~ /^($fqdn_regex)$/ or return; return $1; } sub isHash ($) { my $isHash; if(defined($_[0])){ $isHash = ref $_[0] eq "HASH"; } if($_[1]){ unless($isHash){ code_error "non hash reference passed"; } } return $isHash; } sub isHex ($) { my $hex = shift; defined($hex) or return; $hex =~ /^((?:0x)?[A-Fa-f\d]+)$/ or return; return 1; } sub isHost ($) { my $host = shift; defined($host) or return; # special case to short-circuit failure when chaining find_active_server.py if($host eq "NO_SERVER_AVAILABLE" or $host eq "NO_HOST_AVAILABLE"){ return; } # at casual glance this looks like it's duplicating isHostname but it's using a different unified regex of isHostname + isIP if(length($host) > 255){ # Can't be a hostname return; } elsif($host =~ /^($host_regex)$/){ $host = $1; return $host; } return; } sub isHostname ($) { my $hostname = shift; defined($hostname) or return; # special case to short-circuit failure when chaining find_active_server.py if($hostname eq "NO_SERVER_AVAILABLE" or $hostname eq "NO_HOST_AVAILABLE"){ return; } return if(length($hostname) > 255); $hostname =~ /^($hostname_regex)$/ or return; return $1; } sub isInt ($;$) { my $number = shift; my $signed = shift() ? "-?" : ""; defined($number) or return; # code_error("no number passed to isInt()"); $number =~ /^($signed\d+)$/; } sub isInterface ($) { my $interface = shift; defined($interface) || return; # TODO: consider checking if the interface actually exists on the system $interface =~ /^((?:em|eth|bond|lo|docker)\d+|lo|veth[A-Fa-f0-9]+)$/ or return; return $1; } sub isIP ($) { my $ip = shift; defined($ip) or return; $ip =~ /^($ip_regex)$/ or return; $ip = $1; my @octets = split(/\./, $ip); (@octets == 4) or return; foreach(@octets){ $_ < 0 and return; $_ > 255 and return; } # not disallowing 0 or 255 in final octet any more due to CIDR #$octets[3] eq 0 and return; #$octets[3] > 254 and return; return $ip; } sub isJavaBean ($) { my $string = shift; $string =~ /^([A-Za-z][A-Za-z0-9.,:=_-]+[A-Za-z0-9])$/ or return undef; return $1; } sub isJavaException ($) { my $string = shift; if($string =~ /(?:^\s+at|^Caused by:)\s+\w+(?:\.\w+)+/){ #debug "skipping java exception \\s+at|^Caused by => '$string'"; return 1; } elsif($string =~ /\(.+:[\w-]+\(\d+\)\)/){ #debug "skipping java exception (regex):\\w(\\d+) => '$string'"; return 1; } elsif($string =~ /(\b|_).+\.\w+Exception:/){ #debug "skipping java exception regex\\.\\w+Exception: => '$string'"; return 1; } elsif($string =~ /^(?:\w+\.)*\w+Exception:/){ #debug "skipping java exception (?:\\w+\\.)*\\w+Exception: => '$string'"; return 1; } elsif($string =~ /\$\w+\(\w+:\d+\)/){ #debug "skipping java exception \$\\w+(regex) => '$string'"; return 1; #} elsif($string =~ /\s\w+\s\[[\w-]+\]\s[A-Z][a-z]+(?:[A-Z][a-z]+)+:\d+\s/){ #debug "skipping java exception \\w+\\s\\[[\\w-]+\\]\\s[A-Z][a-z]+(?:[A-Z][a-z]+)+:\\d+\\s => '$string'"; #return 1; } return; } # wish there was a better way of validating the JSON returned but Test::JSON is_valid_json() also errored out badly from underlying JSON::Any module, similar to JSON's decode_json #sub isJson($){ # my $data = shift; # defined($data) or return; # # slightly modified from http://stackoverflow.com/questions/2583472/regex-to-validate-json # # XXX: Unfortunately this only work on RHEL6's version of Perl and parse failure breaks all dependent code on RHEL5 now ## my $json_regex = qr/ ## (?(DEFINE) ## (? -? (?= [1-9]|0(?!\d) ) \d+ (\.\d+)? ([eE] [+-]? \d+)? ) ## (? true | false | null ) ## (? " ([^"\\\\]* | \\\\ ["\\\\bfnrt\/] | \\\\ u [0-9a-f]{4} )* " ) ## (? \[ (?: (?&json) (?: , (?&json) )* )? \s* \] ) ## (? \s* (?&string) \s* : (?&json) ) ## (? \{ (?: (?&pair) (?: , (?&pair) )* )? \s* \} ) ## (? \s* (?: (?&number) | (?&boolean) | (?&string) | (?&array) | (?&object) ) \s* ) ## ) ## \A (?&json) \Z ## /six; # # TODO: reinvestigate if this can be made to work ## my $json; ## my $number = qr/(-? (?= [1-9]|0(?!\d) ) \d+ (\.\d+)? ([eE] [+-]? \d+)?)/six; ## my $boolean = qr/(true | false | null)/six; ## my $string = qr/(" ([^"\\\\]* | \\\\ ["\\\\bfnrt\/] | \\\\ u [0-9a-f]{4} )* ")/six; ## my $array = qr/(\[ (?: (&$json) (?: , (&$json) )* )? \s* \])/six; ## my $pair = qr/\s* ($string) \s* : ($json)/six; ## my $object = qr/(\{ (?: ($pair) (?: , ($pair) )* )? \s* \})/six; ## $json = qr/(\s* (?: ($number) | ($boolean) | ($string) | ($array) | ($object) ) \s*)/six; ## my $json_regex = qr/\A ($json) \Z/six; # #if($data =~ $json_regex){ # # return 1; # #} # return 0; #} sub isJson($){ my $string = shift; defined($string) or return; my $json = undef; try { $json = decode_json($string); }; return $json; } sub isXml($){ require XML::Simple; import XML::Simple; my $string = shift; defined($string) or return; my $xml = undef; try { $xml = XMLin($string, forcearray => 1, keyattr => []); }; return $xml; } sub isKrb5Princ ($) { my $principal = shift; defined($principal) or return; $principal =~ /^($krb5_principal_regex)$/ or return; return $1; } # Primarily for Nagios perfdata labels sub isLabel ($) { my $label = shift; defined($label) or return; $label =~ /^$label_regex$/ or return; return $label; } sub isLdapDn ($) { #subtrace(@_); my $dn = shift; defined($dn) or return; $dn =~ /^($ldap_dn_regex)$/ || return; return $1; } sub isMinVersion ($$) { my $version = shift; my $min = shift; if(not isVersionLax($version)){ warn(sprintf("'%s' is not a recognized version format", $version)); return; } isFloat($min) or code_error("invalid second arg passed to min_version"); if($version =~ /(\d+(?:\.\d+)?)/){ my $detected_version = $1; if($detected_version >= $min){ return $detected_version; } } return; } sub isNagiosUnit ($) { my $units = shift; defined($units) or return; foreach(@valid_units){ if(lc $units eq lc $_){ return $_; } } return; } sub isNoSqlKey ($) { my $key = shift; defined($key) or return; $key =~ /^([\w\_\,\.\:\+\-]+)$/ or return; $key = $1; return $key; } sub isObject ($) { my $object = shift; return blessed($object); } sub isPathQualified($){ my $path = shift; $path =~ /^(?:\.?\/)/; } sub isPort ($) { my $port = shift; defined($port) or return; $port =~ /^(\d+)$/ || return; $port = $1; ($port >= 1 && $port <= 65535) || return; return $port; } sub isProcessName ($) { my $process = shift; defined($process) or return; $process =~ /^($process_name_regex)$/ or return; return $1; } sub isPythonTraceback ($) { my $string = shift; if($string =~ /\bFile "$filename_regex", line \d+, in (?:|[A-Za-z]+)/){ #debug "skipping python traceback 'File "...", line \\d+, in ...'; return 1; } if($string =~ /\bTraceback \(most recent call last\):/){ #debug "skipping python traceback 'Traceback \(most recent call last\)'"; return 1; } return; } # XXX: doesn't catch error before Perl errors out, only using for late loading of regex from files, not in validate_regex() sub isRegex ($) { my $regex = shift; defined($regex) || code_error "no regex arg passed to isRegex()"; #defined($regex) || return; #vlog3("testing regex '$regex'"); if(eval { qr/$regex/ }){ return $regex; } else { return; } } sub isRef ($;$) { my $isRef = ref $_[0] eq "REF"; if($_[1]){ unless($isRef){ code_error "non REF reference passed"; } } return $isRef; } sub isScalar ($;$) { my $arg = shift; my $quit = shift; my $ref = ref $arg; my $isScalar = 0; # needs more testing and thought before I can enable this #if(not $ref or $ref eq "SCALAR" or $ref eq "JSON::PP::Boolean"){ if($ref eq "SCALAR"){ $isScalar = 1; } if($quit and !$isScalar){ code_error "non scalar reference passed"; } return $isScalar; } sub isScientific($;$){ my $num = shift; my $negative = shift() ? "-?" : ""; defined($num) or code_error "no arg passed to isScientific()"; $num =~ /^$negative\d+(?:\.\d+)?e[+-]?\d+$/i or return; return $num; } #sub isSub { # isCode(@_); #} *isSub = \&isCode; sub isThreshold($){ my $threshold = shift; defined($threshold) or code_error "threshold arg to isThreshold() not defined"; if($threshold =~ $threshold_range_regex){ return 1; } elsif($threshold =~ $threshold_simple_regex){ return 1; } return 0; } sub isUrl ($) { my $url = shift; defined($url) or return; #debug("url_regex: $url_regex"); $url = trim($url); $url = "http://$url" unless $url =~ /:\/\//i; $url =~ /^($url_regex)$/ or return; return $1; } sub isUrlPathSuffix ($) { my $url = shift; defined($url) or return; $url =~ /^($url_path_suffix_regex)$/ or return; return $1; } sub isUser ($) { #subtrace(@_); my $user = shift; defined($user) or return; # code_error "user arg not passed to isUser()"; $user =~ /^($user_regex)$/ || return; return $1; } sub isVersion($){ my $version = shift; defined($version) or return; $version =~ /^($version_regex)$/ || return; return $1; } sub isVersionLax($){ my $version = shift; defined($version) or return; # would use version_regex_lax but need to capture and don't want to force capture in the regex as that can mess with client code captures $version =~ /^($version_regex)-?.*$/ || return; return $1; } # =============================== OS CHECKS ================================== # sub isOS ($) { $^O eq shift; } sub isMac () { isOS "darwin"; } sub isLinux () { isOS "linux"; } sub isLinuxOrMac () { isLinux() or isMac(); } our $supported_os_msg = "this program is only supported on %s at this time"; sub mac_only () { isMac or quit("UNKNOWN", sprintf($supported_os_msg, "Mac/Darwin") ); } sub linux_only () { isLinux or quit("UNKNOWN", sprintf($supported_os_msg, "Linux") ); } sub linux_mac_only () { isLinuxOrMac or quit("UNKNOWN", sprintf($supported_os_msg, "Linux or Mac/Darwin") ); } # ============================================================================ # sub loginit () { # This can cause plugins to fail if there is no connection to syslog available at plugin INIT # Let's only use this for something that really needs it #INIT { #require Sys::Syslog; #import Sys::Syslog qw(:standard :macros); # Can't actually require/import optimize here because barewards aren't recognized early enough which breaks strict use Sys::Syslog qw(:standard :macros); # nofatal doesn't appear in earlier 5.x versions #openlog $progname, "ndelay,nofatal,nowait,perror,pid", LOG_LOCAL0; openlog $progname, "ndelay,nowait,perror,pid", LOG_LOCAL0; $syslog_initialized = 1; #} } sub log (@) { loginit() unless $syslog_initialized; # For some reason perror doesn't seem to print so do it manually here print strftime("%F %T", localtime) . " $progname\[$$\]: @_\n"; syslog LOG_INFO, "%s", "@_"; } sub logdie (@) { &log("ERROR: @_"); exit get_status_code("CRITICAL"); } sub lstrip ($) { my $string = shift; #defined($string) or code_error "no arg passed to lstrip()"; $string =~ s/^\s+//o; return $string; } #sub ltrim { lstrip(@_) } *ltrim = \&lstrip; sub minimum_value ($$) { my $value = shift; my $min = shift; isFloat($value) or code_error "invalid first arg passed to minimum_value(), must be float"; isFloat($min) or code_error "invalid second arg passed to minimum_value(), must be float"; if($value < $min){ return $min; } return $value; } sub msg_perf_thresholds (;$$$) { my $return = shift; my $type = shift() ? "lower" : "upper"; my $name = shift() || ""; $name .= " " if $name and $name !~ / $/; my $tmp = ";"; $tmp .= $thresholds{"${name}warning"}{$type} if defined($thresholds{"${name}warning"}{$type}); $tmp .= ";"; $tmp .= $thresholds{"${name}critical"}{$type} if defined($thresholds{"${name}critical"}{$type}); $tmp .= ";"; if(defined($return) and $return){ return $tmp; } else { $msg .= $tmp; } } sub msg_thresholds (;$$) { my $no_msg_thresholds = shift || 0; my $name = shift() || ""; my $msg2 = ""; if (defined($thresholds{"${name}critical"}{"error"}) or defined($thresholds{"${name}warning"}{"error"}) or ($verbose and ( defined($thresholds{"${name}warning"}{"range"}) or defined($thresholds{"${name}critical"}{"range"}) ) ) ) { $msg2 .= " ("; if(defined($thresholds{"${name}critical"}{"error"})){ $msg2 .= $thresholds{"${name}critical"}{"error"} . ", "; } elsif(defined($thresholds{"${name}warning"}{"error"})){ $msg2 .= $thresholds{"${name}warning"}{"error"} . ", "; } if(defined($thresholds{"${name}warning"}{"range"})){ $msg2 .= "w=" . $thresholds{"${name}warning"}{"range"}; } if(defined($thresholds{"${name}warning"}{"range"}) and defined($thresholds{"${name}critical"}{"range"})){ $msg2 .= "/"; } if(defined($thresholds{"${name}critical"}{"range"})){ $msg2 .= "c=" . $thresholds{"${name}critical"}{"range"}; } $msg2 .= ")"; } unless($no_msg_thresholds){ $msg .= $msg2 if $msg2; } return $msg2; } sub month2int($){ my $month = shift; defined($month) or code_error "no arg passed to month2int"; my %months = ( "Jan" => 0, "Feb" => 1, "Mar" => 2, "Apr" => 3, "May" => 4, "Jun" => 5, "Jul" => 6, "Aug" => 7, "Sep" => 8, "Oct" => 9, "Nov" => 10, "Dec" => 11 ); grep { $month eq $_ } keys %months or code_error "non-month passed to month2int()"; return $months{$month}; } sub open_file ($;$) { my $filename = shift; my $lock = shift; #my $mode = shift; my $tmpfh; defined($filename) or code_error "no filename given to open_file()"; ( -e $filename ) or quit("CRITICAL", "file not found: '$filename'"); ( -f $filename ) or quit("CRITICAL", "not a valid file: '$filename'"); ( -r $filename ) or quit("CRITICAL", "file not readable: '$filename'"); vlog2("opening file: '$filename'"); open $tmpfh, "$filename" or quit("UNKNOWN", "Error: failed to open file '$filename': $!"); if($lock){ flock($tmpfh, LOCK_EX | LOCK_NB) or quit("UNKNOWN", "Failed to aquire a lock on file '$filename', another instance of this code may be running?"); } return $tmpfh; } sub parse_file_option($;$){ my $file = shift; my $file_args = shift; my @files; my @tmp; if($file){ my @tmp = split(/\s*[\s,]\s*/, $file); push(@files, @tmp); } if($file_args){ # @ARGV should only be used after get_options() foreach(@ARGV){ push(@files, $_); } } foreach my $f (@files){ if(not -f $f ){ print STDERR "File not found: '$f'\n"; @files = grep { $_ ne $f } @files; } } if($file or ($file_args and @ARGV)){ if(not @files){ die "Error: no files found\n"; } } vlog_option("files", "[ '" . join("', '", @files) . "' ]"); return @files; } sub perf_suffix($){ my $key = shift; my $prefix = '[\b\s\._-]'; if($key =~ /${prefix}bytes$/){ return "b"; } elsif($key =~ /${prefix}millis$/){ return "ms"; } return ""; } # parsing ps aux is more portable than pkill -f command. Useful for alarm sub # Be careful to validate and make sure you use taint mode before calling this sub sub pkill ($;$) { my $search = $_[0] || code_error "No search arg specified for pkill sub"; my $kill_args = $_[1] || ""; $search =~ s/(\/)/\\$1/g; $search =~ s/'/./g; return `ps aux | awk '/$search/ {print \$2}' | while read pid; do kill $kill_args \$pid >/dev/null 2>&1; done`; } our $plural; sub plural ($) { my $var = $_[0]; #print "var = $var\n"; #print "var ref = " . ref($var) . "\n"; if(isArray($var)){ $var = scalar(@{$var}); } elsif (isHash($var)){ $var = scalar keys %{$var}; # TODO: enable this, currently doesn't work #} elsif (not isFloat($var)) { # code_error "non-scalar, non-array ref and non-hash ref passed to plural()"; } isFloat($var) or code_error("arg passed to plural() is not a float"); ( $var == 1 ) ? ( $plural = "" ) : ( $plural = "s" ); } my ($wchar, $hchar, $wpixels, $hpixels); sub print_options (@) { check_terminal_size(); #subtrace(@_); my $switch_width = $short_options_len + 2 + $long_options_len + 4 - 1; my $desc_width = $wchar - $switch_width; foreach my $option (@_){ my $option_regex = $option; $option_regex =~ s/^\w\|//; $option_regex =~ s/=.*$//; # pointless since this is hardcoded Perl interpreter will always error out first #$option_regex = isRegex($option_regex) || code_error "invalid option regex '$option_regex' passed in \@options array to print_options()"; #debug "\noption is $option"; if($option =~ /debug/){ #debug "skipping debug option"; next; } foreach(keys %options){ #debug $_; #debug $options{$_}; #debug "options long value is $options{$_}{desc}"; if($options{$_}{"long"} =~ /^.*--(?:$option_regex)\s*$/ or $options{$_}{"short"} =~ /^-(?:$option_regex)\s*$/){ # This format string must match the length of $switch_width at top of sub printf STDERR "%-${short_options_len}s %-${long_options_len}s ", $options{$_}{"short"}, $options{$_}{"long"}; my $option_desc_len = length($options{$_}{"desc"}); for(my $start=0; $start < $option_desc_len; ){ my ($len, $end); if($option_desc_len - $start < $desc_width){ $end = $option_desc_len; } else { my $space_index = rindex($options{$_}{"desc"}, " ", $start + $desc_width - 1); if($space_index > $start){ $end = $space_index; } else{ $space_index = index($options{$_}{"desc"}, " ", $start); if($space_index > $start){ $end = $space_index; } else { $end = $option_desc_len; } } } $end > $start or $end = $option_desc_len; $len = $end - $start; if($start > 0){ # and $end <= $option_desc_len){ printf STDERR "%${switch_width}s", ""; } printf STDERR "%s\n", substr($options{$_}{"desc"}, $start, $len); $start = $end; } delete $options{$_}; last; } } } 1; } sub prompt($){ my $question = shift; print "\n$question "; my $response = ; chomp $response; vlog(); return $response; } sub isYes($;$$){ my $val = shift; my $name = shift() || ""; my $noquit = shift; $name = " for $name"; unless($val =~ /^\s*(?:y(?:es)?|n(?:o)?)?\s*$/i){ die "invalid response$name, must be 'yes' or 'no'\n" unless $noquit; } if($val =~ /^\s*y(?:es)?\s*$/i){ return 1; } else { return 0; } } # Also prototyped at top to allow me to call it earlier sub quit (@) { if($status_prefix ne ""){ $status_prefix .= " "; } if(@_ eq 0){ chomp $msg; # This ends up bit shifting to 255 instead of 0 grep(/^$status$/, keys %ERRORS) or die "Code error: unrecognized exit code '$status' specified on quit call, not found in %ERRORS hash\n"; # XXX: do not use die function, some modules call die without setting $? to something other than zero, causing an OK: prefix and zero exit code :-/ #$? = $ERRORS{$status}; #die "${status_prefix}$status: $msg\n"; #die "$msg\n"; print "${status_prefix}$status: $msg\n"; exit $ERRORS{$status}; } elsif(@_ eq 1){ $msg = $_[0]; chomp $msg; #$? = $ERRORS{"CRITICAL"}; #die "${status_prefix}CRITICAL: $msg\n"; #die "$msg\n"; print "${status_prefix}CRITICAL: $msg\n"; exit $ERRORS{"CRITICAL"}; } elsif(@_ eq 2) { $status = $_[0]; $msg = $_[1]; $msg or $msg = "msg not defined"; chomp $msg; grep(/^$status$/, keys %ERRORS) or die "Code error: unrecognized exit code '$status' specified on quit call, not found in %ERRORS hash\n"; #$? = $ERRORS{$status}; #die "${status_prefix}$status: $msg\n"; #die "$msg\n"; print "${status_prefix}$status: $msg\n"; exit $ERRORS{$status}; } else { #print "UNKNOWN: Code Error - Invalid number of arguments passed to quit function (" . scalar(@_). ", should be 0 - 2)\n"; #exit $ERRORS{"UNKNOWN"}; code_error("invalid number of arguments passed to quit function (" . scalar(@_) . ", should be 0 - 2)"); } } sub random_alnum($){ my $length = shift; isInt($length) or code_error "invalid length passed to random_alnum"; my @chars = ("A".."Z", "a".."z", 0..9); my $string = ""; $string .= $chars[rand @chars] for 1..$length; return $string; } sub remove_timeout(){ delete $HariSekhonUtils::default_options{"t|timeout=i"}; } sub resolve_ip ($) { require Socket; import Socket; my $ip; defined($_[0]) or return; # returns packed binary address $ip = inet_aton($_[0]) || return; # returns human readable x.x.x.x - only supporting IPv4 for now $ip = inet_ntoa($ip) || return; # validate what we have is a correct IP address $ip = isIP($ip) || return; return $ip; } sub rstrip ($) { my $string = shift; defined($string) or code_error "no arg passed to rstrip()"; $string =~ s/\s+$//; return $string; } #sub rtrim { rstrip(@_) } *rtrim = \&rstrip; sub sec2min ($){ my $secs = shift; isFloat($secs) or return; return sprintf("%d:%.2d", int($secs / 60), $secs % 60); } # Time::Seconds and Time::Piece are available from Perl v5.9.5 but CentOS 5 is v5.8 sub sec2human ($){ my $secs = shift; isFloat($secs) or code_error "invalid non-float argument passed to sec2human"; my $human_time = ""; if($secs >= 86400){ my $days = int($secs / 86400); plural $days; $human_time .= sprintf("%d day$plural ", $days); $secs %= 86400; } if($secs >= 3600){ my $hours = int($secs / 3600); plural $hours; $human_time .= sprintf("%d hour$plural ", $hours); $secs %= 3600; } if($secs >= 60){ my $mins = int($secs / 60); plural $mins; $human_time .= sprintf("%d min$plural ", $mins); $secs %= 60; } plural $secs; $human_time .= sprintf("%d sec$plural", int($secs)); return $human_time; } sub set_http_timeout($){ my $http_timeout = shift; isFloat($http_timeout) or code_error "invalid arg passed to set_http_timeout(), must be float"; defined_main_ua(); $http_timeout = sprintf("%.2f", minimum_value($http_timeout, 1) ); vlog2("setting http per request timeout to $http_timeout secs\n"); $main::ua->timeout($http_timeout); } sub set_sudo (;$) { local $user = $_[0] if defined($_[0]); defined($user) or code_error "user arg not passed to set_sudo() and \$user not defined in outer scope"; # Quit if we're not the right user to ensure we don't sudo command and hang or return with a generic timeout error message #quit "UNKNOWN", "not running as '$hadoop_user' user"; # only Mac has -n switch for non-interactive :-/ #$sudo = "sudo -n -u $hadoop_user "; if(getpwuid($>) eq $user){ $sudo = ""; } else { vlog2("EUID doesn't match user $user, using sudo\n"); $sudo = "echo | sudo -S -u $user "; } } sub set_timeout (;$$) { $timeout = $_[0] if $_[0]; my $sub_ref; $sub_ref = $_[1] if $_[1]; $timeout =~ /^\d+$/ || usage("timeout value must be a positive integer\n"); ($timeout >= $timeout_min && $timeout <= $timeout_max) || usage("timeout value must be between $timeout_min - $timeout_max secs\n"); if(defined($sub_ref)){ isSub($sub_ref) or code_error "invalid sub ref passed to set_timeout()"; } $SIG{ALRM} = sub { &$sub_ref if defined($sub_ref); quit("UNKNOWN", "self timed out after $timeout seconds" . ($timeout_current_action ? " while $timeout_current_action" : "")); }; #verbose_mode() unless $_[1]; vlog2("setting timeout to $timeout secs\n"); # alarm returns the time of the last timer, on first run this is zero so cannot die here alarm($timeout) ;#or die "Failed to set time to $timeout"; } #sub sub_noarg { # quit "UNKNOWN", "Code Error: no arg supplied to subroutine " . (caller(1))[3]; #} sub skip_java_output($){ @_ or code_error "no input passed to skip_java_output()"; my $str = join(" ", @_); # warning due to Oracle 7 JDK bug fixed in 7u60 # objc[54213]: Class JavaLaunchHelper is implemented in both /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/bin/java and /Library/Java/JavaVirtualMachines/jdk1.7.0_45.jdk/Contents/Home/jre/lib/libinstrument.dylib. One of the two will be used. Which one is undefined. if($str =~ /Class JavaLaunchHelper is implemented in both|^SLF4J/){ return 1; } return 0; } sub strBool($){ my $str = shift; # " " returns true otherwise $str = strip($str); return "false" if $str =~ /false/i; ( $str ? "true" : "false" ); } sub strip ($) { my $string = shift; defined($string) or code_error "no arg passed to strip()"; $string =~ s/^\s+//o; $string =~ s/\s+$//o; return $string; } *trim = \&strip; sub strip_ansi_escape_codes ($) { my $string = shift; # will only strip color codes, but want to strip all ansi escape codes for use in anoymize.pl to avoid non-printing chars from breaking anonymizations ##$string = colorstrip($string); #$string =~ s/\x1b\[[0-9;]*m//gio; #$string =~ s/\x1b\[[0-9;]*[a-zA-Z]//gio; # ported from https://github.com/HariSekhon/pylib $string =~ s/(\x9B|\x1B\[)[0-?]*[ -\/]*[@-~]//gio; return $string; } sub subtrace (@) { #@_ || code_error("\@_ not passed to subtrace"); return unless ($debug >= 2); my ( $package, $filename, $line ) = caller; my $debug_msg = "entering with args: @_"; $debug_msg =~ s/^(\n+)//; my $prefix_newline = $1 || ""; # TODO: can improve this if we can go one level up, dedupe with debug, do this later printf "${prefix_newline}debug: %s() => $debug_msg\n", (caller(1))[3]; } sub timecomponents2days($$$$$$){ my $year = shift; my $month = shift; my $day = shift; my $hour = shift; my $min = shift; my $sec = shift; my $month_int; if(isInt($month)){ $month_int = $month - 1; } else { $month_int = month2int($month); } my $epoch = timegm($sec, $min, $hour, $day, $month_int, $year - 1900) || code_error "failed to convert timestamp $year-$month-$day $hour:$min:$sec"; my $now = time || code_error "failed to get epoch timestamp"; return ($epoch - $now) / (86400); } sub tstamp () { return strftime("%F %T %z ", localtime); } sub tprint ($) { my $msg = shift; defined($msg) or code_error "tprint msg arg not defined"; print tstamp() . "$msg\n"; } sub trim_float ($) { my $num = shift; defined($num) or code_error "no arg passed to trim_float()"; $num =~ s/\.0+$//; $num =~ s/\.([1-9]*)0+$/\.$1/; return $num; } #sub type { # my $builtin = $_[0] || code_error "no arg supplied to which() subroutine"; # my $quit = $_[1] || 0; # $builtin =~ /^([\w-]+)$/ or quit "UNKNOWN", "invalid command/builtin passed to type subroutine"; # $builtin = $1; # `type $builtin`; # return 1 if($? == 0); # quit "UNKNOWN", "$builtin is not a shell built-in" if $quit; # return; #} sub sort_insensitive (@) { my @array = @_; # or code_error "no arg passed to sort_insensitive()"; isArray(\@array) or code_error "sort_insensitive() was passed a non-array"; scalar @array or code_error "sort_insensitive() was passed an empty array"; return sort { "\L$a" cmp "\L$b" } @array; } sub uniq_array (@) { my @array = @_; # or code_error "no arg passed to uniq_array"; isArray(\@array) or code_error "uniq_array was passed a non-array"; scalar @array or code_error "uniq_array was passed an empty array"; return sort keys %{{ map { $_ => 1 } @array }}; } sub uniq_array2(@){ my @array = @_; # or code_error "no arg passed to uniq_array"; isArray(\@array) or code_error "uniq_array2 was passed a non-array"; scalar @array or code_error "uniq_array2 was passed an empty array"; my @array2; my $item; foreach $item (@array){ grep { $item eq $_ } @array2 and next; push(@array2, $item); } return @array2; } *uniq_array_ordered = \&uniq_array2; sub get_terminal_size(){ eval { local $SIG{__WARN__} = sub {}; try { ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize(); }; catch { ($wchar, $hchar) = (80, 25); } }; check_terminal_size(); } sub check_terminal_size(){ unless(defined($wchar) and defined($hchar) and defined($wpixels) and defined($hpixels)){ #warn "\nTerm::ReadKey GetTerminalSize() failed to return values! Ignore this warning if you are teeing to a logfile (otherwise your terminal is messed up...)\n\n\n"; $wchar = 99999999; $hchar = 99999999; $wpixels = 99999999; $hpixels = 99999999; } # Travis gets suspiciously small width if($wchar < 80){ $wchar = 80; } if($hchar < 25){ $hchar = 25; } 1; } sub usage (;@) { get_terminal_size(); print STDERR "@_\n\n" if (@_); if(not @_ and $main::DESCRIPTION){ print STDERR "Hari Sekhon - https://github.com/harisekhon"; if($github_repo){ print STDERR "/$github_repo"; } elsif(dirname(abs_path(__FILE__)) =~ /nagios-plugins/i or $main::DESCRIPTION =~ /Nagios/i){ print STDERR "/nagios-plugins"; } elsif(dirname(abs_path(__FILE__)) =~ /tools/i){ print STDERR "/devops-perl-tools"; } elsif(dirname(abs_path(__FILE__)) =~ /lib/i){ print STDERR "/lib"; } print STDERR "\n\n$progname\n\n"; #print STDERR "$main::DESCRIPTION\n\n"; my $desc_len = length($main::DESCRIPTION); for(my $start=0; $start < $desc_len; ){ #print "desc len $desc_len\n"; #print "start $start\n"; my ($len, $end); # reset the start to after newlines # the problem is that the start is taken across newlines if(($desc_len - $start) < $wchar){ $end = $desc_len; } else { my $newline_index = rindex($main::DESCRIPTION, "\n", $start + $wchar - 1); my $space_index = rindex($main::DESCRIPTION, " ", $start + $wchar - 1); if($newline_index > $start){ #print "newline index $newline_index\n"; $end = $newline_index; } elsif($space_index > $start){ $end = $space_index; } else{ $newline_index = index($main::DESCRIPTION, "\n", $start); if($newline_index > $start){ $end = $newline_index; } else { $end = $desc_len; } } } #print "end $end\n"; $end > $start or $end = $desc_len; $len = $end - $start; #print "len $len\n"; printf STDERR "%s\n", substr($main::DESCRIPTION, $start, $len); $start = $end + 1; } print STDERR "\n"; } print STDERR "$usage_line\n\n"; foreach my $key_orig (sort keys %options){ my $key = $key_orig; $key =~ s/=.*$//; $key =~ s/\+//; code_error("invalid array count in value for key '$key' in options hash") unless(scalar(@{$options{$key_orig}}) == 2); $options{$key} = $options{$key_orig}[1]; #debug "key: $key key_orig: $key_orig"; delete $options{$key_orig} if($key ne $key_orig); } foreach(sort keys %options){ my $option = ""; my @short_options = (); my @long_options = (); if($_ =~ /\|/){ @_ = split('\|', $_); foreach(@_){ if(length($_) == 1){ push(@short_options, "-$_"); } else { push(@long_options, "--$_"); } } } else { if(length($_) == 1){ push(@short_options, "-$_"); } else { push(@long_options, "--$_"); } } #debug "$_ short_options: " . join(",", @short_options) . " long_options:" . join(",", @long_options) . " desc: $options{$_}"; $options{$_} = { "short" => join(" ", @short_options), "long" => join(" ", @long_options), "desc" => $options{$_} }; } foreach(sort keys %options){ $short_options_len = length($options{$_}{"short"}) if($short_options_len < length($options{$_}{"short"})); $long_options_len = length($options{$_}{"long"} ) if($long_options_len < length($options{$_}{"long"} )); } # First print options in the order specified in @usage_order print_options(@usage_order); # Now print any unspecified order options in alphabetical order foreach my $option (sort keys %options){ #debug "iterating over general options $option"; # TODO: improve this matching for more than one long opt my $option_regex = escape_regex($option); if(grep($_ =~ /\A$option_regex\Z/, keys %default_options)){ #debug "skipping $option cos it matched \%default_options"; next; } print_options($option); #printf "%-${short_options_len}s %-${long_options_len}s \t%s\n", $options{$option}{"short"}, $options{$option}{"long"}, $options{$option}{"desc"}; } # Finally print base common options, verbosity, timeout etc print_options(sort { lc($a) cmp lc($b) } keys %default_options); exit $ERRORS{"UNKNOWN"}; } sub user_exists ($) { my $user = shift; # if $_[0]; #defined($user) or code_error("no user passed to user_exists()"); #$user = isUser($user) || return; # using id command since this should exist on most unix systems #which("id", 1); #`id "$user" >/dev/null 2>&1`; #return 1 if ( $? eq 0 ); #return; # More efficient return defined(getpwnam($user)); } sub validate_alnum($$){ my $arg = shift; my $name = shift || croak "second argument (name) not defined when calling validate_alnum()"; defined($arg) or usage "$name not defined"; $arg = isAlNum($arg); # isAlNum returns zero as valid and undef when not valid so must check explicitly for undef and avoid 0 which is false in Perl defined($arg) || usage "invalid $name defined: must be alphanumeric"; vlog_option($name, $arg); return $arg; } sub validate_aws_access_key($){ my $aws_access_key = shift; defined($aws_access_key) or usage "aws access key not defined"; $aws_access_key = isAwsAccessKey($aws_access_key) || usage "invalid aws access key defined: must be 20 uppercase alphanumeric characters"; vlog_option("aws access key", "X"x18 . substr($aws_access_key, 18, 2)); return $aws_access_key; } sub validate_aws_bucket($){ my $bucket = shift; defined($bucket) or usage "no aws bucket specified"; $bucket = isDnsShortname($bucket) || usage "invalid aws bucket name defined: must be alphanumeric between 3 and 63 characters long"; isIP($bucket) and usage "invalid aws bucket name defined: may not be formatted as an IP address"; vlog_option("aws bucket", $bucket); return $bucket; } sub validate_aws_secret_key($){ my $aws_secret_key = shift; defined($aws_secret_key) or usage "aws secret key not defined"; $aws_secret_key = isAwsSecretKey($aws_secret_key) || usage "invalid aws secret key defined: must be 40 alphanumeric characters"; vlog_option("aws secret key", "X"x38 . substr($aws_secret_key,38, 2)); return $aws_secret_key; } # Takes a 3rd arg as a regex char range sub validate_chars($$$){ my $string = shift; my $name = shift || croak "second argument (name) not defined when calling validate_chars()"; my $chars = shift; defined($string) or usage "$name not defined"; $string = isChars($string, $chars) || usage "invalid $name defined: must contain only the following chars - $chars"; vlog_option($name, $string); return $string; } sub validate_collection ($;$) { my $collection = shift; my $name = shift || ""; $name .= " " if $name; defined($collection) or usage "${name}collection not defined"; $collection = isCollection($collection) || usage "invalid ${name}collection defined: must be alphanumeric, with optional periods in the middle"; vlog_option("${name}collection", $collection); return $collection; } sub validate_database ($;$) { my $database = shift; my $name = shift || ""; $name .= " " if $name; defined($database) || usage "${name}database not defined"; $database = isDatabaseName($database) || usage "invalid ${name}database defined: must be alphanumeric"; vlog_option("${name}database", $database); return $database; } sub validate_database_columnname ($) { my $column = shift; defined($column) || usage "column not defined"; $column = isDatabaseColumnName($column) || usage "invalid column defined: must be alphanumeric"; vlog_option("column", $column); return $column; } sub validate_database_fieldname ($) { my $field = shift; defined($field) || usage "field not defined"; $field = isDatabaseFieldName($field) || usage "invalid field defined: must be a positive integer, or a valid field name"; ($field eq "0") and usage "invalid field defined: cannot be zero"; vlog_option("field", $field); return $field; } sub validate_database_tablename ($;$$) { my $table = shift; my $name = shift; my $allow_qualified = shift; $name .= " " if $name; defined($table) || usage "${name}table not defined"; $table = isDatabaseTableName($table, $allow_qualified) || usage "invalid ${name}table defined: must be alphanumeric"; vlog_option("${name}table", $table); return $table; } sub validate_database_viewname ($;$$) { my $view = shift; my $name = shift; my $allow_qualified = shift; $name .= " " if $name; defined($view) || usage "${name}view not defined"; $view = isDatabaseViewName($view, $allow_qualified) || usage "invalid ${name}view defined: must be alphanumeric"; vlog_option("${name}view", $view); return $view; } sub validate_database_query_select_show ($;$) { my $query = shift; my $name = shift || ""; $name .= " " if $name; defined($query) || usage "${name}query not defined"; #$query =~ /^\s*((?i:SHOW|SELECT)\s[\w\s;:,\.\?\(\)*='"-]+)$/ || usage "invalid query supplied"; #debug("regex validating query: $query"); $query =~ /^\s*((?:SHOW|SELECT)\s+.+)$/i || usage "invalid ${name}query defined: may only be a SELECT or SHOW statement"; $query = $1; $query =~ /\b(?:insert|update|delete|create|drop|alter|truncate)\b/i and usage "invalid ${name}query defined: found DML statement keywords!"; # this trips up users who put ; at the end of their query and doesn't offer that much protection anyway since DML is already checked for and it may be convenient to comment out end of query for testing #$query =~ /;|--/i and usage "invalid ${name}query defined: suspect chars ';' or '--' detected in query!"; $query =~ /;/ and usage "invalid ${name}query defined: you may not add semi-colons to your queries, while it works on the command line, Nagios ends up choking by prematurely terminating the check command resulting in a null shell error before this plugin executes so the error handlers in this code do not have any chance to catch it"; vlog_option("${name}query", $query); return $query; } #sub validate_dir ($;$) { # validate_directory(@_); #} sub validate_dirname ($;$$$) { my $dirname = shift; my $name = shift || ""; my $noquit = shift; my $no_vlog = shift; $name .= " " if $name; if(not defined($dirname) or $dirname =~ /^\s*$/){ usage "${name}directory not defined"; return; } my $dirname2; unless($dirname2 = isDirname($dirname)){ usage "invalid ${name}directory (does not match regex critera): '$dirname'" unless $noquit; return; } vlog_option("${name}directory", $dirname2) unless $no_vlog; return $dirname2; } sub validate_directory ($;$$$) { my $dir = shift; my $name = shift || ""; my $noquit = shift; my $no_vlog = shift; $name .= " " if $name; if($noquit){ return validate_dirname($dir, $name, "noquit"); } defined($dir) || usage "${name}directory not defined"; $dir = validate_dirname($dir, $name, "noquit", $no_vlog) || usage "invalid ${name}directory (does not match regex criteria): '$dir'"; ( -d $dir) || usage "cannot find ${name}directory: '$dir'"; return $dir; } *validate_dir = \&validate_directory; sub validate_domain ($;$) { my $domain = shift; my $name = shift || ""; $name .= " " if $name; defined($domain) || usage "${name}domain name not defined"; # don't print the domain as it gets reset to undef and results in "Use of uninitialized value $domain in concatenation (.) or string" my $domain2 = $domain; $domain = isDomain($domain) or usage "invalid ${name}domain name '$domain2' defined"; vlog_option("${name}domain", $domain); return $domain; } # SECURITY NOTE: this only validates the email address is valid, it's doesn't make it safe to arbitrarily pass to commands or SQL etc! sub validate_email ($) { my $email = shift; defined($email) || usage "email not defined"; isEmail($email) || usage "invalid email address defined: failed regex validation"; # Not passing it through regex as I don't want to untaint it due to the addition of the valid ' char in email addresses return $email; } sub validate_filename ($;$$$) { my $filename = shift; my $name = shift || "filename"; my $noquit = shift; my $no_vlog = shift; if(not defined($filename) or $filename =~ /^\s*$/){ usage "$name not defined"; return; } my $filename2; unless($filename2 = isFilename($filename)){ usage "invalid $name (does not match regex critera): '$filename'" unless $noquit; return; } vlog_option($name, $filename2) unless $no_vlog; return $filename2; } sub validate_file ($;$$$) { my $filename = shift; my $name = shift || ""; my $noquit = shift; my $no_vlog = shift; $filename = validate_filename($filename, $name, $noquit, $no_vlog) or return; unless( -f $filename ){ $name .= " " if $name; usage "${name}file not found: '$filename' ($!)" unless $noquit; return } return $filename; } sub validate_float ($$$$) { my ($float, $name, $min, $max) = @_; defined($float) || usage "$name not defined"; isFloat($float,1) or usage "invalid $name defined: must be a real number"; if( not ( isFloat($min, "allow_negative") or isScientific($min, "allow_negative") ) or not ( isFloat($max, "allow_negative") or isScientific($max, "allow_negative") ) ){ usage "invalid min/max ($min/$max) passed to validate_float()"; } ($float >= $min && $float <= $max) or usage "invalid $name defined: must be real number between $min and $max"; $float =~ /^(-?\d+(?:\.\d+)?)$/ or usage "invalid float $name passed to validate_float(), WARNING: caught LATE"; $float = $1; vlog_option($name, $float); return $float; } sub validate_fqdn ($;$) { my $fqdn = shift; my $name = shift || ""; $name .= " " if $name; defined($fqdn) || usage "${name}FQDN not defined"; my $fqdn2 = $fqdn; $fqdn = isFqdn($fqdn) || usage "invalid ${name}FQDN '$fqdn' defined"; vlog_option("${name}fqdn", $fqdn); return $fqdn } sub validate_host_port_user_password($$$$){ return (validate_host($_[0]), validate_port($_[1]), validate_user($_[2]), validate_password($_[3])); } sub validate_host ($;$) { my $host = shift; my $name = shift || ""; $name = "$name " if $name; defined($host) || usage "${name}host not defined"; $host = isHost($host) || usage "invalid ${name}host '$host' defined: not a valid hostname or IP address"; vlog_option("${name}host", $host); return $host; } sub validate_hosts($$){ my $hosts = shift; my $port = shift; $port = isPort($port) or usage "invalid port given"; defined($hosts) or usage "hosts not defined"; my @hosts = split(/\s*,\s*/, $hosts); @hosts or usage "no hosts defined"; my $node_port; foreach(my $i = 0; $i < scalar @hosts; $i++){ undef $node_port; if($hosts[$i] =~ /:(\d+)$/){ $node_port = isPort($1) or usage "invalid port given for host " . $i+1; $hosts[$i] =~ s/:$node_port$//; } $hosts[$i] = validate_host($hosts[$i]); # don't replace $host with IP as it can break load balancer routing with '503 Service Temporarily Unavailable' #$hosts[$i] = validate_resolvable($hosts[$i]); #validate_resolvable($hosts[$i]); $node_port = $port unless defined($node_port); $hosts[$i] .= ":$node_port"; vlog_option("port", $node_port); } return @hosts; } sub validate_hostport ($;$) { my $hostport = shift; my $name = shift || ""; my $port_required = shift; my $no_vlog = shift; $name .= " " if $name; defined($hostport) || usage "${name}host:port option not defined"; my ($host, $port) = split(":", $hostport, 2); $host = isHost($host) || usage "invalid ${name}host '$host' defined for host:port: not a valid hostname or IP address"; if($port){ $port = isPort($port) || usage "invalid ${name}port '$port' defined for host:port: must be a positive integer"; } elsif($port_required){ usage "':port' is required for ${name}host:port option"; } $hostport = $host; $hostport .= ":$port" if $port; vlog_option("${name}host:port", $hostport) unless $no_vlog; return $hostport; } sub validate_hostname ($;$) { my $hostname = shift; my $name = shift || ""; $name = "$name " if $name; defined($hostname) || usage "${name}hostname not defined"; $hostname = isHostname($hostname) || usage "invalid ${name}hostname defined"; vlog_option("${name}hostname", $hostname); return $hostname; } sub validate_int ($$;$$) { my ($integer, $name, $min, $max) = @_; defined($name) || code_error "name not defined when calling validate_int()"; defined($integer) || usage "$name not defined"; isInt($integer, 1) or usage "invalid $name defined: must be an integer"; if(defined($min)){ isFloat($min, 1) or code_error "invalid min value '$min' passed to validate_int() for 2nd arg (min value): must be float value"; $integer < $min and usage "invalid $name defined: cannot be lower than $min"; } if(defined($max)){ isFloat($max, 1) or code_error "invalid max value '$max' passed to validate_int() for 3rd arg (max value): must be float value"; $integer > $max and usage "invalid $name defined: cannot be greater than $max"; } $integer =~ /^(-?\d+)$/ or usage "invalid integer $name passed to validate_int() - WARNING: caught LATE code may need updating"; $integer = $1; vlog_option($name, $integer); return $integer; } *validate_integer = \&validate_int; sub validate_interface ($) { my $interface = shift; defined($interface) || usage "interface not defined"; $interface = isInterface($interface) || usage "invalid interface defined: must be either eth, bond or lo"; vlog_option("interface", $interface); return $interface; } sub validate_ip ($;$) { my $ip = shift; my $name = shift || ""; $name .= " " if $name; defined($ip) || usage "${name}IP not defined"; $ip = isIP($ip) || usage "invalid ${name}IP defined"; vlog_option("${name}IP", $ip); return $ip; } sub validate_java_bean ($;$) { my $bean = shift; my $name = shift || ""; $name .= " " if $name; defined($bean) or usage "java bean not defined"; $bean = isJavaBean($bean) || usage "invalid ${name}java bean defined"; vlog_option("${name}java bean", $bean); return $bean; } sub validate_krb5_princ ($;$) { my $principal = shift; my $name = shift || ""; $name .= " " if $name; defined($principal) or usage "krb5 principal not defined"; $principal = isKrb5Princ($principal) || usage "invalid ${name}krb5 principal defined"; vlog_option("${name}krb5 principal", $principal); return $principal; } sub validate_krb5_realm ($;$) { my $realm = shift; my $name = shift || ""; $name .= " " if $name; defined($realm) || usage "${name}krb5 realm name not defined"; $realm = isDomain($realm) || usage "invalid ${name}krb5 realm name defined"; vlog_option("${name}krb5 realm", $realm); return $realm; } sub validate_label ($) { my $label = shift; defined($label) or usage "label not defined"; $label = isLabel($label) || usage "invalid label defined: must be an alphanumeric identifier"; vlog_option("label", $label); return $label; } sub validate_ldap_dn ($;$) { #subtrace(@_); my $dn = shift; my $name = shift || ""; $name .= " " if $name; defined($dn) or usage "ldap ${name}dn not defined"; $dn = isLdapDn($dn) || usage "invalid ldap ${name}dn defined"; vlog_option("ldap ${name}dn", $dn); return $dn; } sub validate_metrics ($) { my $metrics = shift; my @metrics; if($metrics){ foreach(split(/\s*,\s*/, $metrics)){ $_ = trim($_); /^\s*([A-Za-z0-9][\w\.]+[A-Za-z0-9])\s*$/ or usage "invalid metric '$_' given, must be alphanumeric, may contain underscores and dots in the middle"; push(@metrics, $1); } @metrics or usage "no valid metrics given"; @metrics = uniq_array @metrics; vlog_option("metrics", "[ " . join(" ", @metrics) . " ]"); } return @metrics; } # Takes an array and for any items separated by spaces or commas also splits them into array components to be able to conveniently pass a string and/or arrays mixed together and do the right thing sub validate_node_list (@) { my @nodes = @_; @nodes or usage "node(s) not defined"; my @nodes2; foreach(@nodes){ push(@nodes2, split(/[,\s]+/, $_)); } # do this validate_node_list #push(@nodes, @ARGV); scalar @nodes2 or usage "node list empty"; @nodes = uniq_array(@nodes2); my $node_count = scalar @nodes; foreach (my $i = 0; $i < $node_count; $i++){ $nodes[$i] = isHost($nodes[$i]) || usage "invalid node name '$nodes[$i]': must be hostname/FQDN or IP address"; } vlog_option("node list", "[ '" . join("', '", @nodes) . "' ]"); return @nodes; } # Takes an array and for any items separated by spaces or commas also splits them into array components to be able to conveniently pass a string and/or arrays mixed together and do the right thing sub validate_nodeport_list (@) { my @nodes = @_; @nodes or usage "node(s) not defined"; my @nodes2; foreach(@nodes){ defined($_) or next; push(@nodes2, split(/[,\s]+/, $_)); } scalar @nodes2 or usage "node list empty"; @nodes = uniq_array2(@nodes2); my $node_count = scalar @nodes; foreach(my $i = 0; $i < $node_count; $i++){ $nodes[$i] = validate_hostport($nodes[$i]); } vlog_option("node list", "[ '" . join("', '", @nodes) . "' ]"); return @nodes; } sub validate_nosql_key($;$){ my $key = shift; my $name = shift || ""; $name .= " " if $name; defined($key) or usage "${name}key not defined"; $key = isNoSqlKey($key) || usage "invalid ${name}key name defined: may only contain characters: alphanumeric, commas, colons, underscores, pluses, dashes"; vlog_option("${name}key", $key); return $key; } sub validate_port ($;$) { my $port = shift; my $name = shift || ""; $name = "$name " if $name; defined($port) || usage "${name}port not defined"; $port = isPort($port) || usage "invalid ${name}port number defined: must be a positive integer"; vlog_option("${name}port", $port); return $port; } sub validate_process_name ($;$) { my $process = shift; my $name = shift || ""; $name .= " " if $name; defined($process) or usage "${name}process name not defined"; $process = isProcessName($process) || usage "invalid ${name}process name defined"; vlog_option("${name}process name", $process); return $process; } sub validate_program_path ($$;$) { my $path = shift; my $name = shift; my $regex = shift() || $name; defined($path) or usage "$name program path not defined"; defined($name) or usage "$path program name not defined"; if($path !~ /^[\.\/]/){ $path = which($path); unless(defined($path)){ usage "$name program not found in \$PATH ($ENV{PATH})"; } } validate_regex($regex, "program path regex", 1) or code_error "invalid regex given to validate_program_path()"; $path = validate_filename($path, undef, undef, "no vlog") or usage "invalid path given for $name, failed filename regex"; $path =~ /(?:^|\/)$regex$/ || usage "invalid path given for $name, is not a path to the $name command"; ( -f $path ) or usage "$path not found"; ( -x $path ) or usage "$path not executable"; vlog_option("${name} program path", $path); return $path; } # TODO: unify with isRegex and do not allow noquit sub validate_regex ($;$$$) { my $regex = shift; my $name = shift || ""; my $noquit = shift; my $posix = shift; $name = "${name} " if $name; my $regex2; if($noquit){ defined($regex) or return; } else { defined($regex) or usage "${name}regex not defined"; } if($posix){ if($regex =~ /\$\(|\`/){ quit "UNKNOWN", "invalid ${name}posix regex supplied: contains sub shell metachars ( \$( / ` ) that would be dangerous to pass to shell" unless $noquit; return; } else { # XXX: this behaviour is broken in busybox (used in Alpine linux on docker) - it doesn't detect the error in the regex - the validation must be too weak - must install proper grep in that case # cannot return exitcode and test that because the random regex won't match /dev/null my @output = cmd("egrep '$regex' < /dev/null"); #if(grep({$_ =~ "Unmatched"} @output)){ if(@output){ #quit "UNKNOWN", "invalid posix regex supplied: contains unbalanced () or []" unless $noquit; quit "UNKNOWN", "invalid ${name}posix regex defined: @output" unless $noquit; return; } } } else { #$regex2 = isRegex($regex); $regex2 = eval { qr/$regex/ }; if($@){ my $errstr = $@; $errstr =~ s/;.*?$//; $errstr =~ s/in regex m\/.*?$/in regex/; quit "UNKNOWN", "invalid ${name}regex defined: $errstr" unless $noquit; return; } } if($regex2){ vlog_option("${name}regex", $regex2) unless $noquit; return $regex2; } else { vlog_option("${name}regex", $regex) unless $noquit; return $regex; } } sub validate_password ($;$$) { my $password = shift; my $name = shift || ""; my $allow_all = shift; $name = "$name " if $name; defined($password) or usage "${name}password not defined"; if($allow_all){ # intentionally not untaining $password =~ /^(.+)$/ || usage "invalid ${name}password defined"; } else { $password =~ /^([^'"`]+)$/ or usage "invalid ${name}password defined: may not contain quotes or backticks"; $password = $1; $password =~ /\$\(/ and usage "invalid ${name}password defined: may not contain \$( as this is a subshell escape and could be dangerous to pass through to programs on the command line"; } if($ENV{'PASSWORD_DEBUG'}){ vlog_option("${name}password", "$password"); } else { vlog_option("${name}password", ""); } return $password; } sub validate_resolvable($;$){ my $host = shift; my $name = shift || ""; $name .= " " if $name; defined($host) or code_error "${name}host not defined"; return resolve_ip($host) || quit "CRITICAL", "failed to resolve ${name}host '$host'"; } sub validate_ssl_opts(){ if(defined($ssl_noverify)){ $main::ua->ssl_opts( verify_hostname => 0, SSL_verify_mode => 0 ); } if(defined($ssl_ca_path)){ $ssl_ca_path = validate_directory($ssl_ca_path, "SSL CA directory", undef, "no vlog"); $main::ua->ssl_opts( SSL_ca_path => $ssl_ca_path ); } if($ssl or $tls){ vlog_option("SSL CA Path", $ssl_ca_path) if defined($ssl_ca_path); vlog_option("SSL noverify", $ssl_noverify ? "true" : "false"); $main::protocol = "https" if defined($main::protocol); } } sub validate_ssl(){ defined_main_ua(); $ssl = 1 if(defined($ssl_ca_path) or defined($ssl_noverify)); if($ssl){ vlog_option("SSL enabled", "true"); } validate_ssl_opts(); } sub validate_tls(){ defined_main_ua(); $tls = 1 if(defined($ssl_ca_path) or defined($ssl_noverify)); if($tls){ vlog_option("TLS enabled", "true"); } validate_ssl_opts(); } sub validate_threshold ($$;$) { #subtrace(@_); my $name = shift; my $threshold = shift; my $options_ref = shift() || {}; isHash($options_ref) or code_error "3rd arg to validate_threshold() must be a hash ref of options"; $options_ref->{"positive"} = 1 unless defined($options_ref->{"positive"}); $options_ref->{"simple"} = "upper" unless $options_ref->{"simple"}; my @valid_options = qw/simple positive integer min max/; foreach my $option (sort keys %$options_ref){ grep(/^$option$/, @valid_options) or code_error "invalid option '$option' passed to validate_threshold(), must be one of " . join("/", @valid_options); } unless ($options_ref->{"simple"} eq "upper" or $options_ref->{"simple"} eq "lower") { code_error "simple => '$options_ref->{simple}' option to validate_threshold() must be either 'upper' or 'lower', not '$options_ref->{simple}'"; } #debug("validating $name threshold against $threshold"); my $invert_range = 0; defined($threshold) or code_error "no threshold (arg 2) given to validate_threshold subroutine"; $thresholds{"$name"}{"invert_range"} = 0; # Make this more flexible if ($threshold =~ $threshold_range_regex) { $thresholds{$name}{"invert_range"} = 1 if $1; if(defined($3)){ $thresholds{$name}{"upper"} = $4 if defined($4); $thresholds{$name}{"lower"} = $2; } else { $thresholds{$name}{"upper"} = $2; } if(defined($thresholds{$name}{"upper"}) and defined($thresholds{$name}{"lower"})){ $thresholds{$name}{"upper"} < $thresholds{$name}{"lower"} and usage "invalid args: upper $name threshold cannot be lower than lower $name threshold"; } } elsif($threshold =~ $threshold_simple_regex) { if($options_ref->{"simple"} eq "upper"){ $thresholds{$name}{"upper"} = $1; } elsif($options_ref->{"simple"} eq "lower"){ $thresholds{$name}{"lower"} = $1; } } else { usage "invalid $name threshold given, must be in standard nagios threshold format [@][start:]end"; } foreach(qw/upper lower/){ if($options_ref->{"positive"} and defined($thresholds{$name}{$_}) and $thresholds{$name}{$_} < 0){ usage "$name threshold may not be less than zero"; } if($options_ref->{"integer"} and defined($thresholds{$name}{$_}) and not isInt($thresholds{$name}{$_}, 1)){ usage "$name threshold must be an integer"; } if($options_ref->{"min"} and defined($thresholds{$name}{$_}) and $thresholds{$name}{$_} < $options_ref->{"min"}){ usage "$name threshold cannot be less than $options_ref->{min}"; } if($options_ref->{"max"} and defined($thresholds{$name}{$_}) and $thresholds{$name}{$_} > $options_ref->{"max"}){ usage "$name threshold cannot be greater than $options_ref->{max}"; } } $thresholds{"defined"} = 1 if (defined($thresholds{$name}{"upper"}) or defined($thresholds{$name}{"lower"})); $thresholds{$name}{"range"} = ""; $thresholds{$name}{"range"} .= $thresholds{$name}{"lower"} if defined($thresholds{$name}{"lower"}); $thresholds{$name}{"range"} .= ":" if (defined($thresholds{$name}{"lower"}) and defined($thresholds{$name}{"upper"})); $thresholds{$name}{"range"}.= $thresholds{$name}{"upper"} if defined($thresholds{$name}{"upper"}); vlog_option(sprintf("%-8s lower", $name), $thresholds{"$name"}{"lower"}) if defined($thresholds{"$name"}{"lower"}); vlog_option(sprintf("%-8s upper", $name), $thresholds{"$name"}{"upper"}) if defined($thresholds{"$name"}{"upper"}); vlog_option(sprintf("%-8s range inversion", $name), "on") if $thresholds{$name}{"invert_range"}; 1; } sub validate_thresholds (;$$$$$) { # TODO: CRITICAL vs WARNING threshold logic is only applied to simple thresholds, not to range ones, figure out if I can reasonably do range ones later my $require_warning = shift; my $require_critical = shift; my $options = shift; my $name = shift() || ""; my $dual_threshold = shift; my $warning = $warning; my $critical = $critical; if($name){ $name .= " "; if(defined($dual_threshold)){ ($warning, $critical) = split(",", $dual_threshold, 2); if(defined($warning) and not defined($critical)){ $critical = $warning; $warning = undef; } } else { if($require_warning or $require_critical){ code_error "no threshold given for $name"; } } } if($require_warning){ defined($warning) || usage "${name}warning threshold not defined"; } if($require_critical){ defined($critical) || usage "${name}critical threshold not defined"; } # replace $warning and $critical with $name options somehow validate_threshold("${name}warning", $warning, $options) if(defined($warning)); validate_threshold("${name}critical", $critical, $options) if(defined($critical)); # sanity checking on thresholds for simple upper or lower thresholds only if(isHash($options) and $options->{"simple"} and $options->{"simple"} eq "lower"){ if (defined($thresholds{"${name}warning"}{"lower"}) and defined($thresholds{"${name}critical"}{"lower"}) and $thresholds{"${name}warning"}{"lower"} < $thresholds{"${name}critical"}{"lower"}){ usage "${name}warning threshold (" . $thresholds{"${name}warning"}{"lower"} . ") cannot be lower than ${name}critical threshold (" . $thresholds{"${name}critical"}{"lower"} . ") for lower limit thresholds"; } } elsif(isHash($options) and $options->{"simple"} and $options->{"simple"} eq "upper"){ if (defined($thresholds{"${name}warning"}{"upper"}) and defined($thresholds{"${name}critical"}{"upper"}) and $thresholds{"${name}warning"}{"upper"} > $thresholds{"${name}critical"}{"upper"}){ usage "${name}warning threshold (" . $thresholds{"${name}warning"}{"upper"} . ") cannot be higher than ${name}critical threshold (" . $thresholds{"${name}critical"}{"upper"} . ") for upper limit thresholds"; } } 1; } # Not sure if I can relax the case sensitivity on these according to the Nagios Developer guidelines sub validate_units ($;$) { my $units = shift; my $name = shift || ""; $name .= " " if $name; $units or usage("${name}units not defined"); $units = isNagiosUnit($units) || usage("invalid ${name}units defined, must be one of: " . join(" ", @valid_units)); vlog_option("${name}units", $units); return $units; } sub validate_url ($;$) { my $url = $_[0] if $_[0]; my $name = $_[1] || ""; $name .= " " if $name; defined($url) or usage "${name}url not defined"; $url = isUrl($url) || usage "invalid ${name}url defined: '$url'"; vlog_option("${name}url", $url); return $url; } sub validate_url_path_suffix ($;$) { my $url = $_[0] if $_[0]; my $name = $_[1] || ""; $name .= " " if $name; defined($url) or usage "${name}url not defined"; $url = isUrlPathSuffix($url) || usage "invalid ${name}url defined: '$url'"; vlog_option("${name}url", $url); return $url; } sub validate_user ($;$) { #subtrace(@_); my $user = shift; my $name = shift || ""; $name .= " " if $name; defined($user) or usage "${name}username not defined"; $user = isUser($user) || usage "invalid ${name}username defined: must be alphanumeric"; vlog_option("${name}user", $user); return $user; } *validate_username = \&validate_user; sub validate_user_exists ($;$) { #subtrace(@_); my $user = shift; my $name = shift || ""; $name .= " " if $name; $user = validate_user($user); user_exists($user) or usage "invalid ${name}user defined, not found on local system"; return $user; } sub verbose_mode () { vlog2("verbose mode on\n"); vlog3(version_string() . "\n"); return $verbose >= 1; } sub version_string () { my $version_str = ""; $version_str .= "$progname version $main::VERSION => " if defined($progname and $main::VERSION); $version_str .= "Hari Sekhon Utils version $HariSekhonUtils::VERSION"; return $version_str; } sub version () { defined($main::VERSION) or $main::VERSION = "unset"; usage version_string(); } sub vlog (@) { if($debug){ print STDERR strftime("%F %T %z ", localtime); } print STDERR "@_\n" if $verbose; } sub vlog2 (@) { vlog @_ if ($verbose >= 2); } sub vlog3 (@) { vlog @_ if ($verbose >= 3); } sub vlogt (@) { vlog tstamp() . "@_"; } sub vlog2t (@) { vlog2 tstamp . "@_"; } sub vlog3t (@) { vlog3 tstamp . "@_"; } # TODO: check this # $progname: prefixed sub vlog4 (@){ if($verbose){ foreach(@_){ foreach (split(/\n/, $_)){ vlog "$progname\[$$\]: $_"; } } 1; } } sub vlog_option ($$) { #scalar @_ eq 2 or code_error "incorrect number of args passed to vlog_option()"; vlog2 sprintf("%-25s %s", "$_[0]:", $_[1]); } sub vlog_option_bool ($$) { vlog_option $_[0], ( $_[1] ? "true" : "false" ); } #my %download_tries; #my %lock_tries; #sub wget ($$) { # require LWP::Simple; # import LWP::Simple; # my $url = shift; # my $local_file = shift; # # $download_tries{$url}++; # $lock_tries{$url} = 0; # until(go_flock_yourself){ # $lock_tries{$url}++; # if($lock_tries{$url} > $LOCK_TRY_ATTEMPTS){ # vlog "Hit max lock attempts on url '$url' ($LOCK_TRY_ATTEMPTS attempts, $LOCK_TRY_INTERVAL secs apart) while waiting for download lock, aborting download...\n"; # return; # } # vlog "sleeping for $LOCK_TRY_INTERVAL secs before retrying download lock for url '$url'"; # sleep $LOCK_TRY_INTERVAL; # } # vlog "download lock acquired, fetcing '$url' (attempt $download_tries{$url}/$DOWNLOAD_TRIES)"; # my $rc = mirror($url, $local_file); # if ($rc == RC_NOT_MODIFIED){ # vlog "local file '$local_file' is up to date, not redownloaded"; # return 1; # } elsif(is_success($rc)){ # vlog "download successful"; # return 1; # } else { # vlog "error downloading $url: return code is '$rc'"; # flock_off; # if($download_tries{$url} >= $DOWNLOAD_TRIES){ # vlog "failed to download url '$url' $DOWNLOAD_TRIES times"; # return; # } # vlog "sleeping for $DOWNLOAD_RETRY_INTERVAL secs before trying again"; # sleep $DOWNLOAD_RETRY_INTERVAL; # return wget($url, $local_file); # } # return; # #vlog "fetching $url.md5..."; # #getstore("$url.md5", "$local_file.md5"); ## if(open(my $fh, "$local_file.md5")){ ## #vlog ".md5 file present, checking md5sum against '$local_file'"; ## $md5sum = do { local $/; <$fh> }; ## chomp $md5sum; ## my $md5 = md5sum($local_file); ## if($md5 eq $md5sum){ ## vlog "$local_file .md5 file matched '$md5' == '$md5sum', proceeding..."; ## last; ## } else { ## vlog "attempt $tries: $local_file did not match yet, file is '$md5' but .md5 file contains '$md5sum'"; ## wget($url, $local_file); ## } ## } #} sub which ($;$) { my $bin = $_[0] || code_error "no arg supplied to which() subroutine"; my $quit = $_[1] || 0; $bin = isFilename($bin) || quit "UNKNOWN", "invalid filename '$bin' supplied"; if($bin =~ /^(?:\/|\.\/)/){ if(-f $bin){ if(-x $bin){ return $bin; } else { quit "UNKNOWN", "'$bin' is not executable" if $quit; } } else { quit "UNKNOWN", "couldn't find executable '$bin': $!" if $quit; } } else { foreach(split(":", $ENV{"PATH"})){ (-x "$_/$bin") && return "$_/$bin"; } quit "UNKNOWN", "couldn't find '$bin' in \$PATH ($ENV{PATH})" if $quit; } return; } 1;