#-- qar_util.pm ------------------------------------------------------------
#
# (c) Copyright Programming Research 2009
#
# Written: C. Waddingham, 28-10-2009
#
# Purpose: Provides low level routines for qar.
#
#---------------------------------------------------------------------------

#-- package QAR_UTIL: ------------------------------------------------------

package QAR_UTIL;

use strict;
use integer;

BEGIN
{
   our $trace_file = "";
   our $die_config_error = 10;
   our $die_program_termination = 19;

   our $platform_is_cygwin = $^O =~ /cygwin/o;
   our $platform_is_windows = $^O =~ /^MSWin/o;

   our $path_separator;
   $path_separator = "\\" if ( $platform_is_windows );
   $path_separator = "/"  if ( ! $platform_is_windows );

   our $executable_name = $0;

   # During PARSE_COMMAND_LINE, DIEX can be called and for this to work
   # correctly it is necessary to know whether qar::viewing_program=none
   # has been supplied.  NB qar::viewing_program=none may not be read on the 
   # command line, or in -via files etc, until after the error has occured.
   #
   # Hence switch off DIEX while reading command line, and if on completion of
   # reading the command line any errors were found, then display the errors and terminate.
   # 
   # To accommodate this:
   # 1. Before calling QAR_OPT::PARSE_COMMAND_LINE() set $QAR_UTIL::diex_buffer_messages = true;
   #    And set $QAR_UTIL::diex_message_buffer = "";
   # 2. Execute PARSE_COMMAND_LINE() => all DIEX output is buffered.
   # 3. On completion of PARSE_COMMAND_LINE(), if ( $QAR_UTIL::diex_message_buffer ne "" ) then print and EXIT
   # 4. Set $QAR_UTIL::diex_buffer_messages = false
   #

   # Boolean flag.  True => append DIEX msgs to $diex_message_buffer, and do not print.
   #                False => do not append DIEX msgs to $diex_message_buffer, and do print.
   our $diex_buffer_messages = 1;  # true, but this is not relied on.

   our $diex_message_buffer = "";
}

#---------------------------------------------------------------------------

sub INPUT
{
   # Usage: $str = INPUT( $prompt );
   #
   my $prompt = shift;

   print $prompt;
   my $str = <STDIN>;
   $str =~ s/[\n\r]+$//o;

   return $str;
}

# -------------------------------------------------------------------------

sub EXECUTE_ARGS_WITH_RESULT
{
   # Usage: $result_code = EXECUTE_ARGS_WITH_RESULT( @args );
   #
   my $prog_name = shift;
   my @args = @_;

   if ( $QAR_UTIL::platform_is_windows )
   {
      my $a_parameter_has_space = 0;   # false

      foreach my $arg ( @args )
      {
         $a_parameter_has_space |= index( $arg, " " ) != -1;

         $arg = QUOTE_ARG( $arg );
      }

      my $path = DIR_NAME( $prog_name );
      my $prog = BASE_NAME( $prog_name );

      if ( $path ne "" )
      {
         my $short_path = SHORT_PATH_NAME( $path );

         # Note that $short_path can still contain spaces
         # (see Win32::GetShortPathName documentation), if this is the
         # case die here.
         # 
         if ( ( index( $short_path, " " ) != -1 ) &&
              $a_parameter_has_space
            )
         {
            DIEX( $QAR_UTIL::executable_name . " Windows system limitation - " .
                  "Cannot execute \"$prog_name\" " . join( " ", @args ) . "\n",
                  $QAR_UTIL::die_config_error );
         }

         $prog_name = $short_path . $prog;
      }
   }

   my $return_code = system( $prog_name, @args );

   return $return_code >> 8;
}

# ----------------------------------------------------------------

sub LOAD_FILE
{
   # Usage: @file = LOAD_FILE( "fred.template" );
   #
   my $filename = shift;

   my @file = LOAD_FILE_AS_ARRAY( $filename );

   foreach my $line ( @file )
   {
      $line =~ s/[\n\r]+$//o;
   }

   return @file;
}

# ----------------------------------------------------------------

sub LOAD_FILE_AS_ARRAY
{
   # Usage @array_of_lines_of_file = LOAD_FILE_AS_ARRAY( $file_name );
   #
   my $file_name = shift;

   if ( ! $QAR_UTIL::platform_is_windows )
   {
      # Bodge. Because the Unix GUI surrounds some(?) paths in ' '
      # remove them here
      #
      $file_name =~ s/^'(.*)'$/$1/go;
   }

   open FILE, "<$file_name" or       
      DIEX( "Cannot find file \"$file_name\"\n$!",
            $QAR_UTIL::die_config_error );
   
   my @file_lines = <FILE>;
 
   close( FILE );
   
   return @file_lines;
}

