########################################################################
# Copyright ( C ) 2005 ERG Limited, All rights reserved
#
# Module name   : jats.sh
# Module type   : Perl Package
# Compiler(s)   : n/a
# Environment(s): jats
#
# Description   : This package contains functions to manipulate file paths
#                 directories and names.
#
#                    Getcwd                     - Get current directory
#                    Realpath                   - Get real path
#                    Realfile                   - Get real path ?
#                    RelPath                    - Convert to relative path
#                    AbsPath                    - Convert to Abs path
#                    FullPath                   - Convert to Abs path with driver letter
#                    TruePath                   - Case Corrected pathname
#                    CleanPath                  - Clean up a path
#                    StripDrive                 - Remove drive letter
#                    StripDir                   - Return file + extension
#                    StripExt                   - Return dir + file
#                    StripFile                  - Returns extension
#                    StripFileExt               - Returns directory
#                    StripDirExt                - Returns filename ( with optional ext)
#                    CleanDirName               - Clean up a path
#                    TouchFile                  - Touch a file
#                    FileIsNewer                - Test if newer
#                    DisplayPath                - Genate a Path that can be displayed
#                    FileCreate                 - Create a simple text file
#                    FileAppend                 - Append to a simple text file
#                    RmDirTree                  - Remove a directory tree
#           ReExported
#                    catdir                     - Concatenate path elements
#                    catfile                    - Concatenate path elements and a file
#
#......................................................................#

use 5.006_001;
use strict;
use warnings;

################################################################################
#   Global variables used by functions in this package
#   For historical reasons many of these variabeles are global
#

package FileUtils;
use base qw(Exporter);
use File::Path;
use File::Spec::Functions;

use JatsError;
use Cwd;
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);

$VERSION = 1.00;

# Symbols to autoexport (:DEFAULT tag)
@EXPORT = qw(   InitFileUtils
                Getcwd
                Realpath
                RelPath
                AbsPath
                FullPath
                CleanPath
                StripDrive
                StripDir
                StripExt
                StripFile
                StripFileExt
                StripDirExt
                CleanDirName
                TouchFile
                FileIsNewer
                DisplayPath
                TruePath
                FileCreate
                FileAppend
                RmDirTree
                catfile
                catdir

                $ScmPathSep
                $ScmDirSep
                $Cwd
                $CwdDrive
                $ScmHost
            );
#
# exported package globals go here
#
our $ScmPathSep;                # Windows/Unix path seperator
our $ScmDirSep;                 # Windows/Unix dir sep
our $Cwd       ;                # Current directory ( no drive letter )
our $CwdFull   ;                # Current directory ( with drive letter )
our $CwdDrive  ;                # Current drive
our $ScmHost   ;                # Host Type. Unix, WIN

#
#   Internal variables
#
our  $isCygWin;                 # Running under CygWin
our  $isUnix;                   # Is Unix
            
#-------------------------------------------------------------------------------
# Function        : BEGIN
#
# Description     : Determine some values very early
#
#
BEGIN
{
    $ScmHost = "Unix";                                # UNIX, default

    Debug( "PerlHost:  $^O" );
    $ScmHost = "DOS"      if ($^O eq "win95");        # DOS Perl dependent
    $ScmHost = "WIN"      if ($^O eq "MSWin32");      # ActivePerl
    $ScmHost = "WIN"      if ($^O eq "cygwin");       # Cygwin

    $isUnix = ( $ScmHost eq "Unix"  ) ? 1 : 0;
    $isCygWin = ( $ENV{'SHELL'} || $ENV{'CYGWIN'} ) ? 1 : 0;

    $ScmPathSep = $isUnix ? ':' : ';';     # Unix / Windows
    $ScmDirSep = $isUnix ? '/' : '\\';     # Unix / Windows
}

