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