#-----------------------------------------------------------------

sub WRITE_FILE
{
   # Usage: WRITE_FILE( $file_name, @text );
   #
   my $file_name = shift;
   my @text      = @_;

   open FILE, ">$file_name" or 
      DIEX( "::WRITE_FILE: Cannot open \"$file_name\".\n$!",
            $QAR_UTIL::die_program_termination );

   foreach my $line ( @text )
   {
      print FILE $line, "\n";
   }

   close FILE;
}

#-----------------------------------------------------------------

sub SPLIT_STRING_ALLOWING_SPECIFIC_QUOTED_TERMS
{
   # Subroutine to split up a string of terms separated by characters in 
   # the supplied $separator list.  Where some of the terms may be quoted
   # strings that include separators.
   # Note that escaped separators may be embedded.  To do this the 
   # separator is prefixed with \ (backslash).
   #
   # Usage:
   #  @list_of_terms = SPLIT_STRING_ALLOWING_SPECIFIC_QUOTED_TERMS
   #                     ( $separators, $str, $quote_char );
   #
   my $separators = shift;
   my $str        = shift;
   my $quote_char = shift;

   if ( ( $str eq "" ) || ( $separators eq "" ) )
   {
      return ();
   }

   if ( $separators =~ /\\|$quote_char/o )
   {
      DIEX( "$QAR_UTIL::executable_name Program error - '\\' and '$quote_char' " .
            "cannot be used as a split separator.\n",
            $QAR_UTIL::die_config_error );
   }

   my $in_quoted_term = 0;   # FALSE
   my $term           = "";
   my @list_of_terms  = ();
   my @characters     = split( //, $str );
   my $last_but_one   = $#characters - 1;
   my $ch_last        = RIGHT( $str, 1 );

   my $i_ch = 0;

   I_CH:
   while ( $i_ch <= $#characters )
   {
      my $ch = $characters[ $i_ch ];
      my $next_ch;

      # Fix for case where last term of str is quoted and
      # ends in  ...\"
      # Return term ending in \
      #
      if ( $in_quoted_term &&
           ( $i_ch == $last_but_one ) &&
           ( $ch eq "\\" ) &&
           ( $ch_last eq $quote_char )
         )
      {
         $term .= "\\";
         
         last I_CH;
      }

      if ( $i_ch < $#characters )
      {
         $next_ch = $characters[ $i_ch + 1 ];
      }
      else
      {
         $next_ch = "";
      }

      if ( ( $ch eq "\\" ) && ( $next_ch eq $quote_char ) )
      {
         $term .= $quote_char;
         ++$i_ch;
      }
      elsif ( ( $ch eq "\\" ) && ( index( $separators, $next_ch ) >= 0 ) )
      {
         $term .= $next_ch;
         ++$i_ch;
      }
      elsif ( $ch eq $quote_char )
      {
         $in_quoted_term = ! $in_quoted_term;
      }
      elsif ( index( $separators, $ch ) >= 0 )
      {
 	 if ( $in_quoted_term )
 	 {
 	    $term .= $ch;
 	 }
 	 else
 	 {
            if ( $term ne "" )
            {
 	       push @list_of_terms, $term;
 	       $term = "";
            }
 	 }
      }
      else
      {
 	 $term .= $ch;
      }

      ++$i_ch;
   }

   if ( $term ne "" )
   {
      push @list_of_terms, $term;
   }

   return @list_of_terms;
}

#-----------------------------------------------------------------

sub QUOTE_ARG
{
   # Usage: $quoted_arg = QUOTE_ARG( $arg );
   #
   # Escapes any embedded quotes.
   # If $arg has embedded spaces or embedded \ , and $arg not already quoted,
   # quotes $arg.
   #
   my $arg_supplied = shift;

   if ( $arg_supplied eq "" )
   {
      return "";
   }

   # If $arg already quoted, remove quotes.
   #
   my $arg = UNQUOTE( $arg_supplied );

   my $need_quotes = $arg ne $arg_supplied;
   
   # Test for embedded + in string that is NOT quoted.
   # This can be a problem on Windows. 
   #
   if ( ( $arg eq $arg_supplied ) &&
        ( index( $arg_supplied, "+" ) != -1 )
      )
   {
      # Here with arg_supplied is not quoted and has embedded +
      #
      # Set $need_quotes to true to force generation of surrounding quotes
      #
      $need_quotes = 1;  # true
   }
   
   # Test for embedded \ in string that is NOT quoted.
   #
   if ( ( $arg eq $arg_supplied ) &&
        ( index( $arg_supplied, "\\" ) != -1 )
      )
   {
      # Here with arg_supplied is not quoted and has embedded \
      #
      # Set $need_quotes to true to force generation of surrounding quotes
      #
      $need_quotes = 1;  # true
   }
   
   # Here with $arg as bare string that may need quotes if it has
   # embedded spaces.
   #

   # Need to maintain any \\ or \" already in string.
   # Hence separate $arg on \\ and \"
   #

   my @args;
   if ( $arg eq "" )
   {
      @args = ( "" );
   }
   else
   {
      @args = split( (/(\\\\|\\\")/o), $arg );
   }

   # Cannot allow $arg to end in ...\ as this will escape the 
   # applied quote and corrupt the command-line.
   # Similarly settings.via file does not allow paths that end in a
   # bare \
   # e.g. can't have -opC:\prqa\qac-5.0\temp\
   # settings.via can have -op"C:\prqa\qac-5.0\temp\" but this is not
   # suitable as an argument to a Perl program.
   # Achieve this by removing last term of @args if it is '\'.
   #

   my $last_arg = $args[ $#args ];

   if ( ( $last_arg ne "\\\\" ) &&
        ( $last_arg =~ /\\$/o )
      )
   {
      ( $args[ $#args ] = $last_arg ) =~ s/\\$//o;
   }

   SUB_ARG:
   foreach my $sub_arg ( @args )
   {
      next SUB_ARG if ( ( $sub_arg eq "\\\\" ) ||
                        ( $sub_arg eq "\\\"" )
                      );

      # Escape all embedded quotes
      #
      $sub_arg =~ s/\"/\\\"/go;
   }

   # Reinstate $arg by reassembling the components
   #
   $arg = join( "", @args );
   
   # Now quote if necessary.
   # On Unix command line ( or ) are special chars hence need to quote.
   #
   if ( $need_quotes ||
        ( $arg =~ /[\s\"]/oi )        ||
 	( index( $arg, "\"" ) != -1 ) ||
 	( index( $arg, "(" ) != -1 )  ||
 	( index( $arg, ")" ) != -1 )  ||
 	( index( $arg, "'" ) != -1 )
      )
   {
      return "\"$arg\"";
   }
   else
   {   
      # Here when no quoting necessary
      #
      return $arg;
   }
}

#-----------------------------------------------------------------

sub UNQUOTE
{
   # Usage: $unquoted_string = UNQUOTE( $arg );
   #
   my $arg = shift;

   if ( IS_QUOTED( $arg, "\"" ) )
   {
      return substr( $arg, 1, length( $arg ) - 2 );
   }
   else
   {
      return $arg;
   }
}

#-----------------------------------------------------------------

sub IS_QUOTED
{
   # Usage: $bool = IS_QUOTED( $item, "\'\"" );
   #
   my $item   = shift;
   my $quotes = shift;
   
   if ( length( $item ) < 2 )
   {
      return 0;  # False
   }

   my $first_ch = LEFT( $item, 1 );
   my $last_ch  = RIGHT( $item, 1 );

   my @quote_chars = split( //, $quotes );

   foreach my $ch ( @quote_chars )
   {
      if ( ( $first_ch eq $ch ) && ( $last_ch eq $ch ) )
      {
         return 1;  # true
      }
   }

   return 0;   # false
}

#-----------------------------------------------------------------

sub BASE_NAME
{
   # Usage: $stem_and_extension = BASE_NAME( $path );
   #
   my $path = shift;

   require File::Basename;

   return File::Basename::basename( $path );
}

# ----------------------------------------------------------------

sub STEM_NAME
{
   # Usage: $stem = STEM_NAME( $path );
   #
   my $base_name = BASE_NAME( shift );

   my $dot_pos = rindex( $base_name, "." );

   if ( $dot_pos == -1 )
   {
      return $base_name;
   }
   elsif ( $dot_pos == 0 )
   {
      return "";
   }
   else
   {
      return substr( $base_name, 0, $dot_pos );
   }
}

# ----------------------------------------------------------------

sub DIR_EXISTS 
{
   # Usage: $true_false = DIR_EXISTS( $dir_name );
   #
   my $dir_name = shift;

   return ( ( -e $dir_name ) &&
            ( -d $dir_name )
          );
}

# ----------------------------------------------------------------

sub DIR_NAME_NON_NORM
{
   # Usage: $directory_of_file_path = DIR_NAME_NON_NORM( $path );
   # Same as DIR_NAME except $path is not first normalised
   #
   my $path = shift;
   
   if ( $path eq "" )
   {
      return "";
   }

   my $n_pos = -1;
   my $keep_value;
   my $separator = $QAR_UTIL::path_separator;
  
   LOOP:
   for (;;)
   {
      $keep_value = $n_pos;
      $n_pos      = index( $path, $separator, $n_pos + 1 );
      last LOOP if ( $n_pos == -1 );
   }
    
   return LEFT( $path, $keep_value + 1 );
}

# ----------------------------------------------------------------

sub DIR_NAME
{
   # Usage: $directory_of_file_path = DIR_NAME( $path );
   #
   my $path = shift;
   
   if ( $path eq "" )
   {
      return "";
   }

   # Allow both Unix and DOS separators
   #
   $path = NORMALISE_PATH_SEPARATORS( $path );

   return DIR_NAME_NON_NORM( $path );
}

# ----------------------------------------------------------------

sub LEFT
{
   # Usage: $left_hand_str = LEFT( $str, $nch );
   #
   my $str = shift;
   my $nch = shift;

   if ( $str eq "" )
   {
       return "";
   }

   return substr( $str, 0, $nch );
}

#-----------------------------------------------------------------

sub RIGHT
{
   # Usage: $right_hand_str = RIGHT( $str, $nch );
   #
   my $str = shift;
   my $nch = shift;

   my $len_str = length( $str );
   
   if ( $len_str < $nch )
   {
      return $str;
   }

   return substr( $str, $len_str - $nch );
}

# ----------------------------------------------------------------

sub NORMALISE_PATH_SEPARATORS
{
   # Usage: $path_normalised = NORMALISE_PATH_SEPARATORS( $path );
   #
   # Swaps all occurences of \ or / for true path separator.
   #
   my $path = shift;
   
   my $separator = $QAR_UTIL::path_separator;

   ( $path = $path ) =~ s/\\/$separator/g;
   ( $path = $path ) =~ s/\//$separator/g;

   return $path;
}

#-----------------------------------------------------------------

sub APPLY_FINAL_SEP
{
   # e.g. $qabin = APPLY_FINAL_SEP( $QACBIN );
   #
   my $path = shift;

   if ( ( $path ne "" ) &&
        ( RIGHT( $path, 1 ) ne $QAR_UTIL::path_separator ) 
      )
   {
      return $path . $QAR_UTIL::path_separator;
   }
   else
   {
      return $path;
   }
}

#-----------------------------------------------------------------

sub REMOVE_FINAL_SEP
{
   # Usage: $path = REMOVE_FINAL_SEP( $file_path_str );
   #
   my $file_path_str = shift;
   
   if ( $file_path_str eq "" ) 
   {
      return "";
   }

   my $separator = $QAR_UTIL::path_separator;
  
   my $last    = length( $file_path_str ) - 1;
   my $last_ch = substr( $file_path_str, $last, 1 );

   while ( $last_ch eq $separator )
   {
      --$last;

      if ( $last eq -1 )
      {
         return "";
      }

      $last_ch = substr( $file_path_str, $last, 1 );
   }

   return LEFT( $file_path_str, $last + 1 );
}

# ----------------------------------------------------------------

sub SHORT_PATH_NAME
{
   # Usage: $windows_short_path = SHORT_PATH_NAME( $path );
   #
   my $path = shift;

   if ( ! defined( $path ) ||
        ( $path eq "" )
      )
   {
      return "";
   }
   elsif ( $QAR_UTIL::platform_is_windows )
   {
      require Win32;

      return Win32::GetShortPathName( $path );
   }
   else
   {
      return $path;
   }
}

# ----------------------------------------------------------------

sub DATE_DD_MONTH_YYYY
{
   # Usage: $date_dd_mmm_yy = DATE_DD_MMM_YY();
   #
   my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime;

   my $month = ( qw( January February March April May June July August September October November December ))[ $mon ];

   return ( $mday, $month, $year + 1900 );
}

# ----------------------------------------------------------------

sub PWD
{
   require Cwd;

   return Cwd::getcwd();
}

#-----------------------------------------------------------------

sub WHICH
{
   # Usage: $full_filename = WHICH( $program_name );
   #
   # Returns absolute path to $program_name or "" if not found.
   #
   # NB this WHICH() is identical to GEN::WHICH() and has the limitation that
   # for Windows, if the supplied file is not an executable file, e.g. fred.txt,
   # then WHICH() will return the first full path of fred.txt in
   # PATH, whether it is executable or not.  It is the responsibility
   # of the user of WHICH() to ensure that a truely executable
   # filename is supplied.
   #
   # For Unix simply uses the 'which' utility.
   # For Windows:
   #    Gets all paths on PATH and for each path:
   #       Looks for $program_name . ( '.exe' | '.com' | '' ).
   #
   # NB For Windows, this sub will return the first file path in PATH
   # that matches $program_name . ( '.exe' | '.com' | '' )
   # This may be a non-executable file.
 
   my $program_name = shift;

   if ( $program_name eq "" )
   {
      return "";
   }

   # No need to lookup if $program_name is absolute.
   #
   elsif ( IS_FILE_PATH_ABSOLUTE( $program_name ) )
   {
      return EXECUTABLE_FULL_NAME( $program_name );
   }
   elsif ( $program_name ne BASE_NAME( $program_name ) )
   {
      # Here when path is relative
      # Just add to current dir
      #
      my $path = GET_FILE_PATH_ABSOLUTE( APPLY_FINAL_SEP( PWD() ) . $program_name );

      return EXECUTABLE_FULL_NAME( $path );
   }
   elsif ( ! $QAR_UTIL::platform_is_windows )
   {
      my $prog      = BASE_NAME( $program_name );
      my $prog_stem = STEM_NAME( $program_name );

      my $exe_name  = $prog;

      my $path_delimiter = ":";
      my $path_list      = $ENV{ 'PATH' };

      # Append . to ensure that $program_name specified as ./name
      # can be found.
      #
      $path_list .= $path_delimiter . ".";

      my @paths = split( $path_delimiter, $path_list );
  
      foreach my $path ( @paths )
      {
         $path = APPLY_FINAL_SEP( $path );

         my $try_name = $path . $exe_name;

         if ( -f $try_name )
         {
            if ( $QAR_UTIL::platform_is_cygwin )
            {
               return $try_name;
            }
            elsif ( IS_FILE_EXECUTABLE( $try_name ) )
            {
               return $try_name;
            }
         }
      }
   }

   # Here when on Windows.
   #
   else
   {
      my $prog       = BASE_NAME( $program_name );
      my $prog_stem  = STEM_NAME( $program_name );

      my @exe_names = ( "$prog.exe", "$prog.com", $prog );

      my $path_delimiter = ";";
      my $path_list      = $ENV{ 'PATH' };
      $path_list         = "." . $path_delimiter . $path_list;

      my @paths = split( $path_delimiter, $path_list );
  
      foreach my $path ( @paths )
      {
         $path = APPLY_FINAL_SEP( $path );

         foreach my $exe_name ( @exe_names )
         {
            my $try_name = $path . $exe_name;

            if ( -f $try_name )
            {
               return EXECUTABLE_FULL_NAME( $try_name );
            }
         }
      }
   }

   return "";
}

#-----------------------------------------------------------------

sub IS_FILE_PATH_ABSOLUTE
{
   # Usage: $is_absolute_bool = IS_FILE_PATH_ABSOLUTE( $path );
   #
   # Returns true if path starts with \ or / or c:\
   #
   my $path = shift;

   if ( $QAR_UTIL::platform_is_windows )
   {
      # Does $path start with '\' ?
      #
      if ( substr( $path, 0, 1 ) =~ /^[\\\/]$/o )
      {
         # Have absolute path
         #
         return 1;   # true
      }
      elsif ( substr( $path, 1, 2 ) =~ /^:[\\\/]$/o )
      {
         # Have absolute path
         #
	 return 1;   # true
      }
      else
      {
         # Here when path is relative.
         #
         return 0;  # false
      }
   }
   else
   {
      if ( $QAR_UTIL::platform_is_cygwin )
      {
   	 my $ch2_3 = substr( $path, 1, 2 );
   
   	 if ( ( $ch2_3 eq ":\\" ) ||
   	      ( $ch2_3 eq ":/" )
   	    )
   	 {
   	    # Have absolute path
   	    #
   	    return 1;
   	 }
      }

      # Platform is Unix
      #
      if ( index( "~/", substr( $path, 0, 1 ) ) != -1 )
      {
         # Have absolute path
         #
         return 1;   # true
      }
      else
      {
         # Here when path is relative.
         #
         return 0;  # false
      }
   }
}

#-----------------------------------------------------------------

sub EXECUTABLE_FULL_NAME
{
   # Usage: $full_program_name = EXECUTABLE_FULL_NAME( $program_name );
   #
   my $program_name = shift;

   my $executable_full_name = "";

   if ( ! $QAR_UTIL::platform_is_windows )
   {
      $executable_full_name = $program_name;
   }
   else
   {
      if ( -e "$program_name.exe" )
      {
         $executable_full_name = "$program_name.exe";
      }
      if ( -e "$program_name.com" )
      {
         $executable_full_name = "$program_name.com";
      }
      elsif ( -e $program_name )
      {
         $executable_full_name = $program_name;
      }
   }

   if ( $executable_full_name eq "" )
   {
      return "";
   }

   ### $executable_full_name = GET_FILE_PATH_ABSOLUTE( $executable_full_name );
   ### $executable_full_name = EVALUATE_RELATIVE_PATHS( $executable_full_name );

   return $executable_full_name;
}

#-----------------------------------------------------------------

sub GET_FILE_PATH_ABSOLUTE
{
   # Usage: $path_adjusted = GET_FILE_PATH_ABSOLUTE( $path );
   #
   # If $path is relative, returns as absolute. 
   # If absolute returns unchanged.
   #
   # NB Cannot call trace() or entry() in this routine as TRACE will not
   # be initialised at this routine is called at startup.
   #
   my $path_param = shift;

   # Make sure uniform separators are used.
   #
   my $path = NORMALISE_PATH_SEPARATORS( $path_param );

   # Test path is legal
   #
   if ( LEFT( $path, 1 ) eq ":" )
   {
      DIEX( "GET_FILE_PATH_ABSOLUTE: Illegal path \"$path_param\".", 
            $QAR_UTIL::die_program_termination );
   }
  
   # Does $path start with '\' or '/'?
   # Allow DOS and Unix path separator of / or \
   #
   my $ch1 = LEFT( $path, 1 );
   my $first_char_indicates_absolute = ( index( "\\\/" , $ch1 ) >= 0 );

   if ( $first_char_indicates_absolute )
   {
      # Have absolute path
      #
      return $path;
   }

   if ( $QAR_UTIL::platform_is_windows )
   {
      my $ch2_3 = substr( $path, 1, 2 );

      if ( ( $ch2_3 eq ":\\" ) ||
           ( $ch2_3 eq ":/" )
         )
      {
         # Have absolute path
         #
         return $path;
      }
      else
      {
         # Here when path is relative.
         # Calc absolute path.
         #

         # First check case like  A:fred
         # Check that drive is the drive of the current dir.
         # If same then make relative to current dir
         # Otherwise don't know what current dir is for specified
         # drive, so fail program
         #

         my $current_dir_path = PWD();
         $current_dir_path = TRIM( $current_dir_path );

         my $abs_path;
         
         if ( substr( $path, 1, 1 ) eq ":" )
         {
            # Here with drive spec in supplied parameter ( $path_param ).
            #
         
            # Get that drive spec.
            #
            my ( $drive_specified, $path_specified, $junk ) = split( ":", $path, 3 );
         
            # Get the currently logged drive.
            #
            my ( $current_drive, $rest ) = split( ":", $current_dir_path, 2 );
         
            # Can only resolve a relative path of a drive which is the current drive.
            # e.g. can do:
            #   current drive is C:
            #   path is          C:fred
            # Cannot do
            #   current drive is C:
            #   path is          D:fred
            # as don't know the current directory on D:
            #
         
            if ( lc( $drive_specified ) eq lc( $current_drive ) )
            {
               $abs_path = APPLY_FINAL_SEP( $current_dir_path ) . $path_specified;
            }
            else
            {
               DIEX( "GET_FILE_PATH_ABSOLUTE: Cannot derive absolute " .
                     "path for \"$path_param\".",
                     $QAR_UTIL::die_program_termination );
            }
         }
         else
         {
            # Here with no drive spec in $path, i.e. $path_param.
            #
            $abs_path = APPLY_FINAL_SEP( $current_dir_path ) . $path;
         }
         
         # Remove any leading .\ pairs
         #
         ( $abs_path = $abs_path ) =~ s/^(\.\\)*//o;

         return $abs_path;
      }
   }
   else
   {
      if ( $QAR_UTIL::platform_is_cygwin )
      {
   	 my $ch2_3 = substr( $path, 1, 2 );
   
   	 if ( ( $ch2_3 eq ":\\" ) ||
   	      ( $ch2_3 eq ":/" )
   	    )
   	 {
   	    # Have absolute path
   	    #
   	    return $path;
   	 }
      }

      # Platform is Unix ( possibly Cygwin )
      #

      # Here when path is relative.
      # Calc absolute path.
      #

      # Test for path relative to login directory,
      # i.e. starts with '~'
      #
      if ( $ch1 eq "~" )
      {
         # Here with path relative to login directory
         # Get username e.g. ~fred/dir... or ~/dir... etc
         #
         my $home;
         ( $home = $path ) =~ s/^(~.*?)\/.*/$1/o;

         my $remainder = substr( $path, length( $home ) );

         # Evaluate the $home path
         #
         my $expanded_home_path = `ls -d $home`;
         $expanded_home_path = TRIM( $expanded_home_path );

         # Build the absolute path
         #
         return REMOVE_FINAL_SEP( $expanded_home_path ) . $remainder;
      }
      else
      {
   	 my $current_dir_path = PWD();
   	 $current_dir_path = TRIM( $current_dir_path );
   
   	 # Remove any leading ./ pairs
   	 #
   	 ( $path = $path ) =~ s/^(\.\/)*//o;
   
   	 return APPLY_FINAL_SEP( $current_dir_path ) . $path;
      }
   }
}

# --------------------------------------------------------------------------

sub TRIM
{
   # Usage: $trimmed_string = TRIM( string );
   # Removes leading and trailing whitespace from string
   #
   my $str = shift;

   ( $str = $str ) =~ s/^\s*//o;
   ( $str = $str ) =~ s/\s*$//o;

   return $str;
}

#-----------------------------------------------------------------

sub IS_FILE_EXECUTABLE
{
   # Usage: $boolean_executable= IS_FILE_EXECUTABLE( $filename );
   #
   my $filename = shift;

   return ( -x $filename ) || ( -X $filename );
}

#-----------------------------------------------------------------

sub SET_DIEX_BUFFERING_ON
{
   # Usage: SET_DIEX_BUFFERING_ON();
   #

   $QAR_UTIL::diex_buffer_messages = 1;  # true

   $QAR_UTIL::diex_message_buffer = "";
}

#-----------------------------------------------------------------

sub SET_DIEX_BUFFERING_OFF
{
   # Usage: SET_DIEX_BUFFERING_OFF();
   #

   $QAR_UTIL::diex_buffer_messages = 0;  # False

   # NB Having switched diex buffering off, it makes no difference
   # whether the diex_message_buffer is emptied or not, since this
   # will be done if and when the buffering is switched on again.
   # Hence next statement can be removed.
   #
   $QAR_UTIL::diex_message_buffer = "";
}

#-----------------------------------------------------------------

sub DIEX
{
   # Usage: DIEX( $msg, $return_code );
   #
   my $msg = shift;
   my $return_code = shift;

   if ( $QAR_UTIL::diex_buffer_messages )
   {
      $QAR_UTIL::diex_message_buffer .= $msg;

      return;
   }
   else
   {
      print "$msg\n";
   }

   TRACE( "$QAR_UTIL::executable_name ERROR:\n" );
   TRACE( $msg );

   EXIT( $return_code );
}

#-----------------------------------------------------------------

sub MK_PATH
{
   # Usage:  MK_PATH( $path_to_ensure_created );
   #
   my $path = shift;

   require File::Path;

   File::Path::mkpath( $path, 0, 0777 );

   return;

   $path = REMOVE_FINAL_SEP( $path );

   if ( $path eq "" )
   {
      return;
   }

   my $separator = $QAR_UTIL::path_separator;
   my @components_list;

   if ( $separator eq "\\" )
   {
      @components_list = split( /\\/, $path );
   }
   else
   {
      @components_list = split( /$separator/, $path );
   }

   my $z_path = "";
   if ( LEFT( $path, 1 ) eq $separator )
   {
      $z_path = $separator;
   }

   foreach my $component ( @components_list )
   {
      $z_path .= APPLY_FINAL_SEP( $component );

      my $z = REMOVE_FINAL_SEP( $z_path );

      if ( index( $component, ":" ) == -1 )
      {
         if ( -f $z )
         {
            # Here when directory to be created already exists as a file
            #
            DIEX( "Cannot create directory \"$z\" - " .
                  "already exists as a file.\n",
                  $QAR_UTIL::die_config_error );
         }
         elsif ( ! -e $z_path )
         {
            mkdir $z_path, 0777;
	 }
      }
   }
}

# -------------------------------------------------------------------------

sub GET_GLOB_FILE_LIST
{
   # Usage: ( $ar_file_list, $error_string ) = GET_GLOB_FILE_LIST( $filespec );
   #
   # If $filespec does not contain spaces, performs glob() on $filespec.
   #
   # NB glob() cannot handle filespec with spaces.
   #
   # Checks files exist and returns file_list and error status
   # error is returned true (1) if any errors are reported.
   #
   my $filespec_supplied = shift;

   my $no_error = "";  # false => no error

   if ( $filespec_supplied eq "" )
   {
      return ( [], $no_error );
   }

   # Check for case where filespec supplied has no wildcards.
   # If this is the case simply check whether the filespec exists.
   #
   if ( ( index( $filespec_supplied, "?" ) == -1 ) &&
        ( index( $filespec_supplied, "*" ) == -1 )
      )
   {
      # Here when filespec is not wildcarded
      #
      if ( -e $filespec_supplied )
      {
         return ( [ $filespec_supplied ], $no_error );
      }
      else
      {
         return ( [], "Cannot find file \"$filespec_supplied\"\n" );
      }
   }

   # Perl glob works for Unix paths, but has glitches with DOS paths,
   # e.g. C:\fred\--mks.
   # Hence if we are on a DOS platform, translate path separators to
   # Unix ones for the purposes of glob.  And then reverse the separators
   # of the result.
   #

   my $filespec = $filespec_supplied;

   if ( $QAR_UTIL::platform_is_windows )
   {
      ( $filespec = $filespec ) =~ s/\\/\//go;
   }

   my @file_list = glob( QUOTE_ARG( $filespec ) );

   if ( scalar( @file_list ) == 0 )
   {
      return ( [], "Cannot find file \"$filespec_supplied\"\n" );
   }
   else
   {
      # Here with valid glob
      # 
      my @file_names = ();
      my $error      = $no_error;

      foreach my $file_name ( @file_list )
      {
         if ( $QAR_UTIL::platform_is_windows )
         {
            # Reinstate the DOS path separators
            #
	    ( $file_name = $file_name ) =~ s/\//\\/go;
         }

         if ( -e $file_name )
         {
            push @file_names, $file_name;
         }
         else
         {
            $error .= "Cannot find file \"$file_name\"\n";
         }
      }

      return ( \@file_names, $error );
   }
}

# -------------------------------------------------------------------------

sub OPEN_TRACE
{
   # Usage: OPEN_TRACE( $executable_name );
   #
   my $executable_name = shift;

   $QAR_UTIL::trace_file = $executable_name . ".trace";

   open TRACE, ">$QAR_UTIL::trace_file";
}

#---------------------------------------------------------------------------

sub TRACE
{
   # Usage: TRACE( $msg );
   #
   my $msg = shift;

   print TRACE $msg;
}

#---------------------------------------------------------------------------

sub DELETE_TRACE
{
   # Usage: DELETE_TRACE();
   #
   close $QAR_UTIL::trace_file;

   unlink( $QAR_UTIL::trace_file );
}

#---------------------------------------------------------------------------

sub CLOSE_TRACE
{
   # Usage: CLOSE_TRACE();
   #

   my $trace_file = GET_FILE_PATH_ABSOLUTE( $QAR_UTIL::trace_file );

   $trace_file = NORMALISE_PATH_SEPARATORS( $trace_file );

   print "Trace written to $trace_file\n";

   close $QAR_UTIL::trace_file;
}

#---------------------------------------------------------------------------

sub EXIT
{
   # Usage: EXIT( $return_code );
   #
   my $return_code = shift;

   # Here with run ok (depending on $return_code), so delete the trace file
   # unless user supplied the -trace option
   #
   if ( ( $return_code != 0 ) ||
        ( grep( /^-trace$/oi, @ARGV ) != 0 )
      )
   {
      CLOSE_TRACE();

      require QAR_OPT;

      if ( lc( QAR_OPT::VIEWING_PROGRAM() ) ne "none" )
      {
         my $ignore = INPUT( "Press return to continue: " );
      }
   }
   else
   {
      DELETE_TRACE();
   }

   exit $return_code;
}

# ----------------------------------------------------------------

sub LOOKUP_DEFAULT_BROWSER_IN_REGISTRY
{
   # Usage $browser_name = LOOKUP_DEFAULT_BROWSER_IN_REGISTRY();
   #

   if ( ! $QAR_UTIL::platform_is_windows )
   {
      return "";
   }

   require Win32::Registry;

   my $register = "http\\shell\\open\\command";
   my $hkey;
   my $hr_values = {};

   if ( 0 )
   {
      # Avoid: Name "main::HKEY_CLASSES_ROOT" used only once: possible typo ...
      #
      my $ignore = $main::HKEY_CLASSES_ROOT;
   }

   $main::HKEY_CLASSES_ROOT->Win32::Registry::Open
      ( $register, $hkey ) ||
      die( "Registry lookup failure.\n$!\n" );

   $hkey->Win32::Registry::GetValues( $hr_values );
   $hkey->Win32::Registry::Close();
   
   foreach my $value ( keys %$hr_values )
   {
      my $reg_key   = $$hr_values{ $value }->[ 0 ];
      my $reg_type  = $$hr_values{ $value }->[ 1 ];
      my $reg_value = $$hr_values{ $value }->[ 2 ];
   
      if ( ( $reg_key eq "" ) &&
           ( $reg_type == 1 )
         )
      {
         return $reg_value;
      }
   }
   
   # Fall through implies default registry value not found.
   #
   return "";
}

#-- eof qar_util.pm  --------------------------------------------------------

1
