Rev 6423 | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### COPYRIGHT - VIX IP PTY LTD ("VIX"). 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.## InitFileUtils - Call to init globals - after CWD has been setup# 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 - Generate a Path that can be displayed# FileCreate - Create a simple text file# FileAppend - Append to a simple text file# TagFileMatch - Simple (oneline) file content matcher# TagFileRead - Return the contents of the tagfile# RmDirTree - Remove a directory tree# CatPaths - Concatenate Paths# ValidatePath - Validate directory is sane and within package# ReExported# catdir - Concatenate path elements# catfile - Concatenate path elements and a file# mkpath - Create path elements##......................................................................#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( InitFileUtilsGetcwdRealpathRelPathAbsPathFullPathCleanPathStripDriveStripDirStripExtStripFileStripFileExtStripDirExtCleanDirNameTouchFileFileIsNewerDisplayPathTruePathFileCreateFileAppendTagFileMatchTagFileReadRmDirTreeCatPathscatfilecatdirmkpathValidatePath$ScmPathSep$ScmDirSep$Cwd$CwdFull$CwdDrive$ScmHost);## exported package globals go here#our $ScmPathSep; # Windows/Unix path seperatorour $ScmDirSep; # Windows/Unix dir sepour $Cwd ; # Current directory ( no drive letter )our $CwdFull ; # Current directory ( with drive letter )our $CwdDrive ; # Current driveour $ScmHost ; # Host Type. Unix, WIN## Internal variables#our $isCygWin; # Running under CygWinour $isUnix; # Is Unix#-------------------------------------------------------------------------------# Function : BEGIN## Description : Determine some values very early##BEGIN{$ScmHost = "Unix"; # UNIX, defaultDebug( "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 letterif ( ! $isUnix );$Cwd = StripDrive( $CwdFull ); # With drive spec stripedDebug ("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", 'Path :' . $name) 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 : TagFileMatch## Description : Test the contents of a simple (one line) file against a string## Inputs : $tfile - Name of the tag file# $tag - Tag to match## Returns : True - is a match#sub TagFileMatch{my ($tfile, $tag) = @_;return 0 unless -f $tfile;open( my $file, '<', $tfile) || return 0;my $text = <$file>;close $file;$text = '' unless defined ($text);# Remove trailing new line and white space$text =~ s~\s*$~~;Debug("TagFileMatch:'$text':'$tag'", $text eq $tag );return $text eq $tag;}#-------------------------------------------------------------------------------# Function : TagFileRead## Description : Read the contents of a simple (one line) file against a string## Inputs : $tfile - Name of the tag file## Returns : One line of the file#sub TagFileRead{my ($tfile) = @_;return "" unless -f $tfile;open( my $file, '<', $tfile) || Error("Cannot open '$tfile'. $!");my $text = <$file>;close $file;$text = '' unless defined ($text);$text =~ s~\s*$~~;return $text;}#-------------------------------------------------------------------------------# 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) = @_;unless (defined $base){DebugTraceBack ('RelPath');Error ("Internal: 'RelPath(). base not defined'");}$here = $Cwd unless ( defined $here );$here = $CwdDrive . $here if ( $base =~ m~^\w+:/~ && $here !~ m~^\w+:/~);my @base = split ('/', $base );my @here = split ('/', $here );my $result;Debug("RelPath: Here : $here");Debug("RelPath: Source: $base");# Not absolute - just return itreturn $base unless ( $base =~ m~^/~ || $base =~ m~^\w+:/~ );## 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;unless (defined $dpath){DebugTraceBack ();Error ("Internal: 'AbsPath(). dpath not defined'");}## 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 . '/' . $dpathunless ( $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) = @_;Debug("TruePath: $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)} ){Verbose2( "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");}Verbose2 ("TruePath: $TrueComponent");return $TrueComponent;}#-------------------------------------------------------------------------------# Function : CleanPath## Description : Cleanup a path# Remove xxx/.. constructs# Replace /./ constructs with /## 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 delimiter#$dpath =~ s~\\~/~g;$dpath =~ s~^\./~~g;$dpath =~ s~/\./~/~g;$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 );$result = '.' unless $result;Debug("CleanPath: Result: $result");return $result;}#-------------------------------------------------------------------------------# Function : CatPaths## Description : Join path elemanets together with a '/'# Clean up the result## Inputs : Patth elemenst to join## Returns : Cleaned up path elements#sub CatPaths{my @paths = grep defined , @_;Debug("CatPaths: ", @paths );return CleanPath join ('/', @paths );}#-------------------------------------------------------------------------------# 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 specif ( ! $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 namemy( $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 extensionif ("$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 namemy( $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);eval { rmtree( $path ); };}}return ( -e $path );}#-------------------------------------------------------------------------------# Function : ValidatePath## Description : Ensure that the user provided path does not escape the current# package and is sane## Inputs : $path - One path to validate# $mode - 0 : No sanity test (only escape test)# 1 : Abs path not allowed# 2 : Parent directory not allowed# 4 : Path must exist# Mode options are bit mask and may be combined## Returns : Array:# - Clean pathname (unless error)# - Error message#sub ValidatePath{my ($path, $mode) = @_;Error("Internal: ValidatePath. ProjectBase not known" ) unless defined $::ProjectBase;Debug("ValidatePath. $::ProjectBase, $path, $mode");my $errPath = $path;$path = CleanPath($path);if ($mode & 1 && $path =~ m~^/~ ) {return $errPath, 'Absolute path not allowed';}$path =~ s~^/~~;if ($mode & 2 && $path =~ m~^[./]+$~ ) {return $errPath, 'Parent directory not allowed';}if ($mode & 4 && ! -d $path ) {return $errPath, 'Directory does not exist';}my $dirFromBase = RelPath(AbsPath($path), AbsPath($::ProjectBase));if ( $dirFromBase =~ m~\.\.~ ) {Debug("ProjectBase:", AbsPath($::ProjectBase));Debug("User Path :", AbsPath($path));return $errPath, 'Path outside the current package';}return $path;}1;