Subversion Repositories DevTools

#! perl
########################################################################
# Copyright ( C ) 2005 ERG Limited, All rights reserved
#
# Module name   : jats.sh
# Module type   : Perl Package
# Compiler(s)   : n/a
# Environment(s): jats
#
# Description   : This package contains functions to access system commands
#                 and programs.
#
#
#......................................................................#

use 5.006_001;
use strict;
use warnings;

#
#   System Wide Globals
#
our $GBE_BIN;                                   # From ENV
our $GBE_PERL;
our $GBE_CORE;


package JatsSystem;
use JatsError;
use FileUtils;
use JatsEnv;


our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
use Exporter;

$VERSION = 1.00;
@ISA = qw(Exporter);

# Symbols to autoexport (:DEFAULT tag)
@EXPORT = qw(
            System
            SystemConfig
            JatsCmd
            JatsTool
            LocateProgInPath
            QuoteCommand
            );

# Non exported package globals go here

my $opt_test_mode           = 0;                # Test Mode disabled
my $opt_use_shell           = 0;                # Force a shell to be used
my $opt_exit_on_error       = 0;                # Force exit on error

#-------------------------------------------------------------------------------
# Function        : SystemConfig
#
# Description     : Set the system command to TEST mode
#                   Command will not be executed. Only displayed
#
# Inputs          : Test        => Test Mode
#                   UseShell    => Default Shell Mode
#                   ExitOnError => Exit on Error Mode
#
# Returns         : Nothing
#
sub SystemConfig
{
    my %args = @_;

    while (my($key, $value) = each %args)
    {
        if (       $key =~ /^Test/i ) {
            $opt_test_mode = $value;
            Message("SystemTest Enabled") if $value;

        } elsif ( $key =~ /^UseShell/i ) {
            $opt_use_shell = $value;

        } elsif ( $key =~ /^ExitOnError/i ) {
            $opt_exit_on_error = $value;

        } else {
            Error("SystemConfig, Unknown option: $key");
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : System
#
# Description     : Exec the specified command ...
#
# Inputs          : Options [Must be first]
#                       --Show              Force argument display
#                       --Shell             Force use of a Shell
#                       --NoShell           Force no Shell use
#                       --Exit              Force Exit on Error
#                       --ExitQuiet         Force Exit on Error, without display
#                       --NoExit            Force no exit on error
#                   Command
#                   Command args
#
# Returns         : Result code
#
sub System
{
    my @cmd;
    my( $rv );
    my $opt_show = 0;
    my $opt_prefix = "System:";
    my $shell = $opt_use_shell;
    my $exit = $opt_exit_on_error;

    #
    #   Strip off any leading options
    #
    my $just_collect;
    foreach ( @_ )
    {
        if ( $just_collect ) {
            push @cmd, $_;
            next;

        } elsif ( m/^--Show/ ) {
            $opt_show = 1;
        } elsif ( m/^--Shell/ ) {
            $shell = 1;
        } elsif ( m/^--NoShell/ ) {
            $shell = 0;
        } elsif ( m/^--ExitQuiet/ ) {
            $exit = 2;
        } elsif ( m/^--Exit/ ) {
            $exit = 1;
        } elsif ( m/^--NoExit/ ) {
            $exit = 0;
        } elsif ( m/^--/ ) {
            Warning("System: Unknown option(ignored): $_" );
        } else {
            $just_collect = 1;
            redo;
        }
    }

    #
    #   Prefix with Shell if required
    #
    if ( $shell )
    {
        #
        #   Fetch and cache GBE_BIN
        #
        EnvImport ('GBE_BIN')
            unless ( $::GBE_BIN );

        #
        #   Reform command
        #   With -c shell takes one argumemnt - not an array of args
        #   Escape the users command and enclose in quotes
        #
        @cmd = ( "$::GBE_BIN/sh", "-c", EscapeCommand(@cmd) );
    }

    #
    #   Display the command
    #
    $opt_prefix = "System TEST:" if ($opt_test_mode);
    if ( $opt_show || $::ScmVerbose >= 2  )
    {
        my $line = $opt_prefix . ' ' . join ',', map ( "\"$_\"" , @cmd);
        Verbose2 ( $line) ;
        Message  ( $line ) if ( $opt_show );
    }

    #
    #   Simply return OK if in test mode
    #
    return 0 if ( $opt_test_mode );

    #
    #   Now do the hard bit
    #
    $rv = system( @cmd );

    #
    #   Report the result code
    #
    Verbose2 "System Result Code: $rv";
    Verbose2 "System Result Code: $!" if ($rv);
    $rv = $rv / 256;

    #
    #   If ExitOnError is enabled, then force program termination
    #
    if ( $rv && $exit )
    {
        if ( $exit == 2 )
        {
            Error("Program terminated. Errors previously reported");
        }

        Error("System cmd failure. Exit Code: $rv",
              "Command: " . join ',', map ( "\"$_\"" , @cmd) );
    }
    
    return $rv;
}

#-------------------------------------------------------------------------------
# Function        : JatsCmd
#
# Description     : Issue a command to JATS.PL
#
# Inputs          : Command line
#                   This should be an array of arguments
#                   It will not be processed by a shell
# Returns         : Error code
#
sub JatsCmd
{
    EnvImport ('GBE_PERL');
    EnvImport ('GBE_CORE');

    System (  '--NoShell', $::GBE_PERL, "$::GBE_CORE/TOOLS/jats.pl", @_ );
}

#-------------------------------------------------------------------------------
# Function        : JatsTool
#
# Description     : Issue a command to JATS tool
#                   Don't invoke JATS wrapper - go straight to the tool
#
# Inputs          : Tool                        - With optional .pl extension
#                   Command line                - Tool command line
#
# Returns         : Error code
#
sub JatsTool
{
    EnvImport ('GBE_PERL');
    EnvImport ('GBE_CORE');

    my $cmd = shift;
    $cmd .= '.pl' unless ( $cmd =~ m~\.pl$~i );

    #
    #   Look in the standard places for a JATS tool
    #   These are all perl tools
    #
    my $path;
    foreach my $dir (  '/TOOLS/', '/TOOLS/DEPLOY/', '/TOOLS/LOCAL/', '')
    {
        Error ("JatsTool not found: $cmd") unless ( $dir );
        $path = $::GBE_CORE . $dir . $cmd;
        last if ( -f $path );
    }

    System ( '--NoShell', $::GBE_PERL, $path, @_ );
}

#-------------------------------------------------------------------------------
# Function        : LocateProgInPath
#
# Description     : Locate a program in the users path
#                   (Default) Stop if we get the the JATS bin directory
#                   The user should NOT be using programs that are not
#                   provided by JATS
#
# Inputs          : prog            - Program to locate
#                   args            - Options
#                                     --All : Search all of PATH
#                                             Used by build tools
#                                     --Path= User provided pathlist
#
# Returns         : Path name of the file
#
sub LocateProgInPath
{
    my ($prog, @args ) = @_;
    my $all = 0;
    my $stop_dir;
    my $upath = $ENV{PATH};

    #
    #   Extract arguments
    #
    foreach ( @args )
    {
        #
        #   Search in all paths: Don't limit ourselves to JATS
        #
        if ( m/^--All/ ) {
            $all = 1;
        }

        #
        #   User provided pathlist
        #   Allow for an empty list - which will use the default path
        #
        if ( m/^--Path=(.+)/ ) {
            if ( $1 ) {
                $upath = $1;
                $all = 1;
            }
        }
    }

    #
    #   Stop at the JATS BIN directory, unless requested otherwise
    #
    unless ( $all )
    {
        $stop_dir = "$ENV{GBE_CORE}/BIN.";
        $stop_dir =~ tr~\\/~/~s;
    }

    #
    #   A list of known extensions to scan
    #   Basically present so that we can use .exe files without the .exe name
    #
    my @elist;
    push @elist, '.exe' if ( $ScmHost ne "Unix" );
    push @elist, '.pl', '.sh', '.ksh', '';

    #
    #   If elist is empty then insert a defined entry
    #
    push @elist, '' unless ( @elist );

    #
    #   Scan all toolset directories
    #   for the program
    #
    for my $dir ( split ( $ScmPathSep, $upath ) )
    {
        for my $ext ( @elist )
        {
            my $tool = "$dir/$prog$ext";
            Debug2( "LocateProgInPath: Look for: $tool" );

            return $tool if ( -f $tool );
        }

        #
        #   Don't process any dirs beyond the JATS BIN directory
        #   The program MUST be provided by the JATS framework and not
        #   random user configuration
        #
        if (  $stop_dir )
        {
            $dir =~ tr~\\/~/~s;
            if ( $dir =~ /^$stop_dir/i)
            {
                Message ("LocateProgInPath: Stopped at JATS BIN");
                last;
            }
        }
    }
}

#-------------------------------------------------------------------------------
# Function        : QuoteCommand
#
# Description     : Return a string command that is quoted
#                   Do not quote empty elements
#                   Don't quote if already quoted
#                   Handle embedded quotes
#
# Inputs          : Array of element to quote
#
# Returns         : A string or an array
#                   Try to keep as an array
#
sub QuoteCommand
{
    my @cmd;
    foreach ( @_ )
    {
        next unless ( defined $_);             # Ignore empty
        next if ( $_ eq '' );

        if ( m~^"(.+)"$~ )                      # Ignore already quoted
        {
            push @cmd, $_;
            next;
        }

        my $data = $_;                          # Escape embedded "
        $data =~ s~"~\\"~g;
        push @cmd, '"' . $data . '"';           # Quote the argument
    }

    #
    #   Attempt to keep it as an array
    #
    return (wantarray) ? @cmd : join (' ', @cmd);
}

#-------------------------------------------------------------------------------
# Function        : EscapeCommand
#
# Description     : Escape input commands
#                   Can be called with two forms of arguments.
#                   If the there is only one item in the input list, then the
#                   command will be a single command that is to be processed
#                   by the shell. We cannot do escaping of space characters.
#
#                   If there is more than one item, then assume that each
#                   item will be a standalone command parameter - and we can
#                   quote spaces within the command stream.
#
#                   Must handle:
#                       Embedded "
#                       Embeded spaces
#                   Doesn't (yet) handle embedded \
#
# Inputs          : Array of elements to process
#
# Returns         : Return an escaped string
#
sub EscapeCommand
{
    my @cmd;
    my $arg_count = $#_;

    foreach ( @_ )
    {
        my $data = $_;
        next unless ( $data );
        $data =~ s~"~\\"~g;
        $data =~ s~ ~\\ ~g if ($arg_count > 0);
        push @cmd, $data;
    }
    return join (' ', @cmd);
}

1;