Rev 6177 | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.## Module name : jats.sh# Module type : Makefile system# Compiler(s) : n/a# Environment(s): jats## Description : JATS Make Time Support# This package contains a collection of very useful functions# that are invoked by the JATS generated makefiles to perform# complicated operations at Make Time## The functions are designed to be invoked as:# $(GBE_PERL) -Mjats_runtime -e <function> -- <args>+## The functions in this packages are designed to take parameters# from @ARVG as this makes the interface easier to read.## This package is used to speedup and simplify the JATS builds# Speedup (under windows)# Its quicker to start up one perl instance than# to invoke a shell script that performs multiple commands# Windows is very slow in forking another task.## Simplify# Removes some of the complications incurred due to different# behaviour of utilities on different platforms. In particular# the 'rm' command## Perl is a better cross platform language than shell script# as we have greater control over the release of perl.##......................................................................#require 5.006_001;use strict;use warnings;package jats_runtime;our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);use Exporter;use JatsError qw(:name=jats_runtime);$VERSION = 1.00;@ISA = qw(Exporter);# Symbols to autoexport (:DEFAULT tag)@EXPORT = qw( rmlitterrm_oprrm_rfrm_fmkpathprintenvprintargsechocopyDirunCopyDir);use File::Path qw(rmtree);use JatsLocateFiles;use JatsSystem;our %opts;#BEGIN#{# print "-------jats_runtime initiated\n";#}#-------------------------------------------------------------------------------# Function : process_options## Description : Extract options from the front of the command stream# Stops at the first argument that doesn't start with a# '--'## Options of the form --Opt=Val are split out# Options of the form --Opt will set (or increment a value)## Inputs : None: Uses global ARGV## Returns : None: Resets global argv# Populates the %opts hash#sub process_options{while ( my $entry = shift @ARGV ){last if ( $entry eq '--' );if ( $entry =~ m/^--(.*)/ ){if ( $1 =~ m/(.*)=(.*)/ ){$opts{$1} = $2;}else{$opts{$1}++;}}else{unshift @ARGV, $entry;last;}}## Process some known options#$opts{'Verbose'} = $opts{'verbose'} if defined $opts{'verbose'};$opts{'Progress'} = $opts{'Verbose'} if ( $opts{'Verbose'} );ErrorConfig( 'name', $opts{Name}) if ( $opts{'Name'} );ErrorConfig( 'verbose', $opts{Verbose}) if ( $opts{'Verbose'} );DebugDumpData("RunTime Opts", \%opts ) if ( $opts{'ShowOpts'} );;Message ("RunTime args: @ARGV") if ( $opts{'ShowArgs'} );printenv() if ( $opts{'ShowEnv'} );Message ($opts{'Message'}) if ( $opts{'Message'} );}#-------------------------------------------------------------------------------# Function : rmlitter## Description : Remove litter from a build directory## Inputs : ARGV A list of files (with wildcards) to delete in the# current, and named, directories.## Options: -f File list follows (default)# -d Dir list follows## Example: *.err -d OBJ BIN# Will delete *.err OBJ/*.err BIN/*.err## Returns : 0#sub rmlitter{process_options();my @flist;my @dlist = '.';## Parse arguments# Collect filenames and dirnames. Switch between the two collection lists##my $listp = \@flist;foreach my $ii ( @ARGV ){if ( $ii eq '-f' ) {$listp = \@flist;} elsif ( $ii eq '-d' ) {$listp = \@dlist;} else {push @$listp, $ii;}}## Process all directories looking for matching files# Delete files#foreach my $dir ( @dlist ){foreach my $file ( @flist ){my $path = "$dir/$file";$path =~ s~ ~\\ ~g;my @del = glob ( $path );if ( @del ){Message ("rmlitter. @del") if ($opts{'Progress'} );chmod '777', @del;unlink @del;}}}}#-------------------------------------------------------------------------------# Function : expand_wildcards## Description : Expand argument wildcards# Replace @ARGV with an expanded list of files to process# This is a helper function### Inputs : @ARGV## Returns : @ARGV#sub expand_wildcards{## Replace spaces with escaped spaces to assist the 'glob'#sub escape_space{my ($item) = @_;$item =~ s~ ~\\ ~g;return $item;}@ARGV = map(/[*?]/o ? glob (escape_space($_)) : $_ , @ARGV);}#-------------------------------------------------------------------------------# Function : rm_rf## Description : Remove all files and directories specified## Inputs : @ARGV - A list of files and directories## Returns : Nothing#sub rm_rf{process_options();expand_wildcards();my @dirs = grep -e $_,@ARGV;if ( @dirs ){rmtree(\@dirs,0,0);}}#-------------------------------------------------------------------------------# Function : rm_f## Description : Remove all named files# Will not remove directores - even if named## Unix Note:# Need to handle broken soft links### Inputs : @ARGV - A list of files to delete## Returns :#sub rm_f {process_options();expand_wildcards();foreach my $file (@ARGV) {Message ("Delete: $file") if ($opts{'Progress'} );next if -d $file;next unless ( -e $file || -l $file );next if _unlink($file);Warning "Cannot delete $file: $!";}}#-------------------------------------------------------------------------------# Function : rm_opr## Description : Combo deletion operation# Parameter driven to delete many things in one command## Inputs : Options and paths# Options. Set mode for following paths# -f remove named file# -d remove named directory if empty# -rf remove directory or file# -fd remove file and directory if empty## Returns :#sub rm_opr{my $mode = '-f';process_options();foreach my $file (@ARGV) {if ( $file eq '-f' ) {$mode = $file;} elsif ( $file eq '-d' ) {$mode =$file;} elsif ( $file eq '-rf' ) {$mode =$file;} elsif ( $file eq '-fd' ) {$mode =$file;} elsif ( $file =~ m/^-/ ) {Error ("rm_opr - unknown option: $file");} else {## Not an option must be a file/dir to delete#if ( $mode eq '-f' ) {Message ("Delete File: $file") if ($opts{'Progress'} );_unlink($file);} elsif ( $mode eq '-d' ) {Message ("Delete Empty Dir: $file") if ($opts{'Progress'} );rmdir $file;} elsif ( $mode eq '-rf' ) {Message ("Delete Dir: $file") if ($opts{'Progress'} );rmtree($file,0,0);} elsif ( $mode eq '-fd' ) {Message ("Delete File: $file") if ($opts{'Progress'} );_unlink($file);my $dir = $file;$dir =~ tr~\\/~/~s;Message ("Remove Empty Dir: $dir") if ($opts{'Progress'} );if ( $dir =~ s~/[^/]+$~~ ){rmdir $dir;}}}}}#-------------------------------------------------------------------------------# Function : mkpath## Description : Create a directory tree# This will create all the parent directories in the path## Inputs : @ARGV - An array of paths to create## Returns :#sub mkpath{process_options();expand_wildcards();File::Path::mkpath([@ARGV],0,0777);}#-------------------------------------------------------------------------------# Function : copyDir## Description : Copy a directory tree# Used by PackageDir to perform run-time packaging## Inputs : @ARGV - Options# -mode=text# -src=path# -dst=path# -execute - Mark ALL as executable# -noSymlink# -noRecurse# -stripBase - Strip first dir from the source# -exclude+=filter# -include+=filter## Returns :#sub copyDir{my $copts = processCopyDirArgs('copyDir');return unless $copts;## Create the target directory if required#unless (-d $copts->{dst}) {Verbose("Create target directory: $copts->{dst}");File::Path::mkpath([$copts->{dst}],0,0777);}## Configure the use of the System function# Don't exit on error - assume used in unpackaging#SystemConfig ( UseShell => 0, ExitOnError => 0);## Calc mode#my $fmode = '';$fmode .= '+x' if defined $copts->{execute};$fmode .= '+l' unless defined $copts->{noSymlink};## Configure the use of the System function#SystemConfig ( UseShell => 0, ExitOnError => 1);## Travserse the source directory and copy files#my @elements = $copts->{search}->search ( $copts->{src} );## Transfer each file# Use the JatsFileUtil as it solves lots of problems# Its args are strange - Historic (long Story). Args:# 'c0' - Operation is Copy and debug level# 'Text' - Text message to display# DestPath# SrcPath# Modes - wxl## Do not get the shell involved in invoking the command# Quote args in '' not "" as "" will trigger shell usage##foreach my $file ( @elements){my $dst = $file;## Calc target path name#if ($copts->{stripBase}) {$dst = substr($dst, $copts->{stripBase} );}$dst = $copts->{dst} . '/' . $dst;## If the file exists, then only copy it if the src is newer#if (-f $dst) {my ($file1, $file2) = @_;my $f1_timestamp = (stat($file))[9] || 0;my $f2_timestamp = (stat($dst))[9] || 0;next unless ($f1_timestamp > $f2_timestamp );}System('JatsFileUtil', 'c0', $copts->{mode} , $dst, $file, $fmode);}}#-------------------------------------------------------------------------------# Function : unCopyDir## Description : Delete files copies with a copy dir command# Delete directories if they are empty# Used by PackageDir to perform run-time packaging## Inputs : @ARGV - Options# -mode=text# -src=path# -dst=path# -execute - Ignored# -noSymlink - Ignored# -noRecurse# -stripBase - Strip first dir from the source# -exclude+=filter# -include+=filter# -excludeRe+=filter# -includeRe+=filter### Returns :#sub unCopyDir{my %dirList;my $copts = processCopyDirArgs('UnCopyDir');return unless $copts;## Configure the use of the System function# Don't exit on error - assume used in unpackaging#SystemConfig ( UseShell => 0, ExitOnError => 0);## Nothing to do if the target directory does not exist#unless (-d $copts->{dst}) {Verbose("UnCopyDir: No target directory: $copts->{dst}");return;}## Travserse the source directory and find files that would have been copied#my @elements = $copts->{search}->search ( $copts->{src} );## Delete each file# Use the JatsFileUtil as it solves lots of problems# Its args are strange - Historic (long Story). Args:# 'd0' - Operation is Copy and debug level# 'Text' - Text message to display# DestPath## Do not get the shell involved in invoking the command# Quote args in '' not "" as "" will trigger shell usage##foreach my $file ( @elements){my $dst = $file;## Calc target path name#if ($copts->{stripBase}) {$dst = substr($dst, $copts->{stripBase} );}$dst = $copts->{dst} . '/' . $dst;## Only delete if the file exists#next unless (-f $dst);System('JatsFileUtil', 'd0', $copts->{mode}, $dst);# Save dir name for later cleanupif ($dst =~ s~/[^/]+$~~) {$dirList{$dst} = 1;}}## Delete all directories encountred in the tree - if they are empty# Only delete up the base of the target directory# Have a hash of directories - generated by the file deletion process# Extend the hash to include ALL subdirectoroy paths too#Verbose("Remove empty directories");foreach my $entry ( keys %dirList ) {while ($entry =~ s~/[^/]+$~~ ) {$dirList{$entry} = 2;}}my @dirList = sort { length $b <=> length $a } keys %dirList;foreach my $tdir ( @dirList ) {Verbose("Remove dir: $tdir");rmdir $tdir;}}#-------------------------------------------------------------------------------# Function : processCopyDirArgs## Description : Process the args for CopyDir and UnCopyDir so that the processing# is identical## Inputs : $cmdName - Command name# From ARGV## Returns : A hash containing# copts - Copy Options# search - For JatsLocateFiles# Empty if nothind to do#sub processCopyDirArgs{my ($cmdName) = @_;process_options();## Put the command line arguments into a hash# Allow:# aaa+=bbb - An array# aaa=bbb - Value# aaa - Set to one#my %copts;foreach (@ARGV) {if (m~-(.*)\+=(.*)~) {push @{$copts{$1}}, $2;} elsif (m~-(.*)?=(.*)~){$copts{$1} = $2;} elsif (m~-(.*)~) {$copts{$1} = 1;}}Message ("$cmdName Dir Tree: $copts{src} -> $copts{dst}") if ($opts{'Progress'} );## Ensure the source exists#Warning ("$cmdName: Source directory does not exists:" . $copts{src}) unless -d $copts{src};## Calc strip length#if ($copts{stripBase}) {$copts{stripBase} = 1 + length($copts{src});}## Set up the search options to traverse the source directory and find files# to process#my $search = JatsLocateFiles->new('FullPath' );$search->recurse(1) unless $copts{noRecurse};$search->filter_in_re ( $_ ) foreach ( @{$copts{includeRe}} );$search->filter_out_re( $_ ) foreach ( @{$copts{excludeRe}} );$search->filter_in ( $_ ) foreach ( @{$copts{include}} );$search->filter_out( $_ ) foreach ( @{$copts{exclude}} );$search->filter_out_re( '/\.svn/' );$search->filter_out_re( '/\.git/' );## Return a hash#$copts{search} = $search;return \%copts;}#-------------------------------------------------------------------------------# Function : _unlink## Description : Helper function# Unlink a list of files## Inputs : A file to delete## Returns : False: File still exists#sub _unlink {my ($file) = @_;if ( ! unlink $file ){chmod(0777, $file);return unlink $file;}return 1;}#-------------------------------------------------------------------------------# Function : printenv## Description :## Inputs :## Returns :#sub printenv{foreach my $entry ( sort keys %ENV ){print " $entry=$ENV{$entry}\n";}}#-------------------------------------------------------------------------------# Function : printargs## Description : Print my argumements## Inputs : User arguments## Returns : Nothing#sub printargs{Message "Arguments", @ARGV;}#-------------------------------------------------------------------------------# Function : echo## Description : echo my argumements## Inputs : User arguments## Returns : Nothing#sub echo{process_options();Message @ARGV;}#-------------------------------------------------------------------------------# Function : printArgsEnv## Description : Print my argumements nd environmen## Inputs : User arguments## Returns : Nothing#my $PSPLIT=':';sub printArgsEnv{Message "printargs....";Message "Program arguments", @ARGV;$PSPLIT = ';' if ( $ENV{GBE_MACHTYPE} eq 'win32' );sub penv{my ($var) = @_;pvar ($var, $ENV{$var} || '');}# Simple print of name and variablesub pvar{my ($text, $data) = @_;printf "%-17s= %s\n", $text, $data;}sub alist{my ($text, @var) = @_;my $sep = "=";for ( @var ){my $valid = ( -d $_ || -f $_ ) ? " " : "*";printf "%-17s%s%s%s\n", $text, $sep, $valid, $_;$text = "";$sep = " ";}}# Display a ';' or ':' separated list, one entry per linesub dlist{my ($text, $var) = @_;alist( $text, split $PSPLIT, $var || " " );}Message ("Complete environment dump");foreach my $var ( sort keys(%ENV) ){penv ($var);}dlist "PATH" , $ENV{PATH};exit (999);}1;