Subversion Repositories DevTools

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

# 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( rmlitter

              rm_opr

              rm_rf

              rm_f

              mkpath

              printenv

              printargs

              echo

              copyDir

              unCopyDir

            );

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 cleanup

        if ($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 variable

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

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