#!/usr/bin/perl
#JLIB.pm:  John's Library for perl.
#          This file contains general purpose perl library routines
#          that don't know anything about T3 and might be useful on
#          other projects.  The T3 specific library routines should
#          go into T3_RW.pm or other libraries.
#
package JLIB;
use strict;
use warnings;


use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);
$VERSION = 0.01;
@EXPORT = qw(
	     any_in_list
	     approx_equal
             array_to_file
             assert_or_die

	     BA_to_big_hex
	     backup_file

	     big_hex_to_BA
             binfile_to_array
	     bit_get
	     build_exec_path_cmd
	     build_mask_from_hi_lo

	     canonicalize_space
	     center_str
	     chomp_allspace
	     chomprn
	     chomp_outer_space
	     chomp_trailing_space
             coin_flip
	     columnize
             defeq
             defeqnum
             dh2n
             dhr2n
	     diff_BA
             dx2n

             DBG
             DBG_exists
             DBG_is_on
             DBG_set
             DBGP

	     end_with_newline

	     endian_reverse_32

	     f2n
             file_to_array
             file_to_str
	     find_in_list

	     get_dir
	     get_exec_path
	     get_tree_files
             get_random_list_entry
             get_random_list_or_range
             get_random_uint
             get_weighted_random_list_entry
             get_weighted_random_uint

	     graphics_parse
	     graphics_launch

	     hashN_key_to_numlist
	     hashN_swap
	     hash_keyval_filearray
	     hash_keyval_filestr

	     in_list
	     indent_str
	     mark_str_start
	     ipv6str_to_A

	     is_executable
	     is_in_hash
	     is_ipv4

	     join_backslashed_lines

	     length_last_line
	     max_length

	     max_num
	     min_num

	     prompt
	     prs_arg

	     random_true_100

	     x2n

	     sort_numlist
	     split_n_strip
	     sprintf_hash
	     sprintf_table

	     

	     prflush
             prw
             prwf
             prw_set_logfile

             qxw
             readline_alarmed


	     spaces_to_tabs
	     spr_expanded_ipv6_from_A
	     spr_hexdump
	     spr_hexdump_w_ascii
	     spr_hexdump_first_last
	     spr_hexstream
	     spr_repeated_str
	     

	     swap
	     swizzle
             str_to_file
	     

	     
	     strip_blank_lines
	     strip_comments
	     strip_comments_and_extra_white
	     strip_extra_spaces_and_tabs
	     strip_leading_white
	     strip_trailing_white
	     massage_filestr

	     sysctl_read
	     sysctl_write
	     systemw

	     tab_length

	     word_wrap_str

             JLIB_init

             $JLIB_whatever
            );





## exported symbols
our $JLIB_whatever;

## non exported symbols

##------------------------------------------------------------------------
#        print, printf wrappers and the DBG function.
##------------------------------------------------------------------------

#:JLIB_init
#:extract any -debug <switch name> switches from the command line arguments,
#:and turn that debugging feature on.
#:
#:How to use -debug:
#:  In your code add lines like:
#:    DBG("input", "input = %u",$input);
#:  or
#:  if (DBG_is_on("cla")) {
#:    print "Command Line Argument Hash:\n";
#:    print indent_str(sprintf_hash($cla),5);
#:  } 
#: 
#: In above examples, "input" and "cla are the <switch names>
#:
#: then when you call the perl script, just add "-debug input" or
#: "-debug cla" to the command line to cause those debug messages to 
#: print or debug code to execute.
#: 
#: You can support multiple debug switches at the same time:
#:     rreg.pl 0x340 -debug cla -debug input
#:
#: TODO:  add a way for -debug to support multiple debug switches
#:        in one shot, like -debug (input,cla) or something.

sub JLIB_init {
  my @NEWARGV;
  
  for(my $i=0 ; $i<=$#_ ; $i++) {
#    if ( ($_[$i] eq "-debug") and ($i+1 <= $#_) and ($_[$i+1] != /^-/) ) {
    if ( ($_[$i] eq "-debug") and ($i+1 <= $#_)  ) {
      DBG_set($_[$i+1],1);
      $i++; #give $i an extra bump for the argument.
    } else {
      @NEWARGV = (@NEWARGV,$_[$i]);
    }
  }
  return @NEWARGV;
}


{


  my $logfile="";
  sub prw_set_logfile {
    $logfile=shift;
  }

  sub prw {
    if ($logfile ne "") {
      open(LOGFILE,">> $logfile");
      if (1==@_) { print  LOGFILE @_}
      else       { printf LOGFILE @_}
      close LOGFILE;
    }
    
    if (1==@_) { return (print @_)}
    else       { return (printf @_)}
  }
  
  #prwf is alias for prw.  This is so I can easily switch
  #back to print and printf in source files in case there is a problem,
  #with either the wrapper concept or the combined print/printf concept.
  sub  prwf {return (prw @_)}

  #prflush turns off buffering when printing.
  sub prflush {
    local $|=1;  #Turn off buffering until we've printed this string.
    return (prw @_);
  }


  sub prompt {
    prflush @_;
    my $dummy=<STDIN>;
  }


  my %debug;

  sub DBG_exists {return exists $debug{$_[0]}}
  sub DBG_is_on {return $debug{$_[0]}}
  sub DBG_set {$debug{$_[0]} = $_[1]}
  sub DBGP { prflush @_}

  sub DBG {
    if ($debug{$_[0]}) {
      shift;
      DBGP (@_);
    }
  }

}





#assert_or_die
#-------------
#IN: string to eval.  If string not true, die.
sub assert_or_die {
  my $assert = shift;
  eval ($assert) or die "Assertion failure: $assert\n";
  #TODO: print call stack or line, file info.
    
}


##------------------------------------------------------------------------
#                        Basic test routines
##------------------------------------------------------------------------

#: is_number
#: ---------
#: Return true if the scalar is number, else false if a string.  Intended for
#: subroutines to determine if they should use "eq" or "==" comparison.
#: IN: $_[0] : Value to test.
#: OUT: RET  : 1 if number, 0 if string or reference.
#:
#: Warning: not quite perfect.  Returns true for "0.0\n"

sub is_number {
  my $var = $_[0];
  my $ret=1;


  no warnings;
  if  ($var == 0 and $var ne "0" and $var !~ /^[\+-][0]+\.[0]+[^\n]$/) {$ret=0}
  # If a non-numeric string is used in a comparison, perl converts it to
  # a zero, so then you just have to check for the $var being
  # numeric zero, or a string that can convert into a zero.

  # This isn't quite perfect.  It returns True for strings like "0.0\n".

  return $ret;
}


#: swap
#:---------------
#: IN: References to Two scalars
#: OUT: the scalars are swapped
sub swap {
  my $c=$_[0];
  $_[0]=$_[1];
  $_[1]=$c;
}

#: max_num, min_num
#:-----------------
#: IN: Two numbers
#: Ret: maximum or minimum of two numbers
sub max_num {
  return ($_[0] > $_[1] ? $_[0] : $_[1]);
}
sub min_num {
  return ($_[0] > $_[1] ? $_[1] : $_[0]);
}


#:approx_equal
#:---------------
#: IN: Two numbers and an allowed % difference.
#: RET: True if two values are within a few percentage points of each other
#:      else FALSE.

sub approx_equal {
  my $hi=shift;
  my $lo=shift;
  my $okpct=shift;

  if ($lo>$hi) {($lo,$hi) = ($hi,$lo);}
  my $diffpct = ($hi - $lo)*100/$hi;

  return ($okpct >= $diffpct);
}

#:max_length
#: IN: Array or array reference to an array of strings.
#: OUT: length of longest string in the array.
sub max_length {
  my @list=();
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}

  my $ret=0;

  foreach my $word (@list) {
    if (length($word)>$ret) {$ret=length($word)}
  }


  return $ret;
}


##------------------------------------------------------------------------
#                        JOB control subroutines
##------------------------------------------------------------------------


#:qxw:  Wrapper around the "qx" or backquotes command function.
#:---   Note: you cannot use qxw to run process in the background.
#:            because it will wait for the returned data.
#:      Use system instead.  TODO: system wrapper.  Also, can I suppress
#:      system output.
#:
#:  IN:  $_[0]: String to execute.
#:       $_[1]: ctl:  optional string of flags to tweak this routines behavior
#:                    flags: 
#:                           show:    display the command before executing it.
#:                           showret: display the returned string.
#:                           nostderr: Don't capture standard error. 
#:               if above flag not present, then default behavior
#:               is to:
#:                           1. not show the command before executing it.
#:                           2. not show the ret.
#:      $_[2]: status:  optional reference to scaler where status from O.S.
#:                      will be put. If the status field is not present, then
#:                      this command will "die" on a return of a 
#:                      non-zero status from O.S.
#:
#: OUT:  $ret=output of `$_[0] 2>&1`.
#:
#:  TODO: add a "system" option to qxw  to use system() with a "tee" to 
#:  a  tempfile, then read in tempfile and return output of command.
#:  This way we can display command progress in real time and still
#:  capture ouput of command.
#:

