Subversion Repositories DevTools

Rev

Rev 261 | Rev 343 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 261 Rev 263
Line 15... Line 15...
15 
 
 15 
 
16 
use 5.006_001;
 16 
use 5.006_001;
17 
use strict;
 17 
use strict;
18 
use warnings;
 18 
use warnings;
19 
 
 19 
 
- 
 
 20 
#
- 
 
 21 
#   System Wide Globals
- 
 
 22 
#
- 
 
 23 
our $GBE_BIN;                                   # From ENV
- 
 
 24 
our $GBE_PERL;
- 
 
 25 
our $GBE_CORE;
- 
 
 26 
 
- 
 
 27 
 
20 
package JatsSystem;
 28 
package JatsSystem;
21 
use JatsError;
 29 
use JatsError;
22 
use FileUtils;
 30 
use FileUtils;
- 
 
 31 
use JatsEnv;
23 
 
 32 
 
24 
 
 33 
 
25 
our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
 34 
our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
26 
use Exporter;
 35 
use Exporter;
27 
 
 36 
 
Line 31... Line 40...
31 
# Symbols to autoexport (:DEFAULT tag)
 40 
# Symbols to autoexport (:DEFAULT tag)
32 
@EXPORT = qw(
 41 
@EXPORT = qw(
33 
            System
 42 
            System
34 
            SystemConfig
 43 
            SystemConfig
35 
            JatsCmd
 44 
            JatsCmd
- 
 
 45 
            JatsTool
36 
            LocateProgInPath
 46 
            LocateProgInPath
37 
            QuoteCommand
 47 
            QuoteCommand
38 
            );
 48 
            );
39 
 
 49 
 
40 
# Non exported package globals go here
 50 
# Non exported package globals go here
41 
 
 51 
 
42 
my $opt_test_mode           = 0;                # Test Mode disabled
 52 
my $opt_test_mode           = 0;                # Test Mode disabled
43 
my $opt_use_shell           = 0;                # Force a shell to be used
 53 
my $opt_use_shell           = 0;                # Force a shell to be used
44 
my $opt_exit_on_error       = 0;                # Force exit on error
 54 
my $opt_exit_on_error       = 0;                # Force exit on error
45 
 
 55 
 
46 
my $GBE_BIN;                                    # From ENV
 - 
 
47 
 
 - 
 
48 
#-------------------------------------------------------------------------------
 56 
#-------------------------------------------------------------------------------
49 
# Function        : SystemConfig
 57 
# Function        : SystemConfig
50 
#
 58 
#
51 
# Description     : Set the system command to TEST mode
 59 
# Description     : Set the system command to TEST mode
52 
#                   Command will not be executed. Only displayed
 60 
#                   Command will not be executed. Only displayed
Line 141... Line 149...
141 
    if ( $shell )
 149 
    if ( $shell )
142 
    {
 150 
    {
143 
        #
 151 
        #
144 
        #   Fetch and cache GBE_BIN
 152 
        #   Fetch and cache GBE_BIN
145 
        #
 153 
        #
146 
        unless ( $GBE_BIN )
 154 
        EnvImport ('GBE_BIN')
147 
        {
 - 
 
148 
            $GBE_BIN = $ENV{GBE_BIN} || Error ("Environment variable GBE_BIN not set");
 155 
            unless ( $::GBE_BIN );
149 
        }
 - 
 
150 
 
 156 
 
- 
 
 157 
        #
- 
 
 158 
        #   Reform command
- 
 
 159 
        #   With -c shell takes one argumemnt - not an array of args
- 
 
 160 
        #   Esacpe the users command and enclose in quotes
- 
 
 161 
        #
151 
        unshift @cmd, "$GBE_BIN/sh", "-c"
 162 
        @cmd = ( "$::GBE_BIN/sh", "-c", EsacpeCommand(@cmd) );
152 
    }
 163 
    }
153 
 
 164 
 
154 
    #
 165 
    #
