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;

package JatsSystem;
use JatsError;
use FileUtils;


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

my $GBE_BIN;                                    # From ENV

#-------------------------------------------------------------------------------
# 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
        #
        unless ( $GBE_BIN )
        {
            $GBE_BIN = $ENV{GBE_BIN} || Error ("Environment variable GBE_BIN not set");
        }

        unshift @cmd, "$GBE_BIN/sh", "-c"
    }

    #
    #   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
#
# Returns         : Error code
#
sub JatsCmd
{
    my $GBE_PERL = $ENV{GBE_PERL} || Error ("Environment variable GBE_PERL not set");
    my $GBE_CORE = $ENV{GBE_CORE} || Error ("Environment variable GBE_CORE not set");

    System ( "$GBE_PERL $GBE_CORE/TOOLS/jats.pl @_" );
}


#-------------------------------------------------------------------------------
# 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
#
# Returns         : Path name of the file
#
sub LocateProgInPath
{
    my ($prog, @args ) = @_;
    my $all = 0;
    my $stop_dir;

    #
    #   Extract arguments
    #
    foreach ( @args )
    {
        if ( m/^--All/ ) {
            $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, $ENV{PATH} ) )
    {
        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
#
# Inputs          : Array of element to quote
#
# Returns         : A string
#
sub QuoteCommand
{
    my $cmd = '';
    my $pad = '';
    foreach  ( @_ )
    {
        next unless ( $_ );
        $cmd .= $pad . '"' . $_ . '"';
        $pad = ' ';
    }
    return $cmd;
}

    
1;