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;