155 
    #   Display the command
 166 
    #   Display the command
156 
    #
 167 
    #
Line 170... Line 181...
170 
    #
 181 
    #
171 
    #   Now do the hard bit
 182 
    #   Now do the hard bit
172 
    #
 183 
    #
173 
    $rv = system( @cmd );
 184 
    $rv = system( @cmd );
174 
 
 185 
 
175 
 
 - 
 
176 
    #
 186 
    #
177 
    #   Report the result code
 187 
    #   Report the result code
178 
    #
 188 
    #
179 
    Verbose2 "System Result Code: $rv";
 189 
    Verbose2 "System Result Code: $rv";
180 
    Verbose2 "System Result Code: $!" if ($rv);
 190 
    Verbose2 "System Result Code: $!" if ($rv);
Line 201... Line 211...
201 
# Function        : JatsCmd
 211 
# Function        : JatsCmd
202 
#
 212 
#
203 
# Description     : Issue a command to JATS.PL
 213 
# Description     : Issue a command to JATS.PL
204 
#
 214 
#
205 
# Inputs          : Command line
 215 
# Inputs          : Command line
206 
#
 - 
 
- 
 
 216 
#                   This should be an array of arguments
- 
 
 217 
#                   It will not be processed by a shell
207 
# Returns         : Error code
 218 
# Returns         : Error code
208 
#
 219 
#
209 
sub JatsCmd
 220 
sub JatsCmd
210 
{
 221 
{
211 
    my $GBE_PERL = $ENV{GBE_PERL} || Error ("Environment variable GBE_PERL not set");
 222 
    EnvImport ('GBE_PERL');
212 
    my $GBE_CORE = $ENV{GBE_CORE} || Error ("Environment variable GBE_CORE not set");
 223 
    EnvImport ('GBE_CORE');
213 
 
 224 
 
214 
    System ( "$GBE_PERL $GBE_CORE/TOOLS/jats.pl @_" );
 225 
    System (  '--NoShell', $::GBE_PERL, "$::GBE_CORE/TOOLS/jats.pl", @_ );
215 
}
 226 
}
216 
 
 227 
 
- 
 
 228 
#-------------------------------------------------------------------------------
- 
 
 229 
# Function        : JatsTool
- 
 
 230 
#
- 
 
 231 
# Description     : Issue a command to JATS tool
- 
 
 232 
#                   Don't invoke JATS wrapper - go straight to the tool
- 
 
 233 
#
- 
 
 234 
# Inputs          : Tool                        - With optional .pl extension
- 
 
 235 
#                   Command line                - Tool command line
- 
 
 236 
#
- 
 
 237 
# Returns         : Error code
- 
 
 238 
#
- 
 
 239 
sub JatsTool
- 
 
 240 
{
- 
 
 241 
    EnvImport ('GBE_PERL');
- 
 
 242 
    EnvImport ('GBE_CORE');
- 
 
 243 
 
- 
 
 244 
    my $cmd = shift;
- 
 
 245 
    $cmd .= '.pl' unless ( $cmd =~ m~\.pl$~i );
- 
 
 246 
 
- 
 
 247 
    #
- 
 
 248 
    #   Look in the standard places for a JATS tool
- 
 
 249 
    #   These are all perl tools
- 
 
 250 
    #
- 
 
 251 
    my $path;
- 
 
 252 
    foreach my $dir (  '/TOOLS/', '/TOOLS/DEPLOY/', '/TOOLS/LOCAL/', '')
- 
 
 253 
    {
- 
 
 254 
        Error ("JatsTool not found: $cmd") unless ( $dir );
- 
 
 255 
        $path = $::GBE_CORE . $dir . $cmd;
- 
 
 256 
        last if ( -f $path );
- 
 
 257 
    }
- 
 
 258 
 
- 
 
 259 
    System ( '--NoShell', $::GBE_PERL, $path, @_ );
- 
 
 260 
}
217 
 
 261 
 