#-------------------------------------------------------------------------------
# Function        : InitFileUtils
#
# Description     : Initialise this package
#                   This function should be called once the user has determined
#                   settled on a working directory
#
#                   The function may be called multiple times
#                   to allow various globals to be reset - when the user has
#                   changed directory
#
# Inputs          : Nothing
#
# Returns         : Nothing
#
sub InitFileUtils
{
    #
    #   Setup current directory and drive
    #

    $CwdFull = Getcwd();                    # Current working dir

    $CwdDrive = '';
    $CwdDrive = substr( $CwdFull, 0, 2 )    # Saved Drive letter
        if ( ! $isUnix );

    $Cwd = StripDrive( $CwdFull );          # With drive spec striped

    Debug ("InitFileUtils: ScmHost     : $ScmHost");
    Debug ("InitFileUtils: CwdFull     : $CwdFull");
    Debug ("InitFileUtils: Cwd         : $Cwd");
    Debug ("InitFileUtils: CwdDrive    : $CwdDrive");
    Debug ("InitFileUtils: ScmPathSep  : $ScmPathSep");
}


#-------------------------------------------------------------------------------
# Function        : Getcwd
#
# Description     : Retrieve current working directory
#
# Inputs          : None
#
# Returns         : The current working directory
#
# Notes           : Don't use 'pwd' program as it gets symbolic links wrong
#
sub Getcwd
{
    my $cwd = getcwd();
    return $cwd;
}

#-------------------------------------------------------------------------------
# Function        : TouchFile 
#
# Description     : touch a file
#                   Real use is to touch a marker file
#
# Inputs          : path        - path to the file
#
# Returns         : TRUE if an error occured in creating the file
#
sub TouchFile
{
    my ($path, $text) = @_;
    my $result = 0;
    my $tfh;

    Verbose ("Touching file: $path" );
    if ( ! -f $path )
    {
        open ($tfh, ">>", $path) || ($result = 1);
        close $tfh;
    }
    else
    {

        #
        #   Modify the file
        #
        #   Need to physically modify the file
        #   Need to change the 'change time' on the file. Simply setting the
        #   last-mod and last-access is not enough to get past WIN32
        #   OR 'utime()' does not work as expected
        #
        #   Read in the first character of the file, rewind and write it
        #   out again.
        #
        my $data;
        open ($tfh , "+<", $path ) || return 1;
        if ( read ( $tfh, $data, 1 ) )
        {
            seek  ( $tfh, 0, 0 );
            print $tfh $data;
        }
        else
        {
            #
            #   File must have been of zero length
            #   Delete the file and create it
            #
            close ($tfh);
            unlink ( $path );
            open ($tfh, ">>", $path) || ($result = 1);
        }
        close ($tfh);
    }
    return $result;
}

#-------------------------------------------------------------------------------
# Function        : FileCreate
#                   FileAppend
#                   _FileWrite
#
# Description     : Simple Text File Creation function
#                   Suited to the creation of small, simple text files.
#
# Inputs          : Name of the file
#                   Remainder are:
#                       Lines of data to output to the file
#                       Or a reference to an array of lines
#                       Or a mixture
#                   All lines will be terminated with a "\n"
#
# Returns         : Nothing
#
sub FileCreate
{
    _FileWrite ( '>', @_ );
}

sub FileAppend
{
    _FileWrite ( '>>', @_ );
}

sub _FileWrite
{
    my $mode = shift @_;
    my $name = shift @_;
    my $fh;

    Error ("FileCreate: No file specified") unless ( $name );
    Error ("FileCreate: Path is directory") if ( -d $name );

    open  ($fh, $mode, $name ) || Error( "Cannot create file: $name", "Reason: $!" );

    foreach my $entry ( @_ ) {
        if ( ref ($entry ) eq 'ARRAY'  ) {
            print $fh $_ . "\n" foreach  ( @$entry );
        } else {
            print $fh $entry . "\n"
        }
    }
    close $fh;
}

