# *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* */ # ** Copyright UCAR (c) 1992 - 2010 */ # ** University Corporation for Atmospheric Research(UCAR) */ # ** National Center for Atmospheric Research(NCAR) */ # ** Research Applications Laboratory(RAL) */ # ** P.O.Box 3000, Boulder, Colorado, 80307-3000, USA */ # ** 2010/10/7 23:12:42 */ # *=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=* */ ################################################################################ # # Niwot library for managing project control # # Terri L. Betancourt, RAP, NCAR, Boulder, CO, 80307, USA # March 2002 # # $Id: Niwot.pm,v 1.18 2016/01/08 22:13:09 dettling Exp $ ################################################################################ package Niwot; require Exporter; @ISA = qw(Exporter); @EXPORT = qw( setMsgStderr setMsgConsoleHost setMsgTime setMsgLogFile postMsg postError postWarning postInfo postDebug postFatal setHostEnv getHostList getHostRoles isLocalHost areHostsEqual setModeEquiv getModeEquiv setRadarEnv getRadarId getRadarEntry setProcessInstance trim appendFile); Env::import(); use Env; use Socket; use Net::Domain qw(hostfqdn); use Sys::Hostname; # # Set unbuffered IO # $| = 1; # # Get the program basename. # ($prog = $0) =~ s|.*/||; # # Get the local hostname # $localHost = hostname(); 1; #=============================================================================== # MESSAGING #=============================================================================== #------------------------------------------------------------------------------- # Set option to print messages to STDERR # Arguments: none # Prerequisites: none # Return: none # sub setMsgStderr { $postStderr = 1; } #------------------------------------------------------------------------------- # Set console option for messaging # Arguments: hostname # Prerequisites: none # Return: none # sub setMsgConsoleHost { ( $postConsoleHost ) = @_; } #------------------------------------------------------------------------------- # Turn on option for including time of message # Arguments: none # Prerequisites: none # Return: none # sub setMsgTime { $postTime = 1; } #------------------------------------------------------------------------------- # Open the messaging log file # Arguments: logFileExpr # Prerequisites: none # Return: none # Notes: See perl open() function for definition of file expression # to specify open modes # sub setMsgLogFile { sub postMsg; my( $logFileExpr ) = @_; unless ( open( LOG_FILE, $logFileExpr )) { postMsg( "Cannot open log file $logFileExpr", ERROR ); return; } $postLog = 1; } #------------------------------------------------------------------------------- # Post library messages # Arguments: messageText, [severe] # Prerequisites: none # Return: none # Notes: to modify the behavior of the messaging, use the functions # setMsgStderr(), setMsgConsoleHost(), setMsgTime(), # setMsgLogFile() # sub postMsg { my( $msg, $severe ) = @_; my( $date, $msgText ); # # Append the current time, if requested # if ( $postTime ) { $date = scalar localtime; $msgText = "$msg ($date)"; } else { $msgText = $msg; } # # Post to stderr, if requested # if ( $postStderr || defined( $severe ) ) { print STDERR "$prog: $msgText\n"; } # # Post to log file, if requested # if ( $postLog ) { print LOG_FILE "$prog: $msgText\n"; } # console messaging does not currently work w/ timeMsg set # if ( $postConsoleHost ) { # if ( areHostsEqual( $postConsoleHost, $localHost )) { # $cmd = "echo \"$prog: $msgText\" > /dev/console"; # } # else { # $cmd = "ssh -x $postConsoleHost \"echo " # . "\"$prog: $msgText\" > /dev/console\""; # } # system( $cmd ); # } } #------------------------------------------------------------------------------- # Post an error message # Arguments: messageText # Prerequisites: none # Return: none # Notes: to modify the behavior of the messaging, use the functions # setMsgStderr(), setMsgConsoleHost(), setMsgTime(), # setMsgLogFile() # sub postError { my( $msg ) = @_; # # Append "error" message to message text # $msgTxt = "ERROR: $msg"; # # Send it off to postMsg, assume this is severe # postMsg( $msgTxt, ERROR ); } #------------------------------------------------------------------------------- # Post a warning message # Arguments: messageText # Prerequisites: none # Return: none # Notes: to modify the behavior of the messaging, use the functions # setMsgStderr(), setMsgConsoleHost(), setMsgTime(), # setMsgLogFile() # sub postWarning { my( $msg ) = @_; # # Append "warning" message to message text # $msgTxt = "WARNING: $msg"; # # Send it off to postMsg, assume this is NOT severe # postMsg( $msgTxt ); } #------------------------------------------------------------------------------- # Post an info message # Arguments: messageText # Prerequisites: none # Return: none # Notes: to modify the behavior of the messaging, use the functions # setMsgStderr(), setMsgConsoleHost(), setMsgTime(), # setMsgLogFile() # sub postInfo { my( $msg ) = @_; # # Append "info" message to message text # $msgTxt = "INFO: $msg"; # # Send it off to postMsg, assume this is NOT severe # postMsg( $msgTxt ); } #------------------------------------------------------------------------------- # Post a debug message # Arguments: messageText # Prerequisites: none # Return: none # Notes: to modify the behavior of the messaging, use the functions # setMsgStderr(), setMsgConsoleHost(), setMsgTime(), # setMsgLogFile() # sub postDebug { my( $msg ) = @_; # # Append "debug" message to message text # $msgTxt = "DEBUG: $msg"; # # Send it off to postMsg, assume this is NOT severe # postMsg( $msgTxt ); } #------------------------------------------------------------------------------- # Post a fatal error message # Arguments: messageText # Prerequisites: none # Return: none # Notes: to modify the behavior of the messaging, use the functions # setMsgStderr(), setMsgConsoleHost(), setMsgTime(), # setMsgLogFile() # sub postFatal { my( $msg ) = @_; # # Append "fatal error" message to message text # $msgTxt = "FATAL: $msg"; # # Send it off to postMsg, assume this is severe # postMsg( $msgTxt, FATAL ); } #=============================================================================== # HOST NAME / HOST ROLE LOOKUP #=============================================================================== #------------------------------------------------------------------------------- # See if the specified host is the local host # Arguments: hostname # Prerequisites: none # Return: 1 true, 0 false # sub isLocalHost { my( $specifiedHost ) = @_; # # See if the specified host name is equal to the local host # return( areHostsEqual( $specifiedHost, $localHost )); } #------------------------------------------------------------------------------- # See two hostnames refer to the same host machine # Arguments: hostname1, hostname2 # Prerequisites: none # Return: 1 true, 0 false # sub areHostsEqual { my( $host1, $host2 ) = @_; # # Check for 'localhost' keyword # if ( $host1 eq "localhost" ) { $host1 = $localHost; } if ( $host2 eq "localhost" ) { $host2 = $localHost; } # # Expand environment variables, if necessary # if ( $host1 =~ m/\$(\w+)/ ) { $host1 = $ENV{$1}; } if ( $host2 =~ m/\$(\w+)/ ) { $host2 = $ENV{$1}; } # # Get the fully qualified domains # $address1 = gethostbyname( $host1 ); $fqdn1 = gethostbyaddr( $address1, AF_INET ); $address2 = gethostbyname( $host2 ); $fqdn2 = gethostbyaddr( $address2, AF_INET ); # # Say something if we could not resolve the names, and exit. # Exiting is a fairly brutal option, but # otherwise behavior in this case is very puzzling and # leads to a lot of debugging. Niles. # if (!($fqdn1)) { print STDERR "Failed to resolve hostname : $host1\n"; die "Either remove $host1 from host list or resolve it.\n"; } if (!($fqdn2)) { print STDERR "Failed to resolve hostname : $host2\n"; die "Either remove $host2 from host list or resolve it.\n"; } if ( $fqdn1 eq $fqdn2 ) { return 1; } else { return 0; } } #------------------------------------------------------------------------------- # Set the host environment # Arguments: hostEnvFile # Prerequisites: none # Return: 0 on success, -1 on failure # sub setHostEnv { my( $hostEnvFile ) = @_; # # Make sure the host env file exists # if ( ! -e "$hostEnvFile" ) { postMsg( "Host env file '$hostEnvFile' does not exist.", ERROR ); return -1; } # # Open the host env file # unless (open(HOST_FILE, $hostEnvFile)) { postMsg( "Cannot open the file $hostEnvFile.", ERROR ); return -1; } # # Read the host environment into a table of host role entries # @hostRoleTable = ; return 0; } #------------------------------------------------------------------------------- # Determine unique list of system hosts, i.e., hostnames are not repeated # Arguments: none # Prerequisites: setHostEnv() # Return: @hostlist # sub getHostList { my( $host, @hosts ); my( $item, %seen ); if ( !( @hostRoleTable) ) { postMsg( "Unable to access host env table.", ERROR ); return; } # # Scan the host table to see which machines are in the system # foreach $entry ( @hostRoleTable ) { # # Skip comment and blank lines # next if ( $entry =~ m/^\s*#/ ); next if ( $entry =~ m/^\s*$/ ); # # Split the line into the expected tokens # ($setenv, $role, $host) = split ' ', $entry; # # Skip environment variable references # next if ( $host =~ m/(\$\w+)/ ); # # Add this host name to our list # push( @hosts, $host ); } # # Get the unique host name list # %seen = (); foreach $item (@hosts) { $seen{$item}++; } return keys %seen; } #------------------------------------------------------------------------------- # Determine list of host roles # Arguments: none # Prerequisites: setHostEnv() # Return: @hostRoles # sub getHostRoles { my( $host, @hosts ); my( $item, %seen ); if ( !( @hostRoleTable) ) { postMsg( "Unable to access host env table.", ERROR ); return; } # # Scan the host table to see what roles this host plays # %seen = (); foreach $entry ( @hostRoleTable ) { # # Skip comment and blank lines # next if ( $entry =~ m/^\s*#/ ); next if ( $entry =~ m/^\s*$/ ); # # Split the line into the expected tokens # ($setenv, $role, $host) = split ' ', $entry; # # Check environment variable to see if it refers to this host # if ( $host =~ m/\$(\w+)/ ) { $hostEnv = $1; $seen{$hostEnv} and $seen{ $role }++; } elsif ( isLocalHost( $host )) { # # Add this role to our hash # $seen{ $role }++; } } # # Set the unique role list plus EVERY_HOST # return ("EVERY_HOST", keys %seen); } #=============================================================================== # MODE EQUIVALENCE LOOKUP #=============================================================================== #------------------------------------------------------------------------------- # Set the mode equivalent lookup file # Arguments: modeEquivFilePath # Prerequisites: none # Return: 0 on success, -1 on failure # sub setModeEquiv { my( $modeEquivFile ) = @_; # # Make sure the host env file exists # if ( ! -e "$modeEquivFile" ) { postMsg( "Mode equivalence file '$modeEquivFile' does not exist.", ERROR ); return -1; } # # Open the host env file # unless (open(EQUIV_FILE, $modeEquivFile)) { postMsg( "Cannot open the file $modeEquivFile.", ERROR ); return -1; } # # Read the mode equivalencies into a table of mode entries # @modeEquivTable = ; return 0; } #------------------------------------------------------------------------------- # Get the list of equivalent file extensions for a specified mode # Arguments: mode # Prerequisites: setModeEquiv() # Return: @equivList # sub getModeEquiv { my( $mode ) = @_; my( $entry, @equivList ); if ( !( @modeEquivTable) ) { # # The mode itself and the keywork 'always' are our only equivalency # @equivList = ($mode,"always"); return @equivList; } # # Scan the mode equivalence table to see what strings map # to the specified mode # foreach $entry ( @modeEquivTable ) { # # Skip comment and blank lines # next if ( $entry =~ m/^\s*#/ ); next if ( $entry =~ m/^\s*$/ ); # # Build up a list of all equivalent file extensions # if ( $entry =~ m/^\s*$mode\s*(.+)$/ ) { $equivalents = $1; @equivList = (trim(split /,/, $equivalents),"always"); } } return @equivList; } #=============================================================================== # RADAR INFORMATION LOOKUP #=============================================================================== #------------------------------------------------------------------------------- # Set the radar environment # Arguments: radarEnvFile # Prerequisites: none # Return: 0 on success, -1 on failure # sub setRadarEnv { my( $radarEnvFile ) = @_; # # Make sure the radar env file exists # if ( ! -e "$radarEnvFile" ) { postMsg( "Radar env file '$radarEnvFile' does not exist.", ERROR ); return -1; } # # Open the radar env file # unless (open(RADAR_FILE, $radarEnvFile)) { postMsg( "Cannot open the file $radarEnvFile.", ERROR ); return -1; } # # Read the radar environment into a table of radar function entries # @radarFcnTable = ; return 0; } #------------------------------------------------------------------------------- # Get the radar ID for a specified function # Arguments: function # Prerequisites: setRadarEnv() # Return: @radarIdList -or- RadarId[last] # sub getRadarId { my( $specifiedFcn ) = @_; my( @radarIdList ); # # Look up the radar Id from the radar function table # foreach $entry ( @radarFcnTable ) { # # Skip comment and blank lines # next if ( $entry =~ m/^\s*#/ ); next if ( $entry =~ m/^\s*$/ ); # # Split the line into the expected tokens # ($radarId, $host, $function) = split ' ', $entry; # # Skip entries which are not of the requested function type # next if ( $function ne $specifiedFcn ); # # If we got this far, we have found what we are looking for # Save the radar Id # push( @radarIdList, $radarId ); } # # Return the last radarId or the whole list, depending on context # return wantarray ? @radarIdList : $radarIdList[$#radarIdList]; } #------------------------------------------------------------------------------- # Get the radar entry (radarId and radarHost) for a specified function # and optional entry index (1-based, i.e., first, second, etc.) # If an index is not specified, the last radar entry of the specified # function type is returned # Arguments: function, [index] # Prerequisites: setRadarEnv() # Return: radarHostPair[last] -or- radarHostPair[index] # sub getRadarEntry { my( $specifiedFcn, $specifiedIndex ) = @_; my( $index, $found ); # # Look up the radar entry from the radar function table # $index = 1; foreach $entry ( @radarFcnTable ) { # # Skip comment and blank lines # next if ( $entry =~ m/^\s*#/ ); next if ( $entry =~ m/^\s*$/ ); # # Split the line into the expected tokens # ($radarId, $host, $function) = split ' ', $entry; # # Skip entries which are not of the requested function type # next if ( $function ne $specifiedFcn ); # # We have the specified function, see if an index was specified # if ( defined( $specifiedIndex )) { # # if we are at the specified index, we're done # if ( $index == $specifiedIndex ) { $found = true; $foundRadar = $radarId; $foundHost = $host; last; } else { $index++; } } else { $found = true; $foundRadar = $radarId; $foundHost = $host; } } # # Return the specified indexed radarId, if requested # if ( $found ) { return $foundRadar, $foundHost; } else { return; } } #------------------------------------------------------------------------------- # Interpolate the process instance with radarId, substitutions made in place # Arguments: processListFile # Prerequisites: setRadarEnv() # Return: none # sub setProcessInstance { my( $processListFile ) = @_; my( $host, $oldLine, $newLine ); unless ( open( OLD_PROCESS_FILE, "<$processListFile" )) { postMsg( "Cannot open process list file $processListFile", ERROR ); return; } unless ( open( NEW_PROCESS_FILE, ">$processListFile.new" )) { postMsg( "Cannot open process list file $processListFile.new", ERROR ); return; } while( $oldLine = ) { chomp $oldLine; # # Write out comment and blank lines # if ( $oldLine =~ m/^\s*#/ || $oldLine =~ m/^\s*$/ ) { print NEW_PROCESS_FILE "$oldLine\n"; next; } # # Split the line into the expected tokens # ( $process, $instance, $startScript, $killScript, $host, $priority ) = split ' ', $oldLine; # # For now we are only going to interpolate the instance # with a radarId lookup # if ( $instance =~ m/(.*)\?(.+)\?(.*)/ ) { $function = $2; $radar = getRadarId( $function ); if ( !defined( $radar )) { postMsg( "No radar found for '$function'", ERROR ); return; } $newInstance = "$1$radar$3"; $newLine = "$process \t$newInstance \t$startScript \t$killScript \t$host \t$priority"; print NEW_PROCESS_FILE "$newLine\n"; } else { print NEW_PROCESS_FILE "$oldLine\n"; } } # # Move the new file into place # close( OLD_PROCESS_FILE ); close( NEW_PROCESS_FILE ); rename( "$processListFile.new", $processListFile ); } #=============================================================================== # General utilities #=============================================================================== #------------------------------------------------------------------------------- # Append source file to destination file # Arguments: dest, file to append to; source, additions. # Prerequisites: None # Return: None # sub appendFile { my ($source, $dest) = @_; # # Get the sizes of the files involved. This is useful for checking # the result. If the result is not the size we'd expect, experience # suggests that there are some things we should check. # my $destSize = 0; if ( -e $dest ){ $destSize = -s $dest; } my $sourceSize = 0; if ( -e $source){ $sourceSize = -s $source; } my $expectedSize = $destSize + $sourceSize; if ( -e $source ) { $cmd = "cat $source >> $dest"; system( $cmd ); # # Get the size of the result and test it. Trivial errors in this # concatenation process (full disk, permissions issues) have proven # very expensive to debug in the past, so give a hint about what may # be wrong. # my $actualSize = 0; if ( -e $dest ) { $actualSize = -s $dest; } if ($actualSize != $expectedSize) { print STDERR "\nERROR appending $source to $dest :\n"; print STDERR " $dest was $destSize bytes, $source was $sourceSize bytes\n"; print STDERR " Expected result to be $expectedSize bytes, got $actualSize bytes\n"; print STDERR " Check if disk is full or permissions are an issue.\n\n"; } } else { print STDERR "\nWARNING appending $source to $dest but\n"; print STDERR " $source does not exist.\n\n"; } } #------------------------------------------------------------------------------- # Trim leading and trailing blanks -- straight from the Perl Cookbook # Arguments: listOfTokens # Prerequisites: none # Return: @listOfTokens -or- firstToken # sub trim { my @out = @_; for( @out ) { s/^\s+//; s/\s+$//; } return wantarray ? @out : $out[0]; }