218 
#-------------------------------------------------------------------------------
 262 
#-------------------------------------------------------------------------------
219 
# Function        : LocateProgInPath
 263 
# Function        : LocateProgInPath
220 
#
 264 
#
221 
# Description     : Locate a program in the users path
 265 
# Description     : Locate a program in the users path
Line 313... Line 357...
313 
            }
 357 
            }
314 
        }
 358 
        }
315 
    }
 359 
    }
316 
}
 360 
}
317 
 
 361 
 
318 
 
 - 
 
319 
#-------------------------------------------------------------------------------
 362 
#-------------------------------------------------------------------------------
320 
# Function        : QuoteCommand
 363 
# Function        : QuoteCommand
321 
#
 364 
#
322 
# Description     : Return a string command that is quoted
 365 
# Description     : Return a string command that is quoted
323 
#                   Do not quote empty elements
 366 
#                   Do not quote empty elements
- 
 
 367 
#                   Don't quote if already quoted
- 
 
 368 
#                   Handle embedded quotes
324 
#
 369 
#
325 
# Inputs          : Array of element to quote
 370 
# Inputs          : Array of element to quote
326 
#
 371 
#
327 
# Returns         : A string
 372 
# Returns         : A string or an array
- 
 
 373 
#                   Try to keep as an array
328 
#
 374 
#
329 
sub QuoteCommand
 375 
sub QuoteCommand
330 
{
 376 
{
331 
    my $cmd = '';
 377 
    my @cmd;
- 
 
 378 
    foreach ( @_ )
- 
 
 379 
    {
- 
 
 380 
        next unless ( defined $_);             # Ignore empty
- 
 
 381 
        next if ( $_ eq '' );
- 
 
 382 
 
- 
 
 383 
        if ( m~^"(.+)"$~ )                      # Ignore already quoted
- 
 
 384 
        {
- 
 
 385 
            push @cmd, $_;
- 
 
 386 
            next;
- 
 
 387 
        }
- 
 
 388 
 
- 
 
 389 
        my $data = $_;                          # Escape embedded "
- 
 
 390 
        $data =~ s~"~\\"~g;
- 
 
 391 
        push @cmd, '"' . $data . '"';           # Quote the argument
- 
 
 392 
    }
- 
 
 393 
 
- 
 
 394 
    #
- 
 
 395 
    #   Attempt to keep it as an array
- 
 
 396 
    #
- 
 
 397 
    return (wantarray) ? @cmd : join (' ', @cmd);
- 
 
 398 
}
- 
 
 399 
 
- 
 
 400 
#-------------------------------------------------------------------------------
- 
 
 401 
# Function        : EsacpeCommand
- 
 
 402 
#
- 
 
 403 
# Description     : Esacpe input commands
- 
 
 404 
#                   Must handle:
- 
 
 405 
#                       Embedded "
- 
 
 406 
#                   Doesn't (yet) handle embedded \
- 
 
 407 
#
- 
 
 408 
# Inputs          : Array of elements to process
- 
 
 409 
#
- 
 
 410 
# Returns         : Return an escaped string
- 
 
 411 
#
- 
 
 412 
sub EsacpeCommand
- 
 
 413 
{
332 
    my $pad = '';
 414 
    my @cmd;
- 
 
 415 
 
333 
    foreach  ( @_ )
 416 
    foreach ( @_ )
334 
    {
 417 
    {
- 
 
 418 
        my $data = $_;
335 
        next unless ( $_ );
 419 
        next unless ( $data );
336 
        $cmd .= $pad . '"' . $_ . '"';
 420 
        $data =~ s~"~\\"~g;
337 
        $pad = ' ';
 421 
        push @cmd, $data;
338 
    }
 422 
    }
339 
    return $cmd;
 423 
    return join (' ', @cmd);
340 
}
 424 
}
341 
 
 425 
 
- 
 
 426 
 
342
427
343 
1;
 428 
1;
344 
 
 429