#-------------------------------------------------------------------------------
# Function        : FileIsNewer
#
# Description     : Test two files to see if the files are newer
#
# Inputs          : file1
#                   file2
#
# Returns         : Returns true if file1 is newer than file2 or file2 does not
#                   exist.
#
#                   If file 1 does not exist then it will return false
#
sub FileIsNewer
{
    my ($file1, $file2) = @_;

    my $f1_timestamp = (stat($file1))[9] || 0;
    my $f2_timestamp = (stat($file2))[9] || 0;
    my $result = $f1_timestamp > $f2_timestamp ? 1 : 0;

    Verbose2 ("FileIsNewer: TS: $f1_timestamp, File: $file1");
    Verbose2 ("FileIsNewer: TS: $f2_timestamp, File: $file2");
    Verbose2 ("FileIsNewer: $result" );

    return $result;
}

#-------------------------------------------------------------------------------
# Function        : Realpath
#
# Description     : Returns the 'real path'
#
# Inputs          : $path       - Path to process
#
# Returns         : The real path
#
sub Realpath
{
    my( $path ) = @_;
    my( $real, $cwd );

    $cwd = Getcwd();
    if (!chdir( $path )) {
        $real = "";
    } else {
        $real = Getcwd();
        Error ("FATAL: Realpath($path) could not restore directory ($cwd)." )
            unless (chdir( $cwd ));
    }
    Debug( "Realpath:   = $real ($path)" );
    return $real;
}

#-------------------------------------------------------------------------------
# Function        : Realfile
#
# Description     : Returns the 'real path'
#
# Inputs          : $path       - Path to process
#
# Returns         : The real path
#
#sub Realfile
#{
#    my( $path ) = @_;
#    my( $real, $cwd );
#
#    $cwd = Getcwd();
#    if (!chdir( $path )) {
#        $real = "";
#    } else {
#        $real = Getcwd();
#        Error ("FATAL: Realpath($path) could not restore directory ($cwd)." )
#            unless (chdir( $cwd ));
#    }
#    Debug( "Realpath:   = $real ($path)" );
#    return $real;
#}