sub qxw {
  my $cmd   =$_[0];
  my $ctl   =$_[1];
  my $status=$_[2];


  my $ret="";
  my $ret_shown=0;
  my $dummy_status;

  if ($#_<1) {$ctl="";}
  if ($#_<2) {$status=\$dummy_status;}

  chomp $cmd;  #"/n at end of command causes redirection failure.
  if ($ctl !~ /\bnostderr\b/) {$cmd.=" 2>&1"}

  if ($ctl =~ /\bshow\b/ or DBG_is_on("qxw")) {prw("$cmd\n")};
  $ret=`$cmd`;
  $$status=$?;
  #perl sometimes shifts status return by 8 so it can put signal info
  #in lower bits, I think.  Nees more research.  I'm going to undo this
  #status matches value returned.
  if ($$status and 0==($$status & 0xFF)) {$$status>>=8}
  #print "status=$$status\n";
  if ($ctl =~ /\bshowret\b/ or DBG_is_on("qxw")) {
    prw("$ret\n");
    $ret_shown=1;
  };

  if ($$status && $#_<2) {
    if (!defined $ret) {$ret=""}
    if (!$ret_shown) {prw "$ret\n"};
    die "The command \`$cmd\` failed, returning status: $$status\n";
  }
  
  return $ret;
}



##: systemw
#:  -------
#:  Wrapper around the system() call that prints command it is
#:  about to execute, then executes it, then immediately reads O.S. status, 
#:  and does any massaging needed.
#:  Advantage of systemw over qxw:  Displays messages as command runs.
#:  Disadvantage of systemw vs qxw: Cannot easily caputre command output.
#:
#: 
sub systemw {
  my $cmd=shift;
  my $ctl = ($#_>=0) ? shift : "";

  if ($ctl =~ /\bshow\b/) {
    print $cmd."\n";
  }
  system($cmd);
  my $status=$?;
  if ($status and 0==($status & 0xFF)) {$status>>=8}
  

  return $status;
}



##------------------------------------------------------------------------
#                        FILE Read/Write subroutines
##------------------------------------------------------------------------

#Note: you could rewrite this as "get_file()" and use wantarray
#to determine if we return it as stirng or array.

#:file_to_str    : public wrapper around file_to_str_or_array.
#:file_to_array  : public wrapper around file_to_str_or_array
sub file_to_str {
  if ($#_<1) {return file_to_str_or_array($_[0],"\$");}
  else       {return file_to_str_or_array($_[0],"\$",$_[1]);}
}
sub file_to_array {
  if ($#_<1) {return file_to_str_or_array($_[0],"@");}
  else       {return file_to_str_or_array($_[0],"@",$_[1]);}
}


#:file_to_str_or_array:  
#:--------------------
#: Read a text file and put it into a string or an array.
#: IN:  $_[0]: filename
#:      $_[1]: "$" for a string, else an array is assumed.
#:      $_[2]: optional reference to scalar status.  If status not present
#:             this subroutine will die if file does not exist or cannot
#:             be opened.  If status is present, then the return will be:
#:                  ""               : success, file successfully read.
#:                  "$filename does not exist" : file failed the -e test.
#:                  "Error opening $filename: $!" : $! from resulting failure.
#:                  "Error closing $filename: $!" : $! from resulting failure.

sub file_to_str_or_array {
  my $filename   =$_[0];
  my $ret_type   =$_[1];
  my $status     =$_[2];


  my $ret="";
  my @ret=();
  my $ret_shown=0;
  my $dummy_status;


  if ($#_<2) {$status=\$dummy_status;}
  $$status="";

  unless (-e $filename) {
    $$status="$filename does not exist";
  } else {
    open (FH,$filename) or $$status="Error opening $filename: $!";
  }
  if (!$$status) {
    if ($ret_type eq "\$") {
      local $/;
      $ret = <FH>;
    } else {
      @ret = <FH>;
    }
    close (FH)          or $$status="Error closing $filename: $!";
  }

  if ($$status && $#_<2) {die "Error in file_to_str_or_array:  $$status\n";}

  if ($ret_type eq "\$") {
    return $ret;
  } else {
    return @ret;
  }
}



#:binfile_to_array:
#:--------------------
#: Read a binary file into an array
#: IN:  $_[0]: filename
#:      $_[1]: optional reference to scalar status.  If status not present
#:             this subroutine will die if file does not exist or cannot
#:             be opened.  If status is present, then the return will be:
#:                  ""               : success, file successfully read.
#:                  "$filename does not exist" : file failed the -e test.
#:                  "Error opening $filename: $!" : $! from resulting failure.
#:                  "Error closing $filename: $!" : $! from resulting failure.

sub binfile_to_array {
  my $filename   =$_[0];
  my $status     =$_[1];


  my @ret=();
  my $ret_shown=0;
  my $dummy_status;

  if ($#_<1) {$status=\$dummy_status;}
  $$status="";

  unless (-e $filename) {
    $$status="$filename does not exist";
  } else {
    open (FH,$filename) or $$status="Error opening $filename: $!";
  }

  
  if (!$$status) {
    binmode FH;
    my $filestr;
    my $offset=0;
    while (read(FH,$filestr,4096,$offset)) {
      $offset=length $filestr;
    }
    close (FH)          or $$status="Error closing $filename: $!";
    @ret = unpack("C*",$filestr);
  }


  if ($$status && $#_<1) {die "Error in binfile_to_array:  $$status\n";}

  return wantarray ? @ret : \@ret;
}



#:str_to_file:
#:array_to_file
#:--------------------
#: Write a string to a text file.  
#: IN:  $_[0]: str for str_to_file, array reference for array_to_file
#:      $_[1]: filename
#:      $_[2]: optional mode.
#:                If 0 or not present, don't replace an existing file.
#:                else $mode is prepended to filename on open operation:
#:                ">" will create new or replace existing file.
#:                ">>" will create new or append to existing file.
#:             replace existing file, if 1, replace it.
#:      $_[3]: optional status flag.  If variable is not present
#:             or equal to zero, this subroutine will die if the 
#:             write fails.  If flag present and non-zero, then
#:             we will return the following:
#:
#:                  ""                  : success, file successfully written.
#:                  "Error writing $filename: $!" : $! from resulting failure.
#:
#: This subroutine will also die if the filename is longer than 1024 bytes,
#: on the assumption that the user got the $str and $filename variables
#: mixed up.

sub str_to_file {
  my $str         =$_[0];
  my $filename    =$_[1];
  my $mode        =$_[2];
  my $nodie       =$_[3];

  my $ret="";

  if (DBG_is_on("str_to_file")) {
    DBGP ("str_to_file: $filename: mode |$mode|, nodie=|$nodie|\n");
  }

  if (length $filename >1024) {
    $ret = sprintf 
"Programming error in str_to_file.  The filename string has a
length of %u, which is > 1024.\n",length $filename;
    if (length $str <=1024) {
      $ret.=sprintf
"You may have reversed the string and filename arguments, as the
strings length is only %u\n",length $str;
    }
    goto out;
  }


  if (!$mode && -e $filename) {
    $ret                          ="Error: $filename already exists";
  } else {
    if (!$mode) { $mode=">";}
    if ($mode ne ">" && $mode ne ">>" && $mode ne "+>>") {
      die "Programming Error in str_to_file: invalid value for mode: $mode\n";
    }
    open (FH,"$mode $filename") or $ret="Error opening $filename: $!";
    if (!$ret) {
      print FH $str        or $ret="Error writing $filename: $!";
      if (!$ret) {
        close (FH)         or $ret="Error closing $filename: $!";
      }
    }
  }

 out:
  if ($ret && !$nodie) {
    die "Error in str_to_file: $ret\n";
  }

  return $ret;
}


sub array_to_file {
  my $aref = shift;
  my $str=join "", @$aref;
  return (str_to_file($str,@_));
}









#:file_backup
#:--------------------
#: Copy a file to a backup file.
#: IN:  $_[0]: filename
#:      $_[1]: control string
#:      $_[2]: optional reference to scalar status.  If status not present
#:             this subroutine will die if file cannot be backed up.
#:             If status is present, then the return will be:
#:                  ""               : success, file successfully read.
#:                  "$filename does not exist" : file failed the -e test.
#:                  "Error opening $filename: $!" : $! from resulting failure.
#:                  "Error closing $filename: $!" : $! from resulting failure.
#: RET: 1 if file backed up, 0 if $status is non-zero.

#TODO:  allow the control to affect whether we overwrite an existing backup,
#       or whether we always find a unique filename for the backup.

sub backup_file {
  my $filename   =$_[0];
  my $ctl        =$_[1];
  my $status     =$_[2];
  
  my $ret=1;  #assume success

  my $ret_shown=0;
  my $dummy_status;
  my $die_on_err=0;
  if ($#_<2) {
    $status=\$dummy_status;
    $die_on_err=1;
  }

  $$status="";

  my $backupname=$filename.".backup"; #TODO: Allow $ctl to affect naming conv.

  unless (-e $filename) {
    $$status="$filename does not exist";
  } else {
    my $filedata;
    $filedata=file_to_str($filename,$status);
    if (!$$status) {
      str_to_file($filedata,$backupname,">",$status);
    }
    if ($$status) {
      if ($die_on_err) {die "Error in backup_file:  $$status\n";}
      else             {$ret=0;}
    }
  }

  return $ret;
}





#: is_executable
#: -------------
#: Checks to see if the given file name is in our PATH and is executable.
#: If file is not in a directory in our PATH or is not executable, 
#: returns undef, else returns absolute filename of first occurrence
#: of the program.
#: 
sub is_executable {
  my $searchname=$_[0];
  my $ret;

 # print "PATH:\n |$ENV{PATH}|\n";

  my $slash='/';
  my $splitter=':';
  my $ext="";

  if ($^O =~ /win/i) {
    $slash='\\';
    $splitter=';';
    $ext=".exe";
  }
    
  my @path_dirs=split($splitter,$ENV{PATH});
  foreach my $dir (@path_dirs) {
    #    print "|$dir|\n";
    my $absolute_filename=$dir.$slash.$searchname.$ext;
    #print "checking: |$absolute_filename|\n";
    if (-x $absolute_filename) {
      $ret=$absolute_filename;
      last;
    }
  }
  
  return $ret;
}


#: get_exec_path
#: -------------
#: IN: none
#: OUT: return the path that was used to execute this program.
#:

sub get_exec_path {
  my $ret="";
  my $program_name=$0; #Load name of program.
  if ( $program_name =~ /^(.+)\/[^\/]+$/) {
    $ret=$1."/";
  }
  return $ret;
}


#: build_exec_path_cmd
#: -------------------
#: IN: $base_cmd:  Name of a program to run.
#:     $ctl:  optional control string.  If present and contains "die",
#:            then will die with error message 
#: RETURN: If $base_cmd is executable via PATH environment variable,
#:          then returns $base_cmd unchanged.
#:          Else if executable is found in same path the running
#:          program was launched from, returns that path/$base_cmd.
#:          Else returns undef or dies with error message if $ctl
#:          contains "die".
#:
sub build_exec_path_cmd {
  my $base_cmd=shift;
  my $ctl = ($#_>=0) ? shift : "";

  my $program_path;
  my $cmd=$base_cmd;
  if (!defined is_executable($cmd)) {
    $program_path=get_exec_path();
    $cmd=$program_path.$cmd;
    if (not -x $cmd) {$cmd=undef}
  }
  if (!defined $cmd and $ctl =~ /\bdie\b/) {
    die "Cannot find  $base_cmd in PATH:\n $ENV{PATH}\n".
      "\nAlso, cannot find in program path:\n     $program_path\n";
  }
  
  return $cmd;
}


##------------------------------------------------------------------------
#                        strip_* functions
##------------------------------------------------------------------------


#: strip_comments
#: --------------
#: Strip comments out of a multi-line string.
sub strip_comments {
  my $ret = $_[0];
  $ret =~ s/\#.*//g;   
  return $ret;
}


#: strip_leading_white
#: -------------------
#: Strip leading white space from each line of a multi-line string.
sub strip_leading_white {
  my $ret = $_[0];
  $ret =~ s/^\s+?(\S|\n)/$1/mg;
  return $ret;
}

#: strip_trailing_white
#: --------------------
#: Strip trailing white space from each line
#: of a multi-line string.
sub strip_trailing_white {
  my $ret = $_[0];
  $ret =~ s/\s+?(\n)/\n/mg;
  return $ret;
}


#: strip_blank_lines
#: -----------------
#: Strip blank lines a of multi-line string.
sub strip_blank_lines {
  my $ret = $_[0];
  $ret =~ s/^\s*\n//mg;
  return $ret;
}

#: strip_extra_spaces_and_tabs
#: ---------------------------
#: Reduce spaces and tabs to a single space
sub strip_extra_spaces_and_tabs {
  my $ret = $_[0];
  $ret =~ s/[ \t]+/ /g;
  return $ret;
}




#: strip_comments_and_extra_white
#: ------------------------------
#: Strip comments, blank lines, leading and trailing white space from each line
#: of a multi-line string. 
sub strip_comments_and_extra_white {
  my $ret = $_[0];
  $ret = strip_comments($ret);
  $ret = strip_leading_white($ret);
  $ret = strip_trailing_white($ret);
  $ret = strip_blank_lines($ret);
  $ret = strip_extra_spaces_and_tabs($ret);

  return $ret;
}


#: join_backslashed_lines
#: --------------
#: remove \\\s*\n at end of line and replace with a space
sub join_backslashed_lines {
  my $ret = $_[0];
  $ret =~ s/\\\s*\n//g;
  return $ret;
}


#: massage_filestr
#: ----------------
#: This function takes a multiline string that typically has just
#: been read from a file, and a control string.  the function then
#: massages that string to a standardized format as specified by the control
#: string.
#: 
#: IN:  $_[0]: filestr (typically the output of file_to_str)
#:      $_[1]: control string.  Currently supported formats:
#:             ""  : strip comments, strip all white space and start
#:                   of line, all white space and end of line (except for
#:                   the newline, and reduce all inter-word white space
#:                   to a single space.  Also, make sure the last
#:                   line of the string ends with a newline.
#:             "@" : same as above, and then split string into an array
#:                   and return the array.
#: RET: massaged file string



#: This function is typically called after reading a file into a string.
#: This function will put file into a desired format.
#: IN: Strip comments, blank lines, leading and trailing white space from each line
#: of a multi-line string. 
sub massage_filestr {
  my $ret = $_[0];

  my $ctl="";
  if ($#_>=1) {$ctl = $_[1];}

  end_with_newline($ret);
  $ret = strip_comments_and_extra_white($ret);


  if ($ctl =~ /@/) {
    return split(/\n/,$ret);
  } else {
    return $ret;
  }
}








##------------------------------------------------------------------------
#                        INPUT/OUTPUT subroutines
##------------------------------------------------------------------------

#:readline_alarmed
#:----------------
#:readline_alarmed is like read line, only it uses the $SIG{ALRM} mechanism
#:to implement a timeout.  Note that if you call this function, you
#:won't be able to use alarm elsewhere.
#:This weird looking "eval" code is explained in Programming Perl in the
#:"Timing Out Slow Operations" section.  However, the $@ variable
#:doesn't seem to work, so I used the $alarm_expired variable instead.
#:
#:This routine is mainly intended to used for reading pipes that
#:are running concurrently.
#:
#:Two arguments:
#: $_[0]: File handle for the pipe.
#: $_[1]: timeout value, in seconds, with 1 second as the minimum.
#:Returns:
#: If line was read, it returns the $line.
#: If eof was read, it returns "undefined"
#: If timeout occurred, it returns "".
#: 
#: Example Use:
#:
#:  my $cmd="echo start ; sleep 3 ; echo middle ; sleep 3 ; echo end |";
#:  my $file;
#:  open (my $pipe, $cmd);
#:  while (defined (my $line = readline_alarmed($pipe,1))) {
#:    if ($line) {$file.= $line;}
#:    else {print "Waiting for finish of: $cmd\n"};
#:  }
#:  print "\nPIPE RESULT:\n$file";


sub readline_alarmed {
  my $pipe = shift;
  my $timeout = shift;

  my $as="alarm clock restart";

  my $line="";
  my $alarm_expired=0;

  no warnings;
  eval {
    local $SIG{ALRM} = sub { $alarm_expired++; die $as};
    alarm 1;  #schedule alarm for 1 second.
    eval {
      #The eof() function invokes a 1 character read, which blocks if
      #no data, so it doesn't do any good to use it, and might create
      #a race condition if I did.
      $line=<$pipe> or die "nothing read";
    };
    alarm 0;
  };
#    print "$@\n";  #The @ variable ain't working as described in manual.
  alarm 0;
#    if ($@ && $@ =~ /$as/) {print "here\n";} #doesn't work.
#    die if $@ && $@ !~ /$as/;                #doesn't work.

  unless ( $alarm_expired || $line || !defined($line) ) {
    my $err = 
"Possible Programming error in readline_alarmed.
We exited the readline without a timer expiration, a line of data or an EOF
\$!: $!
\$@: $@
";
    die $err;
  }

  return $line;
}

return 1;



##------------------------------------------------------------------------
#                        RANDOM Number routines
##------------------------------------------------------------------------

sub coin_flip {return int(rand 2);}


sub get_random_list_entry {
  my @list=();
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}
  return $list[int (rand scalar @list)];
}



sub get_random_uint {
  my $lo = shift;
  my $hi = shift;

  my $ret;

  $lo = int($lo);
  $hi = int($hi);

  if ($lo != $hi) {
    if ($lo>$hi) {($lo,$hi) = ($hi,$lo);}
    $ret = $lo + int(rand (($hi+1)-$lo));
  } else {
    $ret = $lo
  }

  return $ret;
}


sub random_true_100 {
  if    ($_[0]==0)   {return 0;}
  elsif ($_[0]>=100) {return 1;}
  return (get_random_uint(0,99)<$_[0]);
}


#: get_weighted_random_uint
#: ------------------------
#: $_[0] : array or reference to array of weighting triplets.
#:         a weighting triplet is three numbers:
#:           1. weighting factor
#:           2. low value
#:           3: high value.
#:         The weighting factors are summed, and probability of
#:         range is proportional to weighting factor/sum of weighting factors.

sub get_weighted_random_uint {
  my @list=();
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}

  my $ret=0;

  if (@list % 3 != 0) {
    die "
programming error: get_weighted_random_uint called with a list that
is not a multiple of three.
";
  }

  my $acc=0;
  for (my $i=0 ; $i<@list ; $i+=3) {
    $list[$i]+=$acc;
    $acc=$list[$i];
    
  }

#  print ("NEWLIST: (@list)\n");
  if (0==$acc) {$acc=1}

  my $sel = get_random_uint(0,$acc-1 );
#  print ("SEL: $sel\n");
  for (my $i=0 ; $i<@list ; $i+=3) {
    if ($sel < $list[$i]) {
      $ret = get_random_uint($list[$i+1],$list[$i+2]);
      last;
    }
  }

  return $ret;
}





#: get_weighted_random_list_entry
#: ------------------------------
#: $_[0] : array or reference to array of weighting pairs.
#:         a weighting triplet is three numbers:
#:           1. weighting factor
#:           2. value
#:         The weighting factors are summed, and probability of
#:         a value is proportional to weighting factor/sum of 
#:         weighting factors.

sub get_weighted_random_list_entry {
  my @list=();
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}

  my $ret=0;

  if (@list % 2 != 0) {
    die "
programming error: get_weighted_random_list_entry called with a list that
is not a multiple of two.
";
  }

  my $acc=0;
  for (my $i=0 ; $i<@list ; $i+=2) {
    $list[$i]+=$acc;
    $acc=$list[$i];
    
  }

#  print ("NEWLIST: (@list)\n");
  if (0==$acc) {$acc=1}

  my $sel = get_random_uint(0,$acc-1 );
#  print ("SEL: $sel\n");
  for (my $i=0 ; $i<@list ; $i+=2) {
    if ($sel < $list[$i]) {
      $ret = $list[$i+1];
      last;
    }
  }

  return $ret;
}




#: get_random_list_or_range
#: ------------------------
#: IN:  $_[0]: "L" for list or "R" for range, "WR" for weighted range.
#:             "WL" for Weighted List.  If none of above, just return
#:             the value.
#:      $_[1..] The list or the range.
#:
#: This routine takes an "L" followed by a list or an "R" followed by a
#: range and randomly picks either a value from the list or a number
#: within the range.  The range includes the boundary numbers.
#:
#:

sub get_random_list_or_range {
  my @list=("N");
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}
  
  my $ret;

  my $rule = shift @list;

  if    ("L" eq "\U$rule")  { $ret = get_random_list_entry         (@list)}
  elsif ("R" eq "\U$rule")  { $ret = get_random_uint               (@list)}
  elsif ("WR" eq "\U$rule") { $ret = get_weighted_random_uint      (@list)}
  elsif ("WL" eq "\U$rule") { $ret = get_weighted_random_list_entry(@list)}
  else                      { $ret = $rule}

  return $ret;
}

##------------------------------------------------------------------------
#                          list processing
##------------------------------------------------------------------------

#: find_in_list
#: -----------
#: IN: $_[0] : $value to search list for.
#:     $_[1] : Array or reference to array to search.
#: OUT: RET:   -1 if not in list, else index of $value within the list.
#: Warning: not quite perfect. If list is a mix of strings and numbers,
#:          and $value=0, you'll match the first string in list.

sub find_in_list {
  my $value = shift;
  my @list;
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}


#  print ("Value: $value, list: (@list)\n");

  my $ret=-1;   #assume no match

  my $type = is_number($value);

  for (my $ix=0 ; $ix<@list ; $ix++) {
    no warnings;
    my $match;
    if ($type) { $match = ($value == $list[$ix])}
    else       { $match = ($value eq $list[$ix])}
    if ($match) {$ret=$ix ; last};
  }

  return $ret;
}


#: in_list
#: -----------
#: IN: $_[0] : $value to search list for.
#:     $_[1] : Array or reference to array to search.
#: OUT: RET:   1 if in list, 0 if not
sub in_list {
  return (find_in_list(@_) >=0);
}



#: any_in_list
#: -----------
#: IN: $_[0] : reference to array of values to search for (needles)
#:     $_[1] : Array or reference to array to search. (haystack)
#: OUT: RET:   1 if in any of needles are in the haystack, 0 if not
sub any_in_list {
  my $needles=shift;


  my $ret=0;
  foreach my $needle (@$needles) {
    $ret=in_list($needle,@_);
#    printf "  %s:%u, \n", $needle,$ret;
    if ($ret) {last;}
  }

  return $ret;
}

##------------------------------------------------------------------------
#                          hash_* functions.
##------------------------------------------------------------------------
sub hash_keyval_filearray {
  my $aref=$_[0];

  my $pat="";
  if ($#_>=1) {$pat=$_[1];}
  if (!$pat) {$pat='\s*(.+?)[:\s\+\-\=]+(.+)\s*$';} #'

  my $ret={};
  foreach my $line (@$aref) {
    if ($line=~ /$pat/) {
      $ret->{$1}=$2;
    }
  }

  #print indent_str(sprintf_hash($ret),5);
  
  return $ret;
}

sub hash_keyval_filestr {
  my $filestr = $_[0];
  my $pat="";
  if ($#_>=1) {$pat=$_[1];}  

  $filestr.="\n";
  my @lines=split(/\n/,$filestr);
  return hash_keyval_filearray(\@lines,$pat);
}






##------------------------------------------------------------------------
#                          hashN functions.
##------------------------------------------------------------------------

#: find_num_in_list
#: ----------------
#: Search a numerical list for a number, return index of first match
#: or undefined in number is not in list.
#: 

sub find_num_in_list {
  my $num = shift;
  my @list;
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}

  my $ret;    #set to undefined in case not in list.

  my $ix=0;
  while ( $ix<=$#list and $num != $list[$ix] ) { $ix++}
  if ($ix <= $#list) {$ret=$ix}
  return $ret;
}


#: sort_numlist
#: ------------
#: same interface as sort, but sorts lists numerically instead of ASCII
#: order.  Also, you can pass in either array, or reference to array.
#: 

sub sort_numlist {
  my @ret = @_;
  if    (not        ref $_[0]) {@ret = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@ret = @{$_[0]}}

  sub numerically { $a <=> $b};
  @ret= sort numerically @ret;
  return @ret;
}


#: hashN_key_to_numlist
#: --------------------
#: Take a hashkey and the main key of the hash key,
#: and return a list of the N extensions of the main key.
#: IN: $_[0] = reference to a hashN
#:     $_[1] = $mainkey, without the trailing number.

sub hashN_key_to_numlist {
  my $hashN   = $_[0];
  my $mainkey = $_[1];

  my @ret=();

  if (defined $hashN->{$mainkey})   {push @ret,  0 }
  foreach my $key (keys %$hashN) {
    if ($key =~ /^$mainkey(\d+)$/)  {push @ret, $1 }
  }
  @ret=sort_numlist(@ret);
  return wantarray ? @ret : \@ret;
}

#: hashN_swap
#: -------------------
#: Take a reference to a hashN, and a number and return a new hashN
#: witht the mainkeys swapped with the Nkeys.
#: IN:  $_[0]: hashN reference
#: IN:  $_[1]: N-value
#: OUT: RET  : copy of hashN with N-keys swapped with mainkeys.

sub hashN_swap {
  my $hashN  = $_[0];
  my $N      = $_[1];

  my $ret;
  %$ret= %$hashN;                         #copy the hashN
  if (0==$N) {goto out}                   #No need to swap.

  foreach my $key (keys %$hashN) {
    if ($key !~ /^(.*\D)(\d+)$/) {next};  #Ignore keys that don't end in nums
    if ($2 != $N)                {next};  #Ignore keys for different N's
    my $mainkey=$1;
    if (not defined $hashN->{$mainkey}) {next} #Ignore if no unnumbered mainkey

    $ret->{$mainkey} = $hashN->{$key};      #Put N-key val into mainkey val.
    $ret->{$key}     = $hashN->{$mainkey};  #Save mainkey val in N-key val.
  }
  
 out:
  return $ret;
}

#: hashN_next
#: -------------------
#: Perform the next hashN swap for the next value of N.  Return undefined
#: if last N.
#: IN:  $_[0]: hashN reference
#: IN:  $_[1]: mainkey 
#: IN:  $_[2]: reference to current N-value.
#: OUT: RET  : undefined if cur N-value is last N-value.
#:             else reference to copy of hashN with new N-keys
#:             swapped with main keys.
#:      $_[2]: updated to new N-value if RET is not undefined.


sub hashN_next {
  my $hashN   = $_[0];
  my $mainkey = $_[1];
  my $cur_N_R = $_[2];

  my $cur_N   = $$cur_N_R;

  my $ret;  #undefined in case null list or end of list.

  my @list = hashN_key_to_numlist($hashN,$mainkey);
  if (0==@list) {goto out}
  if ($cur_N < 0) {
    $cur_N = $list[0]
  } else {
    my $ix = find_num_in_list($cur_N,\@list);
    if (not defined $ix) {goto out;}
    if ($ix==$#list)     {goto out;}
    $cur_N = $list[$ix+1];
  }

  $ret =  hashN_swap($hashN,$cur_N);    #swap the hash.
  $$cur_N_R = $cur_N;                   #update cur_N for next call

 out:
  return $ret;
}



##------------------------------------------------------------------------
#    defeq, functions to avoid warning messages.
##------------------------------------------------------------------------

sub defeq    { return (defined $_[0] and $_[0] eq $_[1]) }
sub defeqnum { return (defined $_[0] and $_[0] == $_[1]) }


#: is_in_hash
#: ----------
#: Checks if a given key exists in the hash and if it is defined.
#: In addition, it can also optionally check the type of the value.
#: IN: $_[0] : hash reference
#:     $_[1] : key string.
#:     $_[2] : optional type specifier for further type checking.
#:             Currently supported types:
#:             "hd"  : hex or decimal integer.
#:
sub is_in_hash {
  my $href  = $_[0];
  my $key   = $_[1];
  my $type  = "";
  if ($#_>=2) {$type=$_[2]}

  my $ret = 0;  #assume false
  unless (exists  $href->{$key})                    {goto out}
  unless (defined $href->{$key})                    {goto out}
  if ($type eq "dx") {  #Must be decimal or strict hex number.
    my $dummy;
    unless (dx2n($href->{$key},\$dummy))            {goto out}
  } elsif ($type eq "x") {  #Must be strict hex number.
    my $dummy;
    unless (x2n($href->{$key},\$dummy))            {goto out}
  }
  
  $ret = 1;  #It passed all the tests, so it must be true.


  
 out:
  return $ret;

}


##------------------------------------------------------------------------
#                        Output stuff
##------------------------------------------------------------------------
sub indent_str {
    my @in = split (/\n/,$_[0]);
    my $indent_len = $_[1];

    my $ret="";
    my $indent = sprintf ('%'.$indent_len.'s'," ");

    @in = map {$indent.$_} @in;
    $ret = join "\n",@in;
    #join doesn't put newline at end of string, so restore it if it had one.
    if ( substr($_[0],-1,1) eq "\n") { $ret.="\n"}
    return $ret;
}



sub mark_str_start {
    my @in = split (/\n/,$_[0]);
    my $mark = $_[1];

    my $ret="";

    @in = map {$mark.$_} @in;
    $ret = join "\n",@in;
    #join doesn't put newline at end of string, so restore it if it had one.
    if ( substr($_[0],-1,1) eq "\n") { $ret.="\n"}
    return $ret;
}



sub center_str {
  my @in = split (/\n/,$_[0]);
  my $width = $_[1];
  
  my $ret="";
  my @out=();
  foreach my $line (@in) {
    if ($width > length($line)) {
      my $indent_len = int(($width - length($line))/2);
      push (@out,indent_str($line,$indent_len));
    } else {
      push (@out,$line);
    }
  }

  $ret = join "\n",@out;
  if ( substr($_[0],-1,1) eq "\n") { $ret.="\n"}
  return $ret;
}

#:spaces_to_tabs
#:--------------
#:Converts a string to substitute tabs for spaces
#: This routine not complete, as it cannot handle an input
#: string that has tabs in it already.

sub spaces_to_tabs {
  my $s=shift;
  my $tab_width=shift;

  my $ret="";
  my $len=length $s;
  my $col=-1;
  my $col_cnt=0;

  for (my $i=0 ; $i<$len; ++$i) {
    my $c=substr($s,$i,1);
    $col++;
#    print "C: |$c|\n";
    if ($c eq " ") {
      $col_cnt++;
      next;
    }
    if ($col_cnt>0) {
      my $cur_col=$col-$col_cnt;
#      print "CUR_COL: $col minus $col_cnt = $cur_col\n";
      $col_cnt=0;
      while ($cur_col<$col) {
	my $next_tabstop=$cur_col+($tab_width-($cur_col % $tab_width));
#	print "NEXT: $next_tabstop\n";
	if ($next_tabstop>$col) {
	  while ($cur_col<$col) {
	    $ret.=" ";
	    $cur_col++;
	  }
	}
	elsif (1==$next_tabstop-$cur_col) {
	  $ret.=" ";
	  $cur_col++;
	}
	else {
	  $ret.="\t";
	  $cur_col=$next_tabstop;
	}
      }
    }
    $ret.=$c;
    if ($c eq "\n") {$col=-1;$col_cnt=0;}
  }


  return $ret;

}


#:spr_repeated_str
#:---------
#:Concatenate a string repeatedly. Useful for printing lines
#:of a desired length.
#:IN: $_[0] : $atom to repeatedly concatenate.
#:    $_[1] : $rpt_cnt:  Number of times to concatenate
#:OUT: RET: concatenated string
sub spr_repeated_str {
  my $atom=shift;
  my $rpt_cnt=shift;

  my $ret="";
  foreach (my $i=0 ; $i<$rpt_cnt ; ++$i) {
    $ret.=$atom;
  }
  return $ret;
}


#:columnize
#:---------
#:Converts a list or array reference into a multiline string consisting
#:of columns.  Width of columns and number of columns per line can be
#:specified.  elements that don't fit in their columns will be chopped off.
#:Columns are left justified.
#:IN: $_[0] : Number of columns.
#:    $_[1] : Width of columns
#:    $_[2+] : Either array reference or a list of array elements.
#:OUT: RET: string of columnized array.

sub columnize {
  my $cols     = shift;
  my $col_size = shift;
  my @list=();
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}

  my $ret = "";

  my $col=0;
  for (my $i = 0 ; $i < @list ; $i++) {
    my $fmtstr = '%'."-$col_size.$col_size".'s';
    $ret .= sprintf ($fmtstr,$list[$i]);
    $col++;
    if ($col == $cols) {
      $ret.="\n";
      $col=0;
    }
  }
  return $ret;
}





sub length_last_line {
  my $str=shift;
  my $len;

  $len=0;
  if ($str &&  substr($str,-1,1) ne "\n") {
    my @vals=split(/\n/,$str);
    $len = length $vals[-1];
  }

  return $len;
}



#:tab_length
#:----------
#:Length a string will be after tab expansion.  Assumes string
#:starts in column 0.  Default is tabs are every 8 spaces.

sub tab_length {
  my $s=shift;
  my $tab_width = ($#_>=0) ? shift : 8;
  my $pos=0;
  my $c;

  for (my $i=0 ; $i<length($s) ; ++$i) {
    $c=substr($s,$i,1);
    if ($c eq "\n") {
      last;
    }
    elsif ($c eq "\t") {
      $pos+=8-$pos%8;
    } elsif ($c eq "\b") {
      if ($pos>0) {$pos--;}
    } else {
      $pos++;
    }
  }

  return $pos;
}


sub word_wrap_str {
    my @words = split (" ",$_[0]);
    my $lineLen=80;
    if ($#_>=1) {$lineLen = $_[1];}
    my $indent=0;
    if ($#_>=2) {$indent = $_[2];}

    my $indent_str="";
    if ($indent>0) {$indent_str=sprintf("%*s",$indent," ");}

    my $ret="";
    foreach my $word (@words) {
      if (not $ret) {
	$ret.=$indent_str.$word;
      }elsif (length_last_line($ret) + length($word) + 1 >=$lineLen) {
	$ret.="\n".$indent_str.$word;
      } else {
	$ret.=" ".$word;
      }
    }
    $ret.="\n";


    return $ret;
}


#:sprintf_hash
#:IN:  A simple hash in which value is a scalar.
#:OUT: A sring displaying the hash keys and values in alphabetically 
#:sorted order

sub sprintf_hash {
  my $href = shift;
  my $ret  = "";
  my $fmt  ="%-20s : %s\n";
  
  $ret.= sprintf ($fmt,"key","value");
  $ret.= sprintf ($fmt,"--------------------","--------------------");
  foreach my $key (sort keys %$href) {
    if (defined $href->{$key}) {
      $ret.=sprintf ($fmt,"|".$key."|",$href->{$key});
    } else {
      $ret.=sprintf ($fmt,$key,"<undefined>");
    }
  }
  $ret.="\n";
  return $ret;
}

#:sprintf_table
#:------------
#: Sort of like sprintf, but reuses same format line to
#: print multiple lines
#: IN: $_[0] : $fmt : conventional sprint format string.  It should
#:             represent a line in the table, and should end with \n.
#:     $_[1] : $cols : Number of fields in the format string.
#:     $_[2] : Array of data.  This length of array should be a 
#:             multiple of $cols, and data types must match the
#:             format string.
#: OUT: ret  : Returns a string consiting of @array/$col lines,
#:             each printed using sprintf($fmt,...);


sub sprintf_table {
  my $fmt      = shift;
  my $cols     = shift;
  my @list=();
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}

  my $ret = "";

  my $col=0;
  my @line_list=();
  for (my $i = 0 ; $i < @list ; $i++) {
    push(@line_list,$list[$i]);
    $col++;
    if ($col == $cols) {
      #printf ("line_list: (@line_list)\n");
      $ret .= sprintf ($fmt,@line_list);
      $col=0;
      @line_list=();
    }
  }


  return $ret;
}


#: end_with_newline
#: ----------------
#: Add a new line to end of a string if it doesn't already end  with
#: a newline.
sub end_with_newline {
  my $aref = ref $_[0];
#  prw ("REF: $aref\n");
  if    (not        ref $_[0]) {
    if (substr($_[0],-1,1) ne "\n") {
      $_[0] .= "\n";
    }
  } elsif ("SCALAR" eq ref $_[0]) {
#    print "here: ${$_[0]}";
    if (substr(${$_[0]},-1,1) ne "\n") {
      ${$_[0]} .= "\n";
    }
  }
}


##------------------------------------------------------------------------
#                        Conversion Functions.
##------------------------------------------------------------------------

#: x2n: Check if input string is strict hexadecimal number.
#:       A strict hex number requires a leading 0x or 0X.
#: IN:   $s: String to check and convert.
#:       $vref: optional reference to store converted value into.
#: OUT:  Return 1 if strict hex, 0 if not.
#:       If $vreg is present, but converted value into it.
sub x2n {
  my $s    = $_[0];
  my $dummy;
  my $vref=\$dummy;
  if (@_>1) {$vref = $_[1]}
  my $ret=0;  #assume not okay.

  if ( $ret=($s =~ /^\s*(?:0x|0X)([\da-fA-F]+)/)) {
    $$vref = hex($1);
  }

  return $ret;
}


#:dh2n:  Check if input string is decimal or hexadecimal number.
#:IN:      $s   : String to check and convert.
#:         $vref: Optional Reference to variable to put conversion value.
#:OUT:     Return TRUE if converted, FALSE if not a number
#:         Put converted variable into $vref, or zero if convert failure.
#:         
sub dh2n {
  my $s    = $_[0];
  my $dummy;
  my $vref=\$dummy;
  if (@_>1) {$vref = $_[1]}
  my $ret=1;


#  DBGP "s: |$s|\n";
  if  ($s =~ /^\s*([\d]+)\s*$/) {
    $$vref = $1;
#    DBGP ("DEC: $s, $$vref\n");
  }elsif ( ($s =~ /^\s*(?:0x|0X)?([\da-fA-F]+)/)) {
    $$vref = hex($1);
#    DBGP ("HEX: |$1|, $$vref\n");
  } else {
#   DBGP "bad\n";
    $ret = 0;
    $$vref=0;
  }

  return $ret;
}


#:dx2n:  Check if input string is decimal or hexadecimal number
#        with a leading "0x" or "0X".  This is a stricter version
#        of dh2n that allows you to first check for a number, and
#        if failure, then check for a word like "abc" that would
#        otherwise qualify as a hex number.
#:IN:      $s   : String to check and convert.
#:         $vref: Optional reference to variable to put conversion value.
#:OUT:     Return TRUE if converted, FALSE if not a number
#:         Put converted variable into $vref, or zero if convert failure.
#:         
sub dx2n {
  my $s    = $_[0];
  my $dummy;
  my $vref=\$dummy;
  if (@_>1) {$vref = $_[1]}

  my $ret=1;


#  DBGP "s: |$s|\n";
  if  ($s =~ /^\s*([\d]+)\s*$/) {
    $$vref = $1;
#    DBGP ("DEC: $s, $$vref\n");
  }elsif ( ($s =~ /^\s*(?:0x|0X)([\da-fA-F]+)/)) {
    $$vref = hex($1);
#    DBGP ("HEX: |$1|, $$vref\n");
  } else {
#   DBGP "bad\n";
    $ret = 0;
    $$vref=0;
  }

  return $ret;
}



#:dhr2n: Similar to dh2num, also accepts request for random numbers.
#:IN:      $s   : String to check and convert.
#:         $vref: optional Reference to variable to put conversion value.
#:OUT:     Return TRUE if converted, FALSE if not a number
#:         Put converted variable into $vref, or zero if convert failure.
#:
sub dhr2n {
  my $s    = $_[0];
  my $dummy;
  my $vref=\$dummy;
  if (@_>1) {$vref = $_[1]}

  my $ret=0;  # assume failure.
  my $random_regex=qr{^\s*(?:rand|random)\s*\(\s*
                      ( (?:0x|0X)?[\da-fA-F]+)
                      \s*\,\s*
                      ( (?:0x|0X)?[\da-fA-F]+)
                      \s*\)\s*$
                     }x;

  $s = "\L$s"; #convert to lower case
  if (dh2n($s,$vref)) {
#    DBGP ("\ngere: $$vref\n");    
    $ret =1;
  } elsif ($s =~ $random_regex) { #check if a random number request
#    DBGP ("1: $1, 2: $2\n");
    $$vref = get_random_uint($1,$2);
#    DBGP ("\nTHere: $$vref\n");

    $ret=1;
  } else {
#    DBGP "no match\n";
    $$vref = 0;
    $ret=0;
  }

  return $ret;
}



#:f2n:  Check if input string is floating point number.
#:IN:      $s   : String to check and convert.
#:         $vref: Optional Reference to variable to put conversion value.
#:OUT:     Return TRUE if converted, FALSE if not a number
#:         Put converted variable into $vref, or zero if convert failure.
#:         
sub f2n {
  my $s    = $_[0];
  my $dummy;
  my $vref=\$dummy;
  if (@_>1) {$vref = $_[1]}
  my $ret=1;


  if  ($s =~ /^\s*([\d]+\.*[\d]*)\s*$/) {
    $$vref = $1;
  }elsif ($s =~ /^\s*(\.[\d]+)\s*$/) {
    $$vref = $1;
  } else {
    $ret = 0;
    $$vref=0;
  }
  
  return $ret;
}


#:is_ipv4: Take an ipv4 dotted decimal string, check it, and if
#:             is a valid IP address.  Also, optionally convert to
#:             host order 32-bit integer.
#:IN: $_[0]: $ip_addr
#:    $_[1]: optional int reference to store ip address into.
#:OUT: return 2-tuple: true if address, else return false
sub is_ipv4 {
  my $ip = shift;
  my $dummy;
  my $sref=\$dummy;
  if (@_>0) {$sref = shift;}
  my $ret=0;
  my $acc=0;

  if ($ip =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/) {
    if ( $1<256 and $2<256 and $3<256 and $4<256) {
      $$sref = ($1 << 24) | ($2 <<16) | ($3<<8) | $4;
      $ret=1;
    }
  }

  return $ret;
}



sub is_ipv6 {
  my $ip = shift;
  my $dummy;
  my $sref=\$dummy;
  if (@_>0) {$sref = shift;}
  my $ret=0;
  my $acc=0;


  my $hexb='([\dA-Fa-f]){1,4}';
  my $colons='[:]{1,2}';
  my $regex='^(::)?'.$hexb.'('.$colons.$hexb.'){0,7}(::)?$';
  print "REGEX: |$regex|\n";

  if ($ip =~ /$regex/       and
      $ip =~ /:/            and  #at leaset one colon
      $ip !~ /(::).*(::)/   and  #no more than one elision
      $ip !~ /(:::)/        and  #cannot have 3 or more colons in a row.

      ($ip =~ /::/ or $ip=~/$hexb(:$hexb){7,7}/)    #one elision or 8 hexbytes

     ) {
    $ret=1;
  }

  return $ret;
}
#' ; fix editor display problem


#:ipv6str_to_A: input is a valid abbreviated ipv6 string
# output is either 16-byte array of the address (or array reference)

sub ipv6str_to_A {
  my $ipv6str=shift;
  my $ret=[];
  my $tail=[];
  my $A=$ret;

  my $acc=0;

  my $len=length $ipv6str;
  for (my $i=0; $i<$len ; ++$i) {
    my $c=substr($ipv6str,$i,1);
    my $nc="";
    if ($i+1 < $len) {$nc=substr($ipv6str,$i+1,1)}

    if ($c eq ":") {
      if ($nc eq ":") {$A=$tail;}
    } elsif ($c =~ /^[0-9a-fA-F]$/) {
      $acc=$acc<<4 | hex($c);

      if ($nc eq ":" or $nc eq "") {
	push @$A,(($acc>>8) & 0xFF);
	push @$A,($acc & 0xFF);
	$acc=0;
      }
    } else {
      die "ipv6str_to_A: bad character $c\n";
    }
  }


  my $zeros=16-(scalar @$ret + scalar @$tail);
  while ($zeros) {
    push @$ret,(0);
    --$zeros;
  }

  push @$ret,(@$tail);
  if (scalar @$ret != 16) {die "ipv6str not 16 bytes: $ipv6str\n";}

  return wantarray ? @$ret : $ret;
}

sub spr_expanded_ipv6_from_A {
  my @A;
  if    (not        ref $_[0]) {@A = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@A = @{$_[0]}}

  my $ret="";

  if (scalar @A !=16) {die "spr_expanded_ipv6_from_A is not 16 bytes"}
  for (my $i=0 ; $i<16 ; $i+=2) {
    $ret.=sprintf "%02x%02x",$A[$i],$A[$i+1];
    if ($i<14) {$ret.=":";}
  }

  return $ret;
}



#:prs_arg:  Get's argument from argv style list.
#:          See example.pl's cla_parser subroutine for examples of use.
#:IN: $_[0]:  $val_R: Reference to where to write the value.
#:    $_[1]:  $ARGV_R: Reference to ARGV type array.
#:    $_[2]:  $type: optional argument type specifier:
#:            basic types:
#:               "h"  : hex number, no checking.
#:               "x" : strict hex number (must beging with 0x).
#:               "dh" : decimal or hex number, relaxed checking.
#:               "dx" : decimal or hex number, strict checking.
#:               "ipv4" : dotted decimal ipv4 address.
#:               "ip" : ipv4 or ipv6
#:
#:            extended types:  You can extend some of the above types
#:                             by adding these modifiers:
#:               " range lo hi" : range that number is restricted to.
#:               " commas"      : strip commas out of argument before parsing
#:    $_[3]:  $bada_R: optional reference, which will get a copy of an
#:            illegal argument.
#:    $_[4]:  $argix: optional argument.  If not present, argument to
#:            parse is at @ARGV_R[1], else it is at @ARGV_R[$argix]
#:OUT: If argument is present and correct type:
#:        RET = 1.
#:        $$val_R = parsed value of argument.
#:        if ($argix>0) $$au_R+=1;
#:     else if argument missing or invalid:
#:        RET = 0;
#:        $$bada_R=copy of argument if argument was invalid and this reference
#:                 was present in input list.


sub prs_arg {
  my $val_R    = shift;
  my $ARGV_R   = shift;
  my $type;
  if (@_>0) {$type = shift;}
  my $bada_R;
  if (@_>0) {$bada_R    = shift;}
  my $argix=1;
  if (@_>0) {$argix=shift;}

  my $ret=0;
  my $arg;
  my $val;
  my $bada_flag=0;


  if ($argix > $#$ARGV_R) {goto out;}

  $arg=$$ARGV_R[$argix];
  if ((defined $type) and $type =~ /commas/) {
    $arg=~ s/,//g;
  }

  if (not defined $type) {
    $val = $arg;
    $ret=1;
  } elsif ($type =~ /^h(\s|$)/) {
    $val = hex($arg);
    $ret=1;
  } elsif ($type =~ /^x(\s|$)/) {
    my $num;
    if (x2n($arg,\$num))  {$val = $num; $ret=1;}
    else                  {$bada_flag=1}
  } elsif ($type =~ /^dh(\s|$)/) {
    my $num;
    if (dh2n($arg,\$num)) {$val = $num; $ret=1;}
    else                  {$bada_flag=1}
  } elsif ($type =~ /^dx(\s|$)/) {
    my $num;
    if (dx2n($arg,\$num)) {$val = $num; $ret=1;}
    else                  {$bada_flag=1}
  } elsif ($type =~ /^ipv4(\s|$)/) {
    if (is_ipv4($arg))    {$val=$arg; $ret=1;}
    else                  {$bada_flag=1}
  } elsif ($type =~ /^ip(\s|$)/) {
    if    (is_ipv4($arg) or is_ipv6($arg))    {$val=$arg; $ret=1;}
    else                                      {$bada_flag=1}
  } elsif ($type =~ /^efile(\s|$)/) {
    if    (-e $arg)        {$val=$arg; $ret=1;}
    else                   {$bada_flag=1}
  }


  if ($ret and (defined $type) and $type =~ /range (\S+) (\S+)/) {
    my ($lo,$hi);
    $bada_flag=1;  #assume bad.
    $ret = 0;      #assume bad
    if (dx2n($1,\$lo) and dx2n($2,\$hi)) {
      if ($lo>$hi) {($lo,$hi) = ($hi,$lo);}
      if ($val>=$lo and $val<=$hi) {
	$bada_flag=0;
	$ret=1;
      }
    }
  }


  if ($ret) {
    $$val_R=$val;
    if ($argix>0) {shift @$ARGV_R}
  }

  if ($bada_flag and defined $bada_R) {
    $$bada_R = $arg;
  }


 out:
#  print "ret: $ret\n";
  return $ret;

}

##------------------------------------------------------------------------
#                        bit manipulation
##------------------------------------------------------------------------


#:bit_get : extract a range of bits from a 32-bit integer.
#: IN:  $val to get bits from.
#:      $hi: hightest bit to extract.
#:      $lo: lowest bit to extract
#:      (note: It's okay to reverse $lo and $hi, code will adjust
#: OUT: bits $lo to $hi of $val, right shifted.
sub bit_get {
  my ($val,$hi,$lo,$temp,$bitcnt,$mask);
  $val = $_[0];
  $hi  = $_[1];
  $lo  = $_[2];

  if ($lo > $hi) { $temp = $lo; $lo = $hi ; $hi = $temp;}
  $bitcnt = ($hi - $lo) +1;
  if (32==$bitcnt) {
    $mask = 0xFFFFFFFF;
  } else {
    $mask = (1 << $bitcnt) -1;
  }

  return (($val>>$lo) & $mask);
}


#:build_mask_from_hi_lo : build an AND mask from hi and lo values.
#: IN:  $hi: high bit position,
#:      $lo: low bit postion
#: OUT: 32-bit AND mask
#:
sub build_mask_from_hi_lo { 
  my $hi=shift;
  my $lo=shift;

  my $mask=0;
  if ($lo > $hi) { ($hi,$lo)= ($lo,$hi);}
  ($lo<32 and $lo>=0 and $hi<32 and $hi>=0) or 
    die "Coding error in build_mask_from_hi_lo: $hi, $lo\n";

  my $size=$hi-$lo+1;
  if    ($size==32) {$mask=0xFFFF_FFFF;}
  elsif ($size==31) {$mask=0x7FFF_FFFF << $lo;}
  else {
    $mask= ((1<<$size)-1) << $lo;
  }

  return $mask;
}


#:big_hex_to_BA : convert big hex number to a bit array
#: IN:  $hs hex string of a hexadecimal number
#: OUT: $BA bit array of $val.
sub big_hex_to_BA {
  my $hs=shift;
  my $BA=[];

  my $s=$hs;
  if ($hs =~ /^0x(.*)/i) {
    $s=$1;
  }

  for (my $i=length($s)-1 ; $i>=0 ; --$i) {
    my $nib=hex(substr($s,$i,1));
    push (@$BA,$nib&1);
    push (@$BA,($nib>>1)&1);
    push (@$BA,($nib>>2)&1);
    push (@$BA,($nib>>3)&1);
  }

  #discard leading zeros
  while ($#$BA>0 && $BA->[-1]==0) {pop (@$BA)}

  return $BA;
}


#:BA_to_big_hex : inverse of big_hex_to_BA
#: IN:  bit array
#: OUT: hex string of BA
sub BA_to_big_hex {
  my $BA=shift;
  my $ret="";

  #make a copy so we can discard leading zeros.
  my $WBA=[@$BA]; 
  while ($#$WBA>0 && $WBA->[-1]==0) {pop (@$WBA)}

  for (my $i=0 ; $i<scalar @$WBA; $i+=4) {
    my $nib=0;
    my $j=0;
    while ($i+$j<scalar @$WBA and $j<4) {
      $nib|=$WBA->[$i+$j]<<$j;
      $j++;
    }
    $ret=sprintf("%x",$nib).$ret;
  }

  if ($ret eq "") {$ret="0";}

  return $ret;
}


#:diff_BA : compare to BA's to see if equal  return true if same
#:          size and values, else return false.
#: IN:  BA1, BA2, references to two bit arrays.
#: OUT: 1 if same size and equal, else 0
sub diff_BA {
  my $BA1=shift;
  my $BA2=shift;
  my $ret=1;  #assume same

  if (scalar @$BA1 != scalar @$BA2) {
    $ret=0;
  } else {
    for (my $i=0 ; $i<scalar @$BA1 ; ++$i) {
      if ($BA1->[$i] != $BA2->[$i]) {
	$ret=0; last;
      }
    }
  }
  
  return $ret;
}


##------------------------------------------------------------------------
#                        endianess conversion
##------------------------------------------------------------------------

#:endian_reverse_32: Reverse endianess of a 32-bit number.
#:IN: $_[0] = 32-bit integer value.
#:RET       = endianess swapped value.
sub endian_reverse_32 {
  my $val = $_[0];
  my $ret = 0;

  $ret  = (  $val      & 0xFF) <<24;
  $ret |= ( ($val>>8)  & 0xFF) <<16;
  $ret |= ( ($val>>16) & 0xFF) <<8 ;
  $ret |= ( ($val>>24) & 0xFF)     ;

  return $ret;
}


#:swizzle:   swizzle entries in an array of bytes.
#:IN: $_[0]: $A: reference to array to swizzle, typically an array of bytes.
#:    $_[1]: $lo: optional index into where to start swizzle.
#:    $_[2]: $hi: optional index into where to end swizzle.
sub swizzle {
  my $A = shift;
  my $lo=0;
  if ($#_>=0) {$lo=shift;}
  my $hi=$#$A;
  if ($#_>=0) {$hi=shift;}

  if ($lo>$hi) { ($lo,$hi)=($hi,$lo);}

  while ($lo<$hi) {
    ($A->[$lo],$A->[$hi]) = ($A->[$hi],$A->[$lo]);
    ++$lo;
    --$hi;
  }
}

##------------------------------------------------------------------------
#                        syctl access functions
##------------------------------------------------------------------------

#:sysctl_read
#:-----------
#: IN:   $_[0] name of sysctl to read.
#: OUT:  undefined if error, else value read.

#Attempts to read a sysctl.  If error, returns undefined.
sub sysctl_read {
  my $sysctl = $_[0];
  my $ret;

  my $line=`sysctl $sysctl`;
  chomp $line;
  if ($line =~ /.* = (.*)/) {
    $ret = $1;
  }

  return $ret;
}

#:sysctl_write
#:------------
#: IN:   $_[0] name of sysctl to write
#:       $_[1] value to write, in form of string.
#: OUT: Ret:   undefined if write error, else value written.


#Attempts to read a sysctl.  If error, returns undefined.
sub sysctl_write {
  my $sysctl = $_[0];
  my $val    = $_[1];
  my $ret;

  my $cmd = 'sysctl -w '.$sysctl.'='.$val;
  my $line=`$cmd`;
  chomp $line;
  if ($line =~ /.* = (.*)/) {
    $ret = $1;
  }

  return $ret;
}



#:chompr
#:------
#:chomp for either Windows or Linux.
#:Will remove \n or \r\n at end of line.
#: Warning: only works for strings.
sub chomprn {

  chomp $_[0];  #remove the \n
  if ( substr($_[0],-1,1) eq "\r") { chop $_[0]}

}

#:chomp_outer_space
#:-----------------
#:strip leading and trailing white space, but leave any intermediate
#:white space alone
sub chomp_outer_space {
  $_[0] =~ s/^\s*(.*\S)\s*$/$1/;
}

#:chomp_trailing_space
#:-----------------
#:strip trailing white space, but leave any leading or intermediate
#:white space alone
sub chomp_trailing_space {
  $_[0] =~ s/\s*$//;
}

#:chomp_allspace
#:-----------------
#:Remove all white space, leading, trailing and interior.
sub chomp_allspace {
  $_[0] =~ s/\s//g;
}


#:canonicalize_space
#:-----------------
#:Remove all white space, leading, trailing space and reduce any
#:interior space to one space.  This routine intended for single line.
sub canonicalize_space {
  $_[0] =~ s/^\s*//;
  $_[0] =~ s/\s*$//;
  $_[0] =~ s/\s+/ /g;
}


#:split_n_strip
#:-----------------
#:split a line into an array, then strip outer white space from
#:each member of arrray, and discard any all white space members.
sub split_n_strip {
  my $splitter=shift;
  my $s       =shift;

  my @words=split($splitter,$s);
  my @ret;
  foreach my $word (@words) {
    chomp_outer_space($word);
    if ($word ne "") {
      push @ret,$word
    }
  }

  return wantarray ? @ret : \@ret; 
}






#: graphics_parse:
#: --------------
#: IN: $_[0]: reference to a string containing name of a command.
#:     $_[1]: graphics switch to look for, typically '-g'
#:     $_[2]: ARGV array.
#: OUT: if the switch -g is not present, $$cmd eq "".
#:      else $$cmd is a rebuilt version of command without the -g switch.
#: RET: ARGV array without the -g switch.
#:
#: This routine is used to determine if a program wants to launch 
#: a graphic version of itself.

sub graphics_parse {
  my $cmd=shift;   #reference to command string.
  my $gswitch=shift;   #reference to command string.
  my (@NEWARGV);

  my $gmode=0;

  for(my $i=0 ; $i<=$#_ ; $i++) {
    if ($_[$i] eq $gswitch) {
      $gmode=1;
    } else {
      @NEWARGV = (@NEWARGV,$_[$i]);
      $$cmd .=" ".$_[$i];
    }
  }

  if (not $gmode) {$$cmd="";}
  
  return @NEWARGV;
}

#: graphics_launch:
#: --------------
#: IN: $_[0]$cmd to launch
#:     $_[1] optional control string to specify attributes of window
#: OUT: launch command in a graphics window in the background.
#:      On Windows, it uses the "cmd"
#:      On all other systems, it uses "xterm".  On unix systems,
#:      this only works if xterm is installed.
#: RET: nothing.

sub graphics_launch {
  my $cmd = shift;
  my $ctl="";
  if ($#_>=0) {$ctl=shift;}
  $ctl.=" "; #make regex easier

  #assume unix


  my @color_tbl = qw{
		     18    1A 1B 1C 1D 1E 1F 
		     29    2B       2E 2F 
		     39 3A          3E 3F 
		     48    4A 4B       4E 4F 
		     58    5A 5B       5E 5F 
		     69 6A 6B          6F 
		    };
  
  
  my $openquote='"';
  my $closequote='"';
  my $shellcmd="";
  my $bgtail=" &";
  my $title=$cmd;
  my $width="80";
  my $len="8";
  
  if ($ctl =~ /width[\s]*(\d+)[\s]/) {
    $width=$1;
  }
  if ($ctl =~ /(?:len|length)[\s]*(\d+)[\s]/) {
    $len=$1;
  }
   


  if ($^O =~ /win/i) {
    $openquote="";
    $closequote="";
    $shellcmd="start ";
    $shellcmd.="\"$title\" " ;
    $shellcmd.="/LOW ";
    $shellcmd.="cmd /C ";
    my $color = $color_tbl[int(rand scalar @color_tbl)];
    $shellcmd.='"'."color $color && ";
    $closequote='"';
  } else {
    my $disp_parms=`host2xtermparms.sh`;
    chomp $disp_parms;
    $openquote="";
    $closequote="";
    $title=~s/[\"]//g;        #intermediate quotes mess up title.
    #print "Title: |$title|\n";
    $shellcmd="xterm -T \"$title\" -geometry $width"."x$len $disp_parms -e ";
  }
  
  $cmd = $shellcmd.$openquote.$cmd.$closequote.$bgtail;
  print $cmd."\n";
  system ("$cmd");
}



#:get_file_stats
#:--------------
#:Get stats for a file and return a 2-level hash with results.
#:IN:  $_[0] : directory name string to prepend to files.  Can be ""
#:     $_[1] : reference to an empty error string.  If no error, this wil
#:             be null on return.
#:     $_[2+]: Array reference or list of files to get stats for.  These
#:             names will be the key to the hash.
#:OUT:  RET:  2-level hash of file names:
#:            See stat function of perl for field names.  For now I'm
#:            only implementing:
#:               $hash->{filename}->{size}
#:               $hash->{filename}->{mode}
#:               $hash->{filename}->{mtime}
sub get_file_stats {
  my $dir = shift;
  my $err = shift; 
  my @list=();
  if    (not        ref $_[0]) {@list = @_    }
  elsif ("ARRAY" eq ref $_[0]) {@list = @{$_[0]}}

  my $sep='/';
  if ($^O =~ /win/) {$sep='\\';}
  my $ret={};

  foreach my $key (@list) {
    my @stats= stat $dir.$sep.$key;
    $ret->{$key}->{mode} = $stats[2];
    $ret->{$key}->{size} = $stats[7];
    $ret->{$key}->{mtime} = $stats[9];

    #how do I know if there was an error?
  }

  return $ret;
}


#:get_dir
#:-------
#:Read a directory
#:IN:  $_[0] : directory name string.
#:               regex /<regex pattern>/ : only return filenames that
#:                      match the <regex pattern>/
#:     $_[2] :   optional reference to an empty error string.  If not present,
#:               then this function will die on an error.
#:OUT:  RET:  If array context, we return just an array of filenames.
#:            If a scalar context, we return a 2 level hash of filenames
#:            with file statistics such as size, file mode, etc.
#

sub get_dir {
  my $dir = shift;
  my $ctl ="";
  my $dummy;
  my $err =\$dummy;
  my $die=0;
  if ($#_>=0) {$ctl=shift;}
  if ($#_>=0) {$err=shift;} else {$die=1;}


  $$err="";  #make sure err string is null in case caller forgot.

  unless (opendir(DH,$dir)) {
    $$err="Error, cannot open the $dir directory because: $!\n";
    goto err_exit;
  }

  my @files=readdir DH;
  closedir DH;
  
  @files=sort @files;   #files aren't noramlly sorted.
  
  
  my $regfs=qr{ 
	       (?:^|\s)   #start of string or space.  Don't capture
	       regex      #literal regex
	       \/         #the forward slash
	       (.+)       #regex expression to capture.
	       \/
	       (?:$|\s)  #we have to put space after $ first to prevent emacs
	      }x;         #going nuts.

  if ($ctl =~ $regfs ) {
    my $regex=$1;
    #print "REGEX: $regex\n";
    my @temp;
    foreach my $file (@files) {
      if ($file =~ /$regex/) {
	push (@temp,$file);
      }
    }
    @files=@temp;
  }


  if (wantarray) {
    return @files;
  }


  my $ret=get_file_stats($dir,$err, @files);
  if (not $$err) {return $ret;}


#error exit
err_exit:
  if ($die) {
    prw $$err;
    exit 1
  }
  return undef;
}



sub get_tree_files {
  my $dir = shift;
  my $ctl ="";
  my $dummy;
  my $err =\$dummy;
  my $die=0;
  if ($#_>=0) {$ctl=shift;}
  if ($#_>=0) {$err=shift;} else {$die=1;}

#  print "ENTRY: $dir\n";


   my @files;
  @files=get_dir($dir,$ctl);
  
  my @tree;

  foreach my $file (@files) { #add non-directory files first
    unless ((-d $dir.'/'.$file) or $file eq "." or $file eq "..") {
      push @tree, ($file);
    }
  }
  
  foreach my $file (@files) { #files of sub directories next 
#    print "FILE: $file\n";
    if (-d $dir.'/'.$file and $file ne '.' and $file ne '..') {
      my @subfiles=get_tree_files($dir.'/'.$file,$ctl);
      foreach my $subfile (@subfiles)  {
	push @tree, ("./".$file."/".$subfile);
      }
    }
  }


  if (wantarray) {
    return @tree;
  } else {
    return \@tree; #return reference to array.
  }
}


#==========================================================================
# hexdumps
#==========================================================================


sub spr_hexdump {
  my $A=[];
  my $len=0;
  if    (not        ref $_[0]) {
    $A = [@_];
    $len=scalar @$A;
  }
  elsif ("ARRAY" eq ref $_[0]) {
    $A = $_[0];
    $len=scalar @$A;
    if ($#_>=1) {$len=$_[1];}
  }


  my $ret="";

  for (my $i = 0 ; $i<$len ; $i++) {
    if (0 == ($i % 16)) {$ret.=sprintf("\n%04x: ",$i);}
    elsif (0 == ($i % 8)) { $ret.="  ";}
    $ret.=" ".spr_ifd_02x($A->[$i]);
  }
  $ret.="\n";
  return $ret;
}


sub spr_hexdump_w_ascii {
  my $A=[];
  my $len=0;
  if    (not        ref $_[0]) {
    $A = [@_];
    $len=scalar @$A;
  }
  elsif ("ARRAY" eq ref $_[0]) {
    $A = $_[0];
    $len=scalar @$A;
    if ($#_>=1) {$len=$_[1];}
  }


  my $ret="";
  my $tail="";

  for (my $i = 0 ; $i<$len ; $i++) {
    if (0 == ($i % 16)) {
      if ($tail) {
	$ret.="  ".$tail;
	$tail="";
      }
      $ret.=sprintf("\n%04x: ",$i);
    }
    elsif (0 == ($i % 8)) { $ret.="  ";}
    $ret.=" ".spr_ifd_02x($A->[$i]);
    if ($A->[$i]<0x20 || $A->[$i]>0x7F) {$tail.=" ";}
    else {$tail.=sprintf("%c",$A->[$i]);}
  }
  if ($tail) {$ret.="  ".$tail}
  $ret.="\n";
  return $ret;
}


sub spr_ifd_02x {
  my $val=shift;
  my $ret="XX"; #2 blank spaces if not defined.
  if (defined $val) {
    $ret=sprintf("%02x",$val);
  }
  return $ret;
}


sub spr_hexdump_first_last {
  my $A=[];
  my $len=0;
  if    (not        ref $_[0]) {
    $A = [@_];
    $len=scalar @$A;
  } elsif ("ARRAY" eq ref $_[0]) {
    $A = $_[0];
    $len=@$A;
    if ($#_>=1) {$len=$_[1];}
  }

  my $ret="";

  my $first_len=$len;
  if ($len>16) {$first_len=8;}


  $ret.="0000:";
  for (my $i = 0 ; $i<$first_len ; $i++) {
    $ret.=" ".spr_ifd_02x($A->[$i]);
  }
  

  
  if ($len>16) {
    $ret.= sprintf(" ... %04x:",$len-8);
    for (my $i = $len-8 ; $i<$len ; $i++) {
      $ret.=" ".spr_ifd_02x($A->[$i]);
    }
  }

  $ret.="\n";
  return $ret;
}


sub spr_hexstream {
  #similar to spr_hexdump, but no addresses and array must be a reference.
  my $A=shift;
  my $bytesPerLine=16;
  if ($#_>=0) {$bytesPerLine=shift;}
  my $ret="";

  for (my $i = 0 ; $i<=$#$A ; $i++) {
    if ($i>0 and 0 == ($i % $bytesPerLine)) {$ret.=sprintf("\n",$i);}
    elsif ($i>0)                            {$ret.=" ";}
    $ret.=spr_ifd_02x($A->[$i]);
  }
  $ret.="\n";

  return $ret;
}


# Need to make sure return value of the file is 1 to prevent
# use/require from complaining.
return 1;