# Perl routines to help with network monitoring analysis
#--------------------------------------------------------------*/       
#                                                              */       
#                      DISCLAIMER NOTICE                       */       
#                                                              */       
# This  document  and/or portions  of  the  material and  data */       
# furnished herewith,  was developed under sponsorship  of the */       
# U.S.  Government.  Neither the  U.S. nor the U.S.D.O.E., nor */       
# the Leland Stanford Junior  University, nor their employees, */       
# nor their  respective contractors, subcontractors,  or their */       
# employees,  makes  any  warranty,  express  or  implied,  or */       
# assumes  any  liability   or  responsibility  for  accuracy, */       
# completeness  or usefulness  of any  information, apparatus, */       
# product  or process  disclosed, or  represents that  its use */       
# will not  infringe privately-owned  rights.  Mention  of any */       
# product, its manufacturer, or suppliers shall not, nor is it */       
# intended to, imply approval, disapproval, or fitness for any */       
# particular use.   The U.S. and  the University at  all times */       
# retain the right to use and disseminate same for any purpose */       
# whatsoever.                                                  */       
#--------------------------------------------------------------*/       
# Les Cottrell <cottrell@slac.stanford.edu>
# Copyright (c): Stanford University 1997 
#
# Unpublished work.
# Permission granted to use and modify this library so long as the
# copyright above is maintained, modifications are documented, and
# credit is given for any use of the library.
#
# Thanks are due to many people for reporting bugs and suggestions
# especially John halperin, Connie Logg, Bruce Anderson, Jose Ochoa
#
$version = 1.2;
use strict;
use vars qw($column %config %FORM @normaloutput);

################################################################################
#Derive the sitename for Postscript SAS 180 day file from the full
#hostname.  The input argument contains the hostname, the second argument
#contains the config file to be used for matching hostnames to sitenames
#If no config file is provided or the hostname cannot be matched with any of
#the host_patterns in the config file, then a default algorithm is applied to
#the hostname to provide the sitename. Note that the sitename is returned in
#mixed case (i.e. it is not converted to all lower case or upper case).
# Example:
#    $site=GetSite("www.uu.net", 
#                  "/afs/slac/g/www/cgi-wrap-bin/net/offsite_mon/getsite.cf")
#
# Note I have not made up my mind whether the pattern should be a
# regular expression or simply a text string.  As a result of this 
# indecision the pattern is currently treated as a regular expression, thus
# a pattern of scruz.net which contains a period (.) will match scruz.net and
# scruzanet etc. since the . is treated as any character.  After we have gained
# some experience I will decide how the pattern is to be used.  For the 
# minute you should assume that it is a simple text string and yet beware
# of the ambiguity of the period matching any character.
sub GetSite {  
    local *CONFIG;  
    my ($hostname, $file) = @_;         
    my ($site, $cf, $pattern, $replacement);
    if (defined($file)) {
        if (-e $file) { # File provided and exists, so look for possible 
                        # match & apply if found
            open (CONFIG, "$file") or die "Cannot open $file, yet it exists.\n"; 
            my @config=<CONFIG>; 
            close (CONFIG);
            foreach  $cf (@config) {
       	        $cf =~ s/#{1}.*//;    # remove comments
	        $cf =~ s/^\s*//;      # remove any leading white space
	        if ($cf ne "") {
                    ($pattern, $replacement) = split /\s+/, $cf;
        	    $site = $hostname;
                    if ($site =~ m/$pattern/i) {
                       return $replacement;
                    }
        	} 
            }
        }
    }
    #Apply default algorithm
    $site = $hostname;
    if ($site =~ m/\.net/i) { #Only truncate .net hosts to 20 characters
        $site = substr($site, 0, 20);
    }
    elsif (!($site =~ m/^\w+\.\w+$/) && !($site =~ m/\.$/)) {
        $site = substr($site, 0, 20);
        $site =~ s/\s*[\w-]+\.//; #special case of hosts end with .
    }
    $site =~ tr/a-z/A-Z/; #NB the SITE NAMES ARE ALL UPPER CASE.
    return $site;   
}

################################################################################
# sub InterpolateText
# Takes a block of html found in a file
# (whose name is the first value in the subroutine input array)
# and replaces parameters enclosed in at (@) symbols (e.g. 
# @parameter@) and inserts the values contained in PARM{}
# in place of the @parameter@ place holders.  The resulting text
# is returned as a list.
# Note the calling routine must have done a Perl require to provide the cgi-lib 
# function CgiDie.
# Example:
# require "/afs/slac/g/www/cgi-lib/cgi-lib.pl";
# ...
# print InterpolateText("/afs/slac/g/www/cgi-wrap-bin/net/offsite_mon/connectivity.head", %parm),"\n"; 
sub InterpolateText{
    my @text;
    local *INPUT;
    my $file = $_[0];    # the first subroutine parameter = the file name
    shift @_;            # remove the file name
    my %PARM = @_;       # put the rest of array into key/value pairs
    open (INPUT, $file) or CgiDie("$file not found\n");
    my @text = <INPUT>;
    close (INPUT);
    @text =~ map s/@(\w+)@/$PARM{$1}/g, @text; # do substitution
    return @text;
}

