#!/usr/bin/perl
########################################################################
#
#                  CTC++ System, absagent.pl (v1.2)
#                  (part of ctcwrap -hard ... toolchain)
#
# RCSfile     : $RCSfile: absagent.pl $
# Version     : $Revision: 1.5 $ $Date: 2015/05/05 12:53:03 $
# Last Edited : 5.5.2015
# Author      : $Author: jorma $
#
#               Copyright (c) 1997-2013 Testwell Oy
#               Copyright (c) 2013-2015 Verifysoft Technology GmbH 
##########################################################################

##########################################################################
# subroutines
##########################################################################

sub dirname;
sub basename;
sub which;
sub safeguarded_argument;

##########################################################################
# execution starts here !
##########################################################################

push @INC, "$ENV{CTCHOME}\\Perl";
require "NT.ph";

$compiler = shift @ARGV;
$bindir = dirname($compiler);
$cc = "ctc";
$cmdline_arg;

if (basename($compiler)=~/^C(51|166|251|a)\.EXE$/i) {
    my $orig = $compiler;
    $orig=~s/\.EXE$//i;
    $orig.="-orig.exe";
    $ENV{_CTC_ORIG_COMPILER_}=$orig;
    $cc="keilctc";
}

# if there is .ini file mapping for this compiler/linker, use it...
if (-f $ENV{CTCHOME}."\\absagentinis.pm") {
    require $ENV{CTCHOME}."\\absagentinis.pm";

    if (defined $ini{basename($compiler)}) {
        $cc .= " -c " . '"' . $ENV{CTCHOME} . "\\" . $ini{basename($compiler)} . '"';
    }
}

# ctc-options are stored at $bindir at ctcwrap -hard -modeon ... time
if (! -d $bindir) {
    $bindir = dirname(which($compiler));
}
if (-f $bindir."\\ctcopts.rsp") { # actually should always exist...!
    $cc .= " " . safeguarded_argument("@" . $bindir . "\\ctcopts.rsp");
} else {
    print
    "*** absagent.pl: Something wrong! At ctcwrap -hard -modeon ... time " .
    "the ctc options to be used were written to $bindir\\ctcopts.rsp file. " .
    "But it does not exist any more. For this usage enforced options " .
    "-V and -v.\n";
    $cc .= " -V -v";
}

# compiler/linker...
$compiler =~ s/(.exe$|$)/-orig.exe/i;
if (dirname($compiler) =~ /\s/) {
   my $dir = dirname($compiler);
   $compiler = substr($compiler,length $dir); # separator plus basename
   $compiler = Win32::GetShortPathName($dir).$compiler;
}
$cc .= " " . $compiler;

#compiler/linker arguments...
foreach $cmdline_arg (@ARGV) {
    $cc .= " " . safeguarded_argument($cmdline_arg);
}

# call the instrumentation command...
system ($cc); # ctc tells possible problems...

1;

# The program execution ends here. The definitions of the subroutines
# follow.

##########################################################################
# SUBROUTINES
##########################################################################

##########################################################################
# SUBROUTINE: dirname
# PURPOSE   : Returns the directory part of a filename, do not return the
#             directory separator(s) before the filename
##########################################################################
sub dirname
{
    my ($filename) = @_;
    my $dir = "";

    if ($filename =~ /(.+)[\\\/](.+)/) { # the rightmost '\' or '/'
        $dir = $1;
    }
    # strip still the possible "extra" dir separators from end
    while ($dir =~ /(.+)[\\\/]$/) {
        $dir = $1;
    }
    return $dir;
}


##########################################################################
# SUBROUTINE: basename
# PURPOSE   : Strip directory from a filename. Returns filename in lowercase.
##########################################################################
sub basename 
{
    my ($filename) = @_;
    my $base = $filename;

    if ($filename =~/(.+)[\\\/](.+)/) { # the rightmost '\' or '/'
        $base = $2;
    }
    return lc($base);
}

##########################################################################
# SUBROUTINE: which 
# PURPOSE   : Determines path of an executable in %PATH%
# ARGUMENTS : - Name of executable
# RETURNS   : Path to executable
##########################################################################
sub which {
    my ($exe) = @_;
    my $tmp;
    my $envseparator = ';';
    my $separator = '\\';

    foreach (split $envseparator, $ENV{PATH}) {
        $tmp = $_ . $separator . $exe; 
        return $tmp if (-x $tmp or -x $tmp . "\.exe");
    }
    return "\." . $separator . $exe; # Worst case, should never happen
}

##########################################################################
# SUBROUTINE: safeguarded_argument
# PARAMETER : - argument : the argument value as it is seen in ARGV[i]
# PURPOSE   : Cheks if there is a reason to strengthen '"' or '\' chars in
#             the argument (and does so) and should the whole argument be
#             still safeguarded with "..." (and does so).
# RETURNS   : The safeguarded argument. (If no need for safeguarding it
#             is the same value as before)
##########################################################################
sub safeguarded_argument 
{
   my ($arg) = @_;
   my $newarg = "";
   my $quote_needed = 0;
   my $backslash_count = 0;
   my $ch = "";
   my $i = 0;

   # Is there reason to overall "..." safeguarding?
   # (Some black magic in cmd shell behavior. We assume that it is .exe whom we call)
   if ($arg =~ /\s/ or
       #### $arg =~ /=/ or $arg =~ /;/ or $arg =~ /,/ or
       $arg =~ /\|/ or $arg =~ /&/ or $arg =~ /</ or $arg =~ />/) {
      $quote_needed = 1;
   }

   # Now start constructing the safeguarded argument.
   # First the starting "... if needed
   if ($quote_needed == 1) {
      $newarg .= '"';
   }

   # Then the $arg chars one by one. Special '\' handling if '"' is met.
   while ($arg ne "") {

      # Extract first char from $arg and reduce it correspondingly
      $arg =~ /^(.)(.*)/;
      $ch = $1;
      $arg = $2; 

      # Copy the char to the safeguarded arg
      if ($ch eq '\\') {
         $backslash_count++;
         $newarg .= '\\';

      } elsif ($ch eq '"') {
         # duplicate the possible preceding backslashes, all of them
         for ($i = 1; $i <= $backslash_count ; $i++) {
            $newarg .= '\\';
         }
         # and the safeguarded '"' still
         $newarg .= '\\' . '"';
         $backslash_count = 0;

      } else {
         # normal/harmless char
         $newarg .= $ch;
         $backslash_count = 0;
      }
   }

   # Finally the closing ..." if needed
   if ($quote_needed == 1) {
      # but here also the possibe preceding backslashes duplicating!
      for ($i = 1; $i <= $backslash_count ; $i++) {
         $newarg .= '\\';
      }
      $newarg .= '"';
   }

   return $newarg;
}

# EOF $RCSfile: absagent.pl $