Subversion Repositories DevTools

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

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