Subversion Repositories DevTools

#! perl

########################################################################

# COPYRIGHT - VIX IP PTY LTD ("VIX"). 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 ( @_ )

    {

        # Ignore undefined item on the command line.

        # Makes use of ternary operators, for optional items, easier

        next unless defined $_;

        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

    #   Note: -1 indicates the progarm didn't run at all

    #         Otherwise the upper 8 bits is the programs exit code

    #

    Verbose2 "System Result Code: $rv";

    Verbose2 "System Result Code: $!" if ($rv);

    if ($rv eq -1) {

        $rv = -1;

    } else {

        $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;