################################################################################
# subroutines to help sort by column, $column is non local.
################################################################################
sub numericbycolumn{
    my @tempa = split(/\s+/,$a);
    my @tempb = split(/\s+/,$b);
    if ((!defined $tempb[$column]) || ($tempb[$column] !~ /^\d+\.?\d*$/)){
	return -1;
    }
    if ((!defined $tempa[$column]) || ($tempa[$column] !~ /^\d+\.?\d*$/)){
	return +1;
    }
    $tempb[$column] <=> $tempa[$column];
}
sub alphabycolumn{
    my @tempa = split(/\s+/,$a);
    my @tempb = split(/\s+/,$b);
    lc($tempa[$column]) cmp lc($tempb[$column]);
}

################################################################################
# generate html file from array table @normaloutput 
# using hash %FORM for QUERY_STRING data and
# using configuration array @config for configuration information from the
# calling program (lower case) and from a .cf configuration file (upper case)
# references are passed to htsort to avoid copying @normaloutput 
#
# &htsort(*config, *FORM, *normaloutput)
#
################################################################################  
sub HtSort{
    local (*config, *FORM, *normaloutput) = @_;
    my $debug = $config{"debug"};

    my $line;
    foreach $line (@normaloutput){     # remove leading and trailing white space
	$line =~ s/^\s*(.*?)\s*$/$1/;
    }
#-------------------------------------------------------------------------------
# format data to be viewed under Microsoft Excel
#-------------------------------------------------------------------------------
    if ( defined($FORM{'format'})) {
        if ($FORM{'format'} eq "tsv"){
            print "Content-type: text/tab-separated-values\n\n";
            foreach $line (@normaloutput){
   	        $line =~ s/\s+/\t/g;
	        print $line, "\n";
            }
        }
        elsif ($FORM{'format'} eq "csv") {
            print "Content-type: text/comma-separated-values\n\n";
            foreach $line (@normaloutput){
                $line =~ s/\s+/\,/g;
                print $line, "\n";
            }
        }
        else {CgiDie("Unknown format $FORM{'format'}!\n");}
        exit(0);           
    } 

#-------------------------------------------------------------------------------
# what is the maximum number of columns?
#-------------------------------------------------------------------------------
    my $max_column_count = 0;
    my @table = ();
    my @number_of_columns = ();
    my ($number_of_columns, $line);
    my $tref;
    foreach $line (@normaloutput){
	$tref = [split /\s+/,$line];                # separate line into columns
	$number_of_columns = @$tref;                # columns in this row
	if ($number_of_columns > $max_column_count){
	    $max_column_count = $number_of_columns; # save max number of columns
	    if ($debug>0){print "MaxColCount = $max_column_count<br>\n";}
	}
    }
    
#-------------------------------------------------------------------------------
# Check that the column number to sort on is valid.
#-------------------------------------------------------------------------------
    local $column;                            # to be visible by sorting subs
    if (!defined($FORM{'column'})) {$column = 0;}  # check for sorting request
    else                           {$column = $FORM{'column'};}
    unless (($column =~ /^\d+$/) && ($column <= $max_column_count)
         && ($column >= 0)) {
	CgiDie("The column number '$column' to sort on that was provided in 
                QUERY_STRING ($ENV{'QUERY_STRING'}) must be in 
                range 0-$max_column_count.<br>\n");
    }

#-------------------------------------------------------------------------------
# sort array @normaloutput by chosen $column
#-------------------------------------------------------------------------------
    my @sortedoutput;
    my $i;
    if($column >= 0){
	if ($debug > 0) {print "Sorting on column $column<br>\n";}
	my @removedtitles;
       	# remove column title lines
	if ( $config{"headlines"} > 0 ){
	    for ($i=0;$i<$config{"headlines"};$i++){
		$removedtitles[$i] = shift @normaloutput;
	    }
	}
	if ((split /\s+/, $normaloutput[0]) [$column] =~ /^\d+\.?\d*$/) {
	    @sortedoutput = sort numericbycolumn @normaloutput;
	}
	else {@sortedoutput = sort alphabycolumn @normaloutput;}
	@normaloutput = @sortedoutput;
	# restore column title lines;
	if ( $config{"headlines"} > 0 ){
	    for ($i=$config{"headlines"}-1;$i >= 0;$i--){
		unshift @normaloutput, $removedtitles[$i];
	    }
	}
    }
    
#-------------------------------------------------------------------------------
# assign table after sorting
#-------------------------------------------------------------------------------
    @table = ();
    foreach $line (@normaloutput){
	$tref = [split /\s+/,$line];                # separate line into columns
	push (@table,$tref);                        # save this row in the table
	$number_of_columns = @$tref;                # columns in this row
	push (@number_of_columns,scalar(@$tref));   # save number of columns
	if ($number_of_columns > $max_column_count){
	    $max_column_count = $number_of_columns; # save max number of columns
	    if ($debug>0){print "MaxColCount = $max_column_count<br>\n";}
	}
    }
    
#-------------------------------------------------------------------------------    
# write any html text to display before the table
#-------------------------------------------------------------------------------
#    print &PrintHeader;         # Content-type:text/html 
#    if (defined $config{"HEADFILE"}){
#	print InterpolateText($config{"HEADFILE"}, %config);
#    }
    print "<pre>\n";
    
#-------------------------------------------------------------------------------
# what is the widest field in each column?
#-------------------------------------------------------------------------------
    my ($j, $i, $partwidth);
    my @wid = (0) x $max_column_count;
    for($i=0;$i<@normaloutput;$i++){    # index through the rows of the table
	$tref = $table[$i];
	for($j = 0; $j < $number_of_columns[$i] ; $j++){
	    $partwidth = length($tref->[$j]);
	    if ($partwidth > $wid[$j]){
		$wid[$j]=$partwidth; 
	    }
	}
    }
    
#-------------------------------------------------------------------------------
# make labels and column sorting links for the columns
#-------------------------------------------------------------------------------
    my $headrow;
    my @col;
    my @tag;
    my $column_label;
    unless (defined($FORM{"rawdata"})) {$FORM{"rawdata"} = "";}
    if (defined $config{headlines} && $config{headlines} > 0){
	# format column titles that do not have column sorting links
	for ($headrow = 0;$headrow <  ($config{headlines}-1);$headrow++){
	    my ($column_label, @col, @tag);
	    @col = split /\s+/, $normaloutput[$headrow];
	    for($i = 0; $i < $max_column_count; $i++){
		if (!defined $col[$i]){$col[$i] = "c$i";}
		if(length $col[$i] > $wid[$i]){
		    $col[$i] = substr($col[$i],0,$wid[$i]);
		}
		$column_label = sprintf("%-$wid[$i]s",$col[$i]);
		print "$column_label  ";
	    }
	    print "\n";
	}   
	
	# format column titles with column sorting links
	@col = split /\s+/, $normaloutput[$config{headlines}-1];       
	for($i = 0; $i < $max_column_count; $i++){
	    if (!defined $col[$i]){$col[$i] = "c$i";}
	    if(length $col[$i] > $wid[$i]){
		$col[$i] = substr($col[$i],0,$wid[$i]);
	    }
	    $column_label = sprintf("%-$wid[$i]s",$col[$i]);
	    $tag[$i] = "<a href = $config{'SCRIPTURL'}?$FORM{'rawdata'}&" .
		"column=$i>$column_label</a>";
	    print "$tag[$i]  ";
	}
	print "\n\n";
    } 

#-------------------------------------------------------------------------------
# which column data needs links?
#-------------------------------------------------------------------------------
# begin link formation by identify column data that wants links
    my ($nodecolumn, @base, @pre, @post, @parts);
    for($j=0;$j<$max_column_count;$j++){
	if(defined $config{"URLCOLUMN$j"}){
	    $base[$j] = $config{"URLCOLUMN$j"}; 
	    @parts    = split /\s+/,$base[$j];  #split into flag, path, sub
	    if (defined($parts[1])) {
	        ($pre[$j], $post[$j]) = split /\@/, $parts[1]; 
	    }
	    else {$pre[$j]=""; $post[$j]="";}
	    unless (defined($post[$j])) {$post[$j]="";}
	}
	$nodecolumn = $config{"nodecolumn"}; # links depend on the node name
    }
    
# complete link formation for each type and output html for the table itself
    my ($anch_start, $anch_end, $colors, $colore, $type, $root, $node);
    my $site;
    if ($debug > 0) {print "Normal output=@normaloutput<br>\n";}
    for($i = $config{"headlines"};$i < @normaloutput;$i++){ # index through rows
	for($j = 0; $j < $number_of_columns[$i]; $j++){ # index through columns
	    $anch_start = "";
	    $anch_end = "";
	    $colors = "";
	    $colore = "";
            # if column gets colors, define them here
	    if (defined $config{"colorcolumn$j"}){
		#print "COLOR FOR COLUMN $j\n";
		$colors = "<font color = black><b>";
		if ($table[$i][$j] >= $config{"green"}){
		    $colors = "<font color = green><b>";
		}
		if ($table[$i][$j] >= $config{"orange"}){
		    $colors = "<font color = orange><b>";
		}
		if ($table[$i][$j] >= $config{"red"}){
		    $colors = "<font color = red><b>";
		}
		$colore = "</font></b>";
	    }
	    # if column gets a link, define it here
	    if(defined $base[$j]){
		@parts = split /\s+/, $base[$j];
		$type = shift @parts;                 # get type of info
		$root = $pre[$j];
		$node = $table[$i][$nodecolumn];
		if ($type =~ /NORMAL/){
		    $site = $node;
		}
		if ($type =~ /GETSITE/){
		    $site = GetSite($node,$config{GETSITECF});
		}
		if ($type =~ /RAWDATA/){
		    $root = "$config{SCRIPTURL}?rawdata=";
		    $site = $node;
		}
		$anch_start = "<a href=$root$site$post[$j]>";
		$anch_end = "</a>";
	    }
	    $anch_start = $anch_start . $colors;
	    $anch_end = $anch_end . $colore;
	    if($table[$i][$j] =~ /\D+/){
		printf (STDOUT "$anch_start%-$wid[$j]s$anch_end  ",$table[$i][$j]);
	    }
	    else{
		printf(STDOUT "$anch_start%$wid[$j]s$anch_end  ",$table[$i][$j]);
	    }
	}
	print "\n";
    }
    
    # write html for any text to display after the table
    if (defined $config{"FOOTFILE"}){
	print("</pre>\n", InterpolateText($config{"FOOTFILE"}, %config));
    }

}

################################################################################
sub SeekBinSrch # ( *FH, $key, $close_enough )

# Subroutine to seek to the vicinity of the $begin data records in the
# ping_data file using a binary search.  The binary search only attempts
# to get within $close_enough bytes of the "exact" position in the sorted
# file which contains the search key (or, if no such record exists in the
# file, then to where such a record would be placed if it existed).

# More precisely, the binary search finds a region of the file such that
# (1) the size of the region is less than or equal to $close_enough bytes;
# (2) the beginning of the region is the beginning of a record whose key is
#     less than or equal to the search key if such a record exists, otherwise
#     the start of the region is the start of the file; and
# (3) the first record that begins after the end of the region has a key
#     which is greater than or equal to the search key if such a record
#     exists, otherwise the end of the region is the end of the file.
# The file is left positioned to the beginning of the region.
#
# Author: John Halperin <jxh@slac.stanford.edu>  6 June 1997.

{
  local(*FH) = $_[0];
  my($key, $close_enough) = @_[1..2];
  my($lo_posn, $hi_posn);

  return unless (-f FH);		# can't handle pipes or other oddities
    
  $lo_posn = 0;
  $hi_posn = (-s FH)  or  die "BinSrchFile: error stat'ing FH: $!\n";

  my $loop_ct = 0;
  my($mid_posn, $rec_start, $rec, $rec_key, $lt_eq_gt, $errct);

BinSrch:
  while (($hi_posn - $lo_posn) > $close_enough && ++$loop_ct < 40)  {
    $mid_posn = ($lo_posn + $hi_posn) >> 1;
    seek(FH, $mid_posn, 0)  or
	die "BinSrchFile: seek($mid_posn) failed: $!\n";
    <FH>;				# skip to start of next record
    for ($errct = 0; ; ) {
      $rec_start = (tell);
      last BinSrch if ($rec_start >= $hi_posn);
      $rec = <FH>  or  die "SeekBinSrch: error reading file: $!\n";
      $rec_key = (split(/ /, $rec, 7))[5];
      last if (defined($rec_key) && $rec_key =~ m/^\d+$/);
      warn "BinSrchFile: record at posn $rec_start has a bad timestamp\n",
        "*** $rec";
      die "BinSrchFile terminating\n" if (++$errct > 10);
    }
    $lt_eq_gt = $key - $rec_key;

    if ($lt_eq_gt < 0)  {
      $hi_posn = $mid_posn;		# srch key < rec, so drop ceiling
    }
    elsif ($lt_eq_gt > 0)  {
      $lo_posn = $rec_start;		# srch key > rec, so raise floor
    }
    else {
      $hi_posn = $lo_posn = $rec_start;	# key == rec; found.
    }
  } # BinSrch: while ()
  die "BinSrchFile failed; looping?\n"
    if (($hi_posn - $lo_posn) > $close_enough);

  seek(FH, $lo_posn, 0)  or
    die "BinSrchFile: seek($lo_posn) failed: $!\n";
} # &SeekBinSrch()
1;