Subversion Repositories DevTools

########################################################################
# Copyright (C) 2007 ERG Limited, 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_rf
              rm_f
              mkpath
              printenv
              printargs
            );

use File::Path qw(rmtree);

#BEGIN
#{
#    print "-------jats_runtime initiated\n";
#}

#-------------------------------------------------------------------------------
# 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
{
    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 )
            {
                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
{
    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
#
# Inputs          : @ARGV       - A list of files to delete
#
# Returns         :
#
sub rm_f {
    expand_wildcards();

    foreach my $file (@ARGV) {
        next unless -f $file;

        next if _unlink($file);

        chmod(0777, $file);

        next if _unlink($file);
        Warning "Cannot delete $file: $!";
    }
}

#-------------------------------------------------------------------------------
# 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
{
    expand_wildcards();
    File::Path::mkpath([@ARGV],0,0777);
}

#-------------------------------------------------------------------------------
# Function        : _unlink
#
# Description     : Helper function
#                   Unlink a list of files
#
# Inputs          : A list of files to delete
#
# Returns         : The number of files that have been deleted
#
sub _unlink {
    my $files_unlinked = 0;

    foreach my $file (@_)
    {
        my $delete_count = 0;
        $delete_count++ while unlink $file;
        $files_unlinked++ if $delete_count;
    }
    return $files_unlinked;
}

#-------------------------------------------------------------------------------
# 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
#
my $PSPLIT=':';
sub printargs
{
    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;