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;