#-------------------------------------------------------------------------------
# Function        : RelPath
#
# Description     : Return the relative path to the current working directory
#                   as provided in $Cwd
#
# Inputs          : $base       - Base directory to convert
#                                 Expected to be well formed absolute path
#                   $here       - Optional current directory
#                                 Expected to be well formed absolute path
#                                 $Cwd will be used if non provided
#
# Returns         : Relative path from the current directory to the base directory
#
sub RelPath
{
    my ($base, $here) = @_;

    $here = $Cwd unless ( defined $here );
    my @base = split ('/', $base );
    my @here = split ('/', $here );
    my $result;

    Debug("RelPath: Here  : $here");
    Debug("RelPath: Source: $base");

    # Not absolute - just return it
    return $base unless ( $base =~ m~^/~ );
    
    #
    #   Remove common bits from the head of both lists
    #
    while ( $#base >= 0 && $#here >= 0 && $base[0] eq $here[0] )
    {
        shift @base;
        shift @here;
    }

    #
    #   Need to go up some directories from here and then down into base
    #
    $result = '../' x ($#here + 1);
    $result .= join ( '/', @base);
    $result = '.' unless ( $result );
    $result =~ s~/$~~;

    Debug("RelPath: Result: $result");
    return $result;
}

#-------------------------------------------------------------------------------
# Function        : AbsPath
#
# Description     : Return the absolute path to the file
#                   Add the current directory if the path is absolute
#                   Clean up xxx/.. constructs
#
#                   If an absolute path is provided then it will simply be
#                   cleaned up.
#
# Assumption      : Absolute paths start with a "/" and do not have a drive letter
#
# Inputs          : $dpath      - Source file path
#                   $here       - Optional current directory
#                                 $Cwd will be used if non provided
#                   $mode       - Defined: No error
#                                 Used during error reporting
#
# Returns         : Cleaned abs path
#
sub AbsPath
{
    my ($dpath, $here, $mode) = @_;
    my @result;

    #
    #   If we have a relative path then prepend the current directory
    #   An absolute path is:
    #           /aaa/aa/aa
    #       or  c:/aaa/aa/aa
    #
    $here = $Cwd unless ( defined $here );
    $here =~ s~^\w:~~;
    $dpath = $here . '/' . $dpath
        unless ( $dpath =~ m~^/|\w:[/\\]~  );
    $dpath =~ s~//~/~g;

    #
    #   Walk the bits and remove ".." directories
    #       Done by pushing non-.. elements and poping last entry for .. elements.
    #   Have a leading "/" which is good.
    #
    foreach ( split ( '/', $dpath ) )
    {
        next if ( $_ eq '.' );
        unless ( $_ eq '..' )
        {
            push @result, $_;
        }
        else
        {
            if ( $#result <= 0 )
            {
                Error ("Bad Pathname: $dpath") unless ( $mode );
                return $dpath;
            }
            else
            {
                pop @result;
            }
        }
    }

    #
    #   Create a nice directory name again.
    #
    return join ( '/', @result );
}

#-------------------------------------------------------------------------------
# Function        : FullPath
#
# Description     : Return the absolute path to the file - with driver letter
#                   Add the current directory if the path is absolute
#                   Clean up xxx/.. constructs
#
#                   If an absolute path is provided then it will simply be
#                   cleaned up.
#
# Inputs          : Source file path
#                   $here       - Optional current directory
#                                 $Cwd will be used if non provided
#
# Returns         : Cleaned abs path
#
sub FullPath
{
    my $path = AbsPath (@_ );
    $path = $CwdDrive . $path unless ( $path =~ m~^\w:~  );
    return $path;
}

#-------------------------------------------------------------------------------
# Function        : TruePath
#
# Description     : Returns a case correct pathname
#                   Really only applicable to windows, under unix it returns
#                   its input path.
#
#                   Maintains a cache to speed up processing
#
# Inputs          : Confused path (Absolute with a driver letter)
#
# Returns         : Case Correct Path : Windows
#                   Input Path : Non Windows
#
my %TruePathCache;
my %DirRead;
sub TruePath
{
    my ($path) = @_;
    $path =~ tr~\\/~/~s;

    #
    #   On Unix systems the path is case sensitive to start with
    #   Can't get it wrong - can't do anything.
    #
    return $path if ( $isUnix );

    #
    #   If the path does not exist at all then return the user input
    #   Assume that the user will handle this later
    #
    unless ( -e $path )
    {
        Warning ("TruePath given invalid path: $path");
        return $path;
    }

    #
    #   Look in the cache - have we seen this before
    #
    if ( exists $TruePathCache{lc($path)} )
    {
        Verbose( "TruePath Cache Hit: $path");
        return $TruePathCache{lc($path)};
    }

    #
    #   Split the directory into components
    #
    my $TrueComponent = '';
    my @components = split ('/', $path );
    foreach my $elem ( @components )
    {
        Debug ("Process: $elem in $TrueComponent");
        my $tag;
        #
        #   Handle driver letter
        #
        if ( $elem =~ m~^[a-zA-Z]:$~ )
        {
            $elem = uc($elem);
            $TrueComponent = $elem;

            $tag = lc($TrueComponent);
            $TruePathCache{$tag} = $elem;
            Debug ("     Add: $elem");
            next;
        }

        #
        #   Ensure that we have read in containing directory
        #   Note: Append / to ensure we read root directories correctly
        #
        $TrueComponent .= '/';
        unless ( $DirRead{ $TrueComponent }  )
        {
            Debug ("Reading: $TrueComponent");
            opendir (my $tp, $TrueComponent ) or Error ("Cannot open $TrueComponent");
            my @dirlist = readdir $tp;
            closedir $tp;
            $DirRead {$TrueComponent } = 1;

            #
            #   Add cache entries for each path in the directory
            #
            foreach my $dir ( @dirlist )
            {
                next if ( $dir eq '.' );
                next if ( $dir eq '..' );
                my $fullpath = $TrueComponent . $dir;
                Debug ("     Add: $fullpath");
                $TruePathCache{lc($fullpath)} = $fullpath;
            }
        }

        #
        #   Now that we have populated the cache with data from the directory
        #   we can expect to find our desired entry in the cache.
        #
        $tag = lc($TrueComponent . $elem );
        if ( exists $TruePathCache{ $tag } )
        {
            $TrueComponent = $TruePathCache{ $tag };
        }
        else
        {
            DebugDumpData ("Cache", \%TruePathCache);
            Error ("TruePath Internal error. File may have been deleted: $tag");
        }
        Debug ("Have: $TrueComponent");
    }

    Verbose ("TruePath: $TrueComponent");
    return $TrueComponent;
}

#-------------------------------------------------------------------------------
# Function        : CleanPath
#
# Description     : Cleanup a path
#                   Remove xxx/.. constructs
#
# Note            : Will not perform error detection on badly formed
#                   absolute paths.
#
# Inputs          : Source file path
#
# Returns         : Clean absolute or relative path
#
#
sub CleanPath
{
    my ($dpath) = @_;
    my @result;
    Debug("CleanPath: Source: $dpath");

    #
    #   Cleanup the the user input. Remove double delimiters and ensure there
    #   is no trailing delemiter
    #
    $dpath =~ s~/+~/~g;
    $dpath =~ s~/$~~g;

    #
    #   Walk the bits and remove "xxx/.." directories
    #
    foreach ( split ( '/', $dpath ) )
    {
        if ( $_ ne '..' || $#result < 0 )
        {
            push @result, $_;
        }
        else
        {
            if ( $#result >= 0 )
            {
                my $last_dir = pop @result;
                push (@result, $last_dir, $_)
                    if ($last_dir eq '..' || $last_dir eq '');
            }
        }
    }

    my $result = join ( '/', @result );
    Debug("CleanPath: Result: $result");
    return $result;
}

#-------------------------------------------------------------------------------
# Function        : StripDrive
#
# Description     : Strip any leading drive speification
#
# Inputs          : $fname          - Path to process
#
# Returns         : Path, with drive letter stripped
#                   Will do nothing on Unix systems
#
sub StripDrive
{
    my( $fname ) = @_;                          # Full name

    $fname =~ s/^[A-Za-z]://g                  # leading drive spec
        if ( ! $isUnix );
    return $fname;
}

#-------------------------------------------------------------------------------
# Function        : StripDir
#
# Description     : Strip directory (returns file, including extension)
#
# Inputs          : $fname          - Path to process
#
# Returns         : filename + extension
#
sub StripDir
{
    my( $fname ) = @_;                          # Full name
    my( $idx );

    if (($idx = rindex($fname, "/")) == -1) {
        if (($idx = rindex($fname, "\\")) == -1) {
            return $fname;                      # No path ...
        }
    }
    return substr($fname, $idx+1, 512);
}

#-------------------------------------------------------------------------------
# Function        : StripExt
#
# Description     : Strip extension (return basename, plus any dir)
#
# Inputs          : $fname          - Path to process
#
# Returns         : basename, plus any dir
#                   Simply removes one extension
#
sub StripExt
{
    my( $fname ) = @_;

    $fname =~ s/(\S+)(\.\S+)/$1/;               # strip out trailing '.<ext>'
    return ($fname);
}

#-------------------------------------------------------------------------------
# Function        : StripFile
#
# Description     : Strip filename (returns extension)
#
# Inputs          : $fname          - Path to process
#
# Returns         : extension
#                   Will return an empty string if the input does not have an
#                   extension.
#
sub StripFile
{
    my( $fname ) = @_;

    $fname =~ s/(\S+)(\.\S+)/$2/;               # Strip out items before '.<ext>'
    return ("")                                 # No extension
        if ("$fname" eq "@_");
    return ($fname);
}

#-------------------------------------------------------------------------------
# Function        : StripFileExt
#
# Description     : Strip filename and ext (returns dir)
#
# Inputs          : $fname          - Path to process
#
# Returns         : Directory of a file path
#


#   StripFileExt( path ) ---
#       Strip filename and ext (returns dir)
#..

sub StripFileExt
{
    my( $fname ) = @_;                          # Full name
    my( $idx );
    my $dir;

    if (($idx = rindex($fname, "/")) == -1) {
        if (($idx = rindex($fname, "\\")) == -1) {
            return "";                          # No path ...
        }
    }

    return substr($fname, 0, $idx);
}

#-------------------------------------------------------------------------------
# Function        : StripDirExt
#
# Description     : Strip the directory and extension from a file
#                   Returning the base file. Optionally replace the extension
#                   with a user value
#
# Inputs          : Full path name
#                   Optional extension to be replaced
#
# Returns         :
#
sub StripDirExt
{
    my ($fname, $ext ) = (@_, '');
    $fname =~ s~.*[/\\]~~;                      # Strip directory
    $fname =~ s/\.[^.]+$/$ext/;
    return $fname;
}


#-------------------------------------------------------------------------------
# Function        : CleanDirName
#
# Description     : Clean up a directory path string
#                       1) Remove multiple //
#                       2) Remove multiple /./
#                       2) Remove leading ./
#                       3) Remove trailing /
#                       4) Remove /xxxx/../
#
# Inputs          : A dirty directory path
#
# Returns         : A clean directory path
#
sub CleanDirName
{
    my ( $dir ) = @_;
    $dir =~ s~//~/~g;                   # Kill multiple //
    $dir =~ s~/\./~/~g;                 # Kill multiple /./
    $dir =~ s~^\./~~;                   # Kill leading ./
    $dir = '.' unless ( $dir );         # Ensure we have a path

    #
    #   Remove /xxxxx/../ bits
    #
    unless ( $dir =~ m~^\.\./~  )
    {
        while ( $dir =~ s~
                        (^|/)               # Allow for stings that may not start with a /
                        [^/]+/\.\.          # xxxxx/.., where xxxx is anything other than a /
                        (/|$)               # Allow for strings ending with /..
                        ~$1~x               # Replace with the start character
              )
        {
            last if ( $dir =~ m~^\.\./~ );  # Too far. Stop now !
        }
    }

    $dir =~ s~/$~~;                     # No trailing /
    $dir =~ s~/\.$~~;                   # No trailing /.
    return $dir;
}

#-------------------------------------------------------------------------------
# Function        : DisplayPath
#
# Description     : Cleanup a path for display purposes
#                   Useful under windows to provide paths with \ that can be
#                   cut and pasted.
#
#                   If cygwin is located in the environment, then this function
#                   will not convert / to \.
#
# Inputs          : A path to modify
#
# Returns         : Modified path
#
sub DisplayPath
{
    my ($path) = @_;
    if ( ! $isUnix && ! $isCygWin )
    {
        $path =~ s~/~\\~g;
    }
    else
    {
        $path =~ s~\\~/~g;
    }
    return $path;
}

#-------------------------------------------------------------------------------
# Function        : RmDirTree
#
# Description     : Delete a directory tree
#                   Really delete it. Allow for users to remove directory
#                   without search permissions under unix.
#
#                   Can also delete a file
#
#                   This function has a bit of history
#                   I've tried the Perl rmtree(), but there were situations
#                   where the OS(WIN32) says the directory exists after its been
#                   deleted. Also the Jats-Win32 version of chmod would issue
#                   messages if it couldn't find the dir/file.
#
#                   The solution is to use JATS' own JatsFileUtil utility
#                   This appears to do the right thing
#
# Inputs          : $path                   - Path to directory
#                                             May be empty, in which case nothing is done
#
# Returns         : 1                       - Still there
#
sub RmDirTree
{
    my ($path) = @_;
    return 0 unless $path;
    if ( -e $path )
    {
        #  Need to know if its a file or a directory
        #
        my $mode = ( -d $path ) ? 'T' : 'r';

        #
        #   Use JATS's own utility to do the hardwork
        #   Used as it address a number of issues
        #
        #   Merge in verbosity
        #
        system ("$ENV{GBE_BIN}/JatsFileUtil", $mode . $::ScmVerbose, '', $path );

        #
        #   Shouldn't happen but ...
        #   If the path still exists try another (one this has known problems)
        #
        if ( -e $path )
        {
            Verbose3 ("RmDirTree: Directory still exists. Change permissions: $path");
            system ("$ENV{GBE_BIN}/chmod", '-R', 'u+wrx', $path);
            rmtree( $path );
        }
    }
    return ( -e $path );
}

1;