Subversion Repositories DevTools

Rev

Rev 6177 | Rev 6415 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
227 dpurdie 1
########################################################################
6177 dpurdie 2
# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.
227 dpurdie 3
#
4
# Module name   : jats.sh
5
# Module type   : Perl Package
6
# Compiler(s)   : n/a
7
# Environment(s): jats
8
#
9
# Description   : This package contains functions to manipulate file paths
10
#                 directories and names.
11
#
6177 dpurdie 12
#                    InitFileUtils              - Call to init globals - after CWD has been setup
227 dpurdie 13
#                    Getcwd                     - Get current directory
14
#                    Realpath                   - Get real path
15
#                    Realfile                   - Get real path ?
16
#                    RelPath                    - Convert to relative path
17
#                    AbsPath                    - Convert to Abs path
18
#                    FullPath                   - Convert to Abs path with driver letter
257 dpurdie 19
#                    TruePath                   - Case Corrected pathname
227 dpurdie 20
#                    CleanPath                  - Clean up a path
21
#                    StripDrive                 - Remove drive letter
22
#                    StripDir                   - Return file + extension
23
#                    StripExt                   - Return dir + file
24
#                    StripFile                  - Returns extension
25
#                    StripFileExt               - Returns directory
26
#                    StripDirExt                - Returns filename ( with optional ext)
27
#                    CleanDirName               - Clean up a path
261 dpurdie 28
#                    TouchFile                  - Touch a file
29
#                    FileIsNewer                - Test if newer
5486 dpurdie 30
#                    DisplayPath                - Generate a Path that can be displayed
261 dpurdie 31
#                    FileCreate                 - Create a simple text file
32
#                    FileAppend                 - Append to a simple text file
6133 dpurdie 33
#                    TagFileMatch               - Simple (oneline) file content matcher
34
#                    TagFileRead                - Return the contents of the tagfile
379 dpurdie 35
#                    RmDirTree                  - Remove a directory tree
6276 dpurdie 36
#                    CatPaths                   - Concatenate Paths            
4421 dpurdie 37
#           ReExported
38
#                    catdir                     - Concatenate path elements
39
#                    catfile                    - Concatenate path elements and a file
227 dpurdie 40
#
41
#......................................................................#
42
 
255 dpurdie 43
use 5.006_001;
227 dpurdie 44
use strict;
45
use warnings;
46
 
47
################################################################################
48
#   Global variables used by functions in this package
49
#   For historical reasons many of these variabeles are global
50
#
51
 
52
package FileUtils;
283 dpurdie 53
use base qw(Exporter);
361 dpurdie 54
use File::Path;
4309 dpurdie 55
use File::Spec::Functions;
283 dpurdie 56
 
227 dpurdie 57
use JatsError;
58
use Cwd;
283 dpurdie 59
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
227 dpurdie 60
 
61
$VERSION = 1.00;
62
 
63
# Symbols to autoexport (:DEFAULT tag)
64
@EXPORT = qw(   InitFileUtils
65
                Getcwd
66
                Realpath
67
                RelPath
68
                AbsPath
69
                FullPath
70
                CleanPath
71
                StripDrive
72
                StripDir
73
                StripExt
74
                StripFile
75
                StripFileExt
76
                StripDirExt
77
                CleanDirName
78
                TouchFile
79
                FileIsNewer
80
                DisplayPath
257 dpurdie 81
                TruePath
261 dpurdie 82
                FileCreate
83
                FileAppend
6133 dpurdie 84
                TagFileMatch
85
                TagFileRead
361 dpurdie 86
                RmDirTree
6276 dpurdie 87
                CatPaths
4309 dpurdie 88
                catfile
89
                catdir
227 dpurdie 90
 
91
                $ScmPathSep
261 dpurdie 92
                $ScmDirSep
227 dpurdie 93
                $Cwd
6276 dpurdie 94
                $CwdFull
227 dpurdie 95
                $CwdDrive
96
                $ScmHost
97
            );
98
#
99
# exported package globals go here
100
#
101
our $ScmPathSep;                # Windows/Unix path seperator
261 dpurdie 102
our $ScmDirSep;                 # Windows/Unix dir sep
227 dpurdie 103
our $Cwd       ;                # Current directory ( no drive letter )
247 dpurdie 104
our $CwdFull   ;                # Current directory ( with drive letter )
227 dpurdie 105
our $CwdDrive  ;                # Current drive
106
our $ScmHost   ;                # Host Type. Unix, WIN
107
 
108
#
109
#   Internal variables
110
#
4546 dpurdie 111
our  $isCygWin;                 # Running under CygWin
112
our  $isUnix;                   # Is Unix
227 dpurdie 113
 
114
#-------------------------------------------------------------------------------
115
# Function        : BEGIN
116
#
117
# Description     : Determine some values very early
118
#
119
#
120
BEGIN
121
{
122
    $ScmHost = "Unix";                                # UNIX, default
123
 
124
    Debug( "PerlHost:  $^O" );
125
    $ScmHost = "DOS"      if ($^O eq "win95");        # DOS Perl dependent
126
    $ScmHost = "WIN"      if ($^O eq "MSWin32");      # ActivePerl
127
    $ScmHost = "WIN"      if ($^O eq "cygwin");       # Cygwin
128
 
4546 dpurdie 129
    $isUnix = ( $ScmHost eq "Unix"  ) ? 1 : 0;
130
    $isCygWin = ( $ENV{'SHELL'} || $ENV{'CYGWIN'} ) ? 1 : 0;
227 dpurdie 131
 
132
    $ScmPathSep = $isUnix ? ':' : ';';     # Unix / Windows
261 dpurdie 133
    $ScmDirSep = $isUnix ? '/' : '\\';     # Unix / Windows
227 dpurdie 134
}
135
 
136
#-------------------------------------------------------------------------------
137
# Function        : InitFileUtils
138
#
139
# Description     : Initialise this package
140
#                   This function should be called once the user has determined
141
#                   settled on a working directory
142
#
143
#                   The function may be called multiple times
144
#                   to allow various globals to be reset - when the user has
145
#                   changed directory
146
#
147
# Inputs          : Nothing
148
#
149
# Returns         : Nothing
150
#
151
sub InitFileUtils
152
{
153
    #
154
    #   Setup current directory and drive
155
    #
156
 
247 dpurdie 157
    $CwdFull = Getcwd();                    # Current working dir
227 dpurdie 158
 
159
    $CwdDrive = '';
247 dpurdie 160
    $CwdDrive = substr( $CwdFull, 0, 2 )    # Saved Drive letter
227 dpurdie 161
        if ( ! $isUnix );
162
 
247 dpurdie 163
    $Cwd = StripDrive( $CwdFull );          # With drive spec striped
227 dpurdie 164
 
165
    Debug ("InitFileUtils: ScmHost     : $ScmHost");
247 dpurdie 166
    Debug ("InitFileUtils: CwdFull     : $CwdFull");
227 dpurdie 167
    Debug ("InitFileUtils: Cwd         : $Cwd");
168
    Debug ("InitFileUtils: CwdDrive    : $CwdDrive");
169
    Debug ("InitFileUtils: ScmPathSep  : $ScmPathSep");
170
}
171
 
172
 
173
#-------------------------------------------------------------------------------
174
# Function        : Getcwd
175
#
176
# Description     : Retrieve current working directory
177
#
178
# Inputs          : None
179
#
180
# Returns         : The current working directory
181
#
182
# Notes           : Don't use 'pwd' program as it gets symbolic links wrong
183
#
184
sub Getcwd
185
{
186
    my $cwd = getcwd();
187
    return $cwd;
188
}
189
 
190
#-------------------------------------------------------------------------------
261 dpurdie 191
# Function        : TouchFile 
227 dpurdie 192
#
193
# Description     : touch a file
194
#                   Real use is to touch a marker file
195
#
196
# Inputs          : path        - path to the file
197
#
198
# Returns         : TRUE if an error occured in creating the file
199
#
200
sub TouchFile
201
{
202
    my ($path, $text) = @_;
203
    my $result = 0;
283 dpurdie 204
    my $tfh;
205
 
227 dpurdie 206
    Verbose ("Touching file: $path" );
207
    if ( ! -f $path )
208
    {
283 dpurdie 209
        open ($tfh, ">>", $path) || ($result = 1);
210
        close $tfh;
227 dpurdie 211
    }
212
    else
213
    {
214
 
215
        #
216
        #   Modify the file
217
        #
218
        #   Need to physically modify the file
219
        #   Need to change the 'change time' on the file. Simply setting the
220
        #   last-mod and last-access is not enough to get past WIN32
221
        #   OR 'utime()' does not work as expected
222
        #
223
        #   Read in the first character of the file, rewind and write it
224
        #   out again.
225
        #
226
        my $data;
283 dpurdie 227
        open ($tfh , "+<", $path ) || return 1;
228
        if ( read ( $tfh, $data, 1 ) )
229
        {
230
            seek  ( $tfh, 0, 0 );
231
            print $tfh $data;
227 dpurdie 232
        }
233
        else
234
        {
235
            #
236
            #   File must have been of zero length
237
            #   Delete the file and create it
238
            #
283 dpurdie 239
            close ($tfh);
227 dpurdie 240
            unlink ( $path );
283 dpurdie 241
            open ($tfh, ">>", $path) || ($result = 1);
227 dpurdie 242
        }
283 dpurdie 243
        close ($tfh);
227 dpurdie 244
    }
245
    return $result;
246
}
247
 
248
#-------------------------------------------------------------------------------
261 dpurdie 249
# Function        : FileCreate
250
#                   FileAppend
251
#                   _FileWrite
252
#
253
# Description     : Simple Text File Creation function
254
#                   Suited to the creation of small, simple text files.
255
#
256
# Inputs          : Name of the file
257
#                   Remainder are:
258
#                       Lines of data to output to the file
259
#                       Or a reference to an array of lines
260
#                       Or a mixture
261
#                   All lines will be terminated with a "\n"
262
#
263
# Returns         : Nothing
264
#
265
sub FileCreate
266
{
267
    _FileWrite ( '>', @_ );
268
}
269
 
270
sub FileAppend
271
{
272
    _FileWrite ( '>>', @_ );
273
}
274
 
275
sub _FileWrite
276
{
277
    my $mode = shift @_;
278
    my $name = shift @_;
283 dpurdie 279
    my $fh;
261 dpurdie 280
 
281
    Error ("FileCreate: No file specified") unless ( $name );
6276 dpurdie 282
    Error ("FileCreate: Path is directory", 'Path :' . $name) if ( -d $name );
261 dpurdie 283
 
283 dpurdie 284
    open  ($fh, $mode, $name ) || Error( "Cannot create file: $name", "Reason: $!" );
261 dpurdie 285
 
286
    foreach my $entry ( @_ ) {
287
        if ( ref ($entry ) eq 'ARRAY'  ) {
283 dpurdie 288
            print $fh $_ . "\n" foreach  ( @$entry );
261 dpurdie 289
        } else {
283 dpurdie 290
            print $fh $entry . "\n"
261 dpurdie 291
        }
292
    }
283 dpurdie 293
    close $fh;
261 dpurdie 294
}
295
 
296
#-------------------------------------------------------------------------------
6133 dpurdie 297
# Function        : TagFileMatch 
298
#
299
# Description     : Test the contents of a simple (one line) file against a string    
300
#
301
# Inputs          : $tfile      - Name of the tag file
302
#                   $tag        - Tag to match 
303
#
304
# Returns         : True - is a match
305
#
306
sub TagFileMatch
307
{
308
    my ($tfile, $tag) = @_;
309
    return 0 unless -f $tfile;
310
 
311
    open( my $file, '<', $tfile) || return 0;
312
    my $text = <$file>;
313
    close $file;
314
 
315
    $text = '' unless defined ($text);
316
    # Remove trailing new line and white space
317
    $text =~ s~\s*$~~;
318
    Debug("TagFileMatch:'$text':'$tag'", $text eq $tag );
319
 
320
    return $text eq $tag;
321
}
322
 
323
#-------------------------------------------------------------------------------
324
# Function        : TagFileRead
325
#
326
# Description     : Read the contents of a simple (one line) file against a string    
327
#
328
# Inputs          : $tfile      - Name of the tag file
329
#
330
# Returns         : One line of the file
331
#
332
sub TagFileRead
333
{
334
    my ($tfile) = @_;
335
    return "" unless -f $tfile;
336
 
337
    open( my $file, '<', $tfile) || Error("Cannot open '$tfile'. $!");
338
    my $text = <$file>;
339
    close $file;
340
 
341
    $text = '' unless defined ($text);
342
    $text =~ s~\s*$~~;
343
    return $text;
344
}
345
 
346
#-------------------------------------------------------------------------------
227 dpurdie 347
# Function        : FileIsNewer
348
#
349
# Description     : Test two files to see if the files are newer
350
#
351
# Inputs          : file1
352
#                   file2
353
#
354
# Returns         : Returns true if file1 is newer than file2 or file2 does not
355
#                   exist.
356
#
357
#                   If file 1 does not exist then it will return false
358
#
359
sub FileIsNewer
360
{
361
    my ($file1, $file2) = @_;
362
 
363
    my $f1_timestamp = (stat($file1))[9] || 0;
364
    my $f2_timestamp = (stat($file2))[9] || 0;
365
    my $result = $f1_timestamp > $f2_timestamp ? 1 : 0;
366
 
367
    Verbose2 ("FileIsNewer: TS: $f1_timestamp, File: $file1");
368
    Verbose2 ("FileIsNewer: TS: $f2_timestamp, File: $file2");
369
    Verbose2 ("FileIsNewer: $result" );
370
 
371
    return $result;
372
}
373
 
374
#-------------------------------------------------------------------------------
375
# Function        : Realpath
376
#
377
# Description     : Returns the 'real path'
378
#
379
# Inputs          : $path       - Path to process
380
#
381
# Returns         : The real path
382
#
383
sub Realpath
384
{
385
    my( $path ) = @_;
386
    my( $real, $cwd );
387
 
388
    $cwd = Getcwd();
389
    if (!chdir( $path )) {
390
        $real = "";
391
    } else {
392
        $real = Getcwd();
393
        Error ("FATAL: Realpath($path) could not restore directory ($cwd)." )
394
            unless (chdir( $cwd ));
395
    }
396
    Debug( "Realpath:   = $real ($path)" );
397
    return $real;
398
}
399
 
400
#-------------------------------------------------------------------------------
401
# Function        : Realfile
402
#
403
# Description     : Returns the 'real path'
404
#
405
# Inputs          : $path       - Path to process
406
#
407
# Returns         : The real path
408
#
409
#sub Realfile
410
#{
411
#    my( $path ) = @_;
412
#    my( $real, $cwd );
413
#
414
#    $cwd = Getcwd();
415
#    if (!chdir( $path )) {
416
#        $real = "";
417
#    } else {
418
#        $real = Getcwd();
419
#        Error ("FATAL: Realpath($path) could not restore directory ($cwd)." )
420
#            unless (chdir( $cwd ));
421
#    }
422
#    Debug( "Realpath:   = $real ($path)" );
423
#    return $real;
424
#}
425
 
426
#-------------------------------------------------------------------------------
427
# Function        : RelPath
428
#
429
# Description     : Return the relative path to the current working directory
430
#                   as provided in $Cwd
431
#
285 dpurdie 432
# Inputs          : $base       - Base directory to convert
4421 dpurdie 433
#                                 Expected to be well formed absolute path
285 dpurdie 434
#                   $here       - Optional current directory
4421 dpurdie 435
#                                 Expected to be well formed absolute path
285 dpurdie 436
#                                 $Cwd will be used if non provided
227 dpurdie 437
#
438
# Returns         : Relative path from the current directory to the base directory
439
#
440
sub RelPath
441
{
285 dpurdie 442
    my ($base, $here) = @_;
6276 dpurdie 443
    unless (defined $base)
444
    {
445
        DebugTraceBack ('RelPath');
446
        Error ("Internal: 'RelPath(). base not defined'");
447
    }
227 dpurdie 448
 
285 dpurdie 449
    $here = $Cwd unless ( defined $here );
6276 dpurdie 450
    $here = $CwdDrive . $here if ( $base =~ m~^\w+:/~ && $here !~ m~^\w+:/~);
227 dpurdie 451
    my @base = split ('/', $base );
285 dpurdie 452
    my @here = split ('/', $here );
227 dpurdie 453
    my $result;
454
 
4265 dpurdie 455
    Debug("RelPath: Here  : $here");
227 dpurdie 456
    Debug("RelPath: Source: $base");
457
 
4421 dpurdie 458
    # Not absolute - just return it
6133 dpurdie 459
    return $base unless ( $base =~ m~^/~ || $base =~ m~^\w+:/~ );
460
 
227 dpurdie 461
    #
462
    #   Remove common bits from the head of both lists
463
    #
464
    while ( $#base >= 0 && $#here >= 0 && $base[0] eq $here[0] )
465
    {
466
        shift @base;
467
        shift @here;
468
    }
469
 
470
    #
471
    #   Need to go up some directories from here and then down into base
472
    #
473
    $result = '../' x ($#here + 1);
474
    $result .= join ( '/', @base);
475
    $result = '.' unless ( $result );
476
    $result =~ s~/$~~;
477
 
478
    Debug("RelPath: Result: $result");
479
    return $result;
480
}
481
 
482
#-------------------------------------------------------------------------------
483
# Function        : AbsPath
484
#
485
# Description     : Return the absolute path to the file
486
#                   Add the current directory if the path is absolute
487
#                   Clean up xxx/.. constructs
488
#
489
#                   If an absolute path is provided then it will simply be
490
#                   cleaned up.
491
#
492
# Assumption      : Absolute paths start with a "/" and do not have a drive letter
493
#
2450 dpurdie 494
# Inputs          : $dpath      - Source file path
325 dpurdie 495
#                   $here       - Optional current directory
496
#                                 $Cwd will be used if non provided
2450 dpurdie 497
#                   $mode       - Defined: No error
498
#                                 Used during error reporting
227 dpurdie 499
#
500
# Returns         : Cleaned abs path
501
#
502
sub AbsPath
503
{
2450 dpurdie 504
    my ($dpath, $here, $mode) = @_;
227 dpurdie 505
    my @result;
6276 dpurdie 506
    unless (defined $dpath)
507
    {
508
        DebugTraceBack ();
509
        Error ("Internal: 'AbsPath(). dpath not defined'");
510
    }
227 dpurdie 511
 
512
    #
513
    #   If we have a relative path then prepend the current directory
514
    #   An absolute path is:
515
    #           /aaa/aa/aa
516
    #       or  c:/aaa/aa/aa
517
    #
325 dpurdie 518
    $here = $Cwd unless ( defined $here );
3859 dpurdie 519
    $here =~ s~^\w:~~;
325 dpurdie 520
    $dpath = $here . '/' . $dpath
3832 dpurdie 521
        unless ( $dpath =~ m~^/|\w:[/\\]~  );
227 dpurdie 522
    $dpath =~ s~//~/~g;
523
 
524
    #
525
    #   Walk the bits and remove ".." directories
526
    #       Done by pushing non-.. elements and poping last entry for .. elements.
527
    #   Have a leading "/" which is good.
528
    #
529
    foreach ( split ( '/', $dpath ) )
530
    {
531
        next if ( $_ eq '.' );
532
        unless ( $_ eq '..' )
533
        {
534
            push @result, $_;
535
        }
536
        else
537
        {
2450 dpurdie 538
            if ( $#result <= 0 )
539
            {
540
                Error ("Bad Pathname: $dpath") unless ( $mode );
541
                return $dpath;
542
            }
543
            else
544
            {
545
                pop @result;
546
            }
227 dpurdie 547
        }
548
    }
549
 
550
    #
551
    #   Create a nice directory name again.
552
    #
553
    return join ( '/', @result );
554
}
555
 
556
#-------------------------------------------------------------------------------
557
# Function        : FullPath
558
#
559
# Description     : Return the absolute path to the file - with driver letter
560
#                   Add the current directory if the path is absolute
561
#                   Clean up xxx/.. constructs
562
#
563
#                   If an absolute path is provided then it will simply be
564
#                   cleaned up.
565
#
566
# Inputs          : Source file path
325 dpurdie 567
#                   $here       - Optional current directory
568
#                                 $Cwd will be used if non provided
227 dpurdie 569
#
570
# Returns         : Cleaned abs path
571
#
572
sub FullPath
573
{
574
    my $path = AbsPath (@_ );
229 dpurdie 575
    $path = $CwdDrive . $path unless ( $path =~ m~^\w:~  );
227 dpurdie 576
    return $path;
577
}
578
 
579
#-------------------------------------------------------------------------------
257 dpurdie 580
# Function        : TruePath
581
#
582
# Description     : Returns a case correct pathname
583
#                   Really only applicable to windows, under unix it returns
584
#                   its input path.
585
#
586
#                   Maintains a cache to speed up processing
587
#
588
# Inputs          : Confused path (Absolute with a driver letter)
589
#
590
# Returns         : Case Correct Path : Windows
591
#                   Input Path : Non Windows
592
#
593
my %TruePathCache;
594
my %DirRead;
595
sub TruePath
596
{
597
    my ($path) = @_;
6276 dpurdie 598
    Debug("TruePath: $path");
257 dpurdie 599
    $path =~ tr~\\/~/~s;
600
 
601
    #
602
    #   On Unix systems the path is case sensitive to start with
603
    #   Can't get it wrong - can't do anything.
604
    #
605
    return $path if ( $isUnix );
606
 
607
    #
608
    #   If the path does not exist at all then return the user input
609
    #   Assume that the user will handle this later
610
    #
611
    unless ( -e $path )
612
    {
613
        Warning ("TruePath given invalid path: $path");
614
        return $path;
615
    }
616
 
617
    #
618
    #   Look in the cache - have we seen this before
619
    #
620
    if ( exists $TruePathCache{lc($path)} )
621
    {
5969 dpurdie 622
        Verbose2( "TruePath Cache Hit: $path");
257 dpurdie 623
        return $TruePathCache{lc($path)};
624
    }
625
 
626
    #
627
    #   Split the directory into components
628
    #
629
    my $TrueComponent = '';
630
    my @components = split ('/', $path );
631
    foreach my $elem ( @components )
632
    {
633
        Debug ("Process: $elem in $TrueComponent");
634
        my $tag;
635
        #
636
        #   Handle driver letter
637
        #
638
        if ( $elem =~ m~^[a-zA-Z]:$~ )
639
        {
640
            $elem = uc($elem);
641
            $TrueComponent = $elem;
642
 
643
            $tag = lc($TrueComponent);
644
            $TruePathCache{$tag} = $elem;
645
            Debug ("     Add: $elem");
646
            next;
647
        }
648
 
649
        #
650
        #   Ensure that we have read in containing directory
651
        #   Note: Append / to ensure we read root directories correctly
652
        #
653
        $TrueComponent .= '/';
654
        unless ( $DirRead{ $TrueComponent }  )
655
        {
656
            Debug ("Reading: $TrueComponent");
285 dpurdie 657
            opendir (my $tp, $TrueComponent ) or Error ("Cannot open $TrueComponent");
658
            my @dirlist = readdir $tp;
659
            closedir $tp;
257 dpurdie 660
            $DirRead {$TrueComponent } = 1;
661
 
662
            #
663
            #   Add cache entries for each path in the directory
664
            #
665
            foreach my $dir ( @dirlist )
666
            {
667
                next if ( $dir eq '.' );
668
                next if ( $dir eq '..' );
669
                my $fullpath = $TrueComponent . $dir;
670
                Debug ("     Add: $fullpath");
671
                $TruePathCache{lc($fullpath)} = $fullpath;
672
            }
673
        }
674
 
675
        #
676
        #   Now that we have populated the cache with data from the directory
677
        #   we can expect to find our desired entry in the cache.
678
        #
679
        $tag = lc($TrueComponent . $elem );
680
        if ( exists $TruePathCache{ $tag } )
681
        {
682
            $TrueComponent = $TruePathCache{ $tag };
683
        }
684
        else
685
        {
686
            DebugDumpData ("Cache", \%TruePathCache);
687
            Error ("TruePath Internal error. File may have been deleted: $tag");
688
        }
689
        Debug ("Have: $TrueComponent");
690
    }
691
 
5969 dpurdie 692
    Verbose2 ("TruePath: $TrueComponent");
257 dpurdie 693
    return $TrueComponent;
694
}
695
 
696
#-------------------------------------------------------------------------------
227 dpurdie 697
# Function        : CleanPath
698
#
699
# Description     : Cleanup a path
700
#                   Remove xxx/.. constructs
6133 dpurdie 701
#                   Replace /./ constructs with /
227 dpurdie 702
#
703
# Note            : Will not perform error detection on badly formed
704
#                   absolute paths.
705
#
706
# Inputs          : Source file path
707
#
708
# Returns         : Clean absolute or relative path
709
#
710
#
711
sub CleanPath
712
{
713
    my ($dpath) = @_;
714
    my @result;
715
    Debug("CleanPath: Source: $dpath");
716
 
717
    #
718
    #   Cleanup the the user input. Remove double delimiters and ensure there
6276 dpurdie 719
    #   is no trailing delimiter
227 dpurdie 720
    #
6276 dpurdie 721
    $dpath =~ s~\\~/~g;
722
    $dpath =~ s~^\./~~g;
723
    $dpath =~ s~/\./~/~g;
245 dpurdie 724
    $dpath =~ s~/+~/~g;
227 dpurdie 725
    $dpath =~ s~/$~~g;
726
 
727
    #
728
    #   Walk the bits and remove "xxx/.." directories
729
    #
730
    foreach ( split ( '/', $dpath ) )
731
    {
732
        if ( $_ ne '..' || $#result < 0 )
733
        {
734
            push @result, $_;
735
        }
736
        else
737
        {
738
            if ( $#result >= 0 )
739
            {
283 dpurdie 740
                my $last_dir = pop @result;
741
                push (@result, $last_dir, $_)
742
                    if ($last_dir eq '..' || $last_dir eq '');
227 dpurdie 743
            }
744
        }
745
    }
746
 
747
    my $result = join ( '/', @result );
6276 dpurdie 748
    $result = '.' unless $result;
227 dpurdie 749
    Debug("CleanPath: Result: $result");
750
    return $result;
751
}
752
 
753
#-------------------------------------------------------------------------------
6276 dpurdie 754
# Function        : CatPaths 
755
#
756
# Description     : Join path elemanets together with a '/'
757
#                   Clean up the result
758
#
759
# Inputs          : Patth elemenst to join    
760
#
761
# Returns         : Cleaned up path elements
762
#
763
sub CatPaths
764
{
765
    Debug("CatPaths: @_ ");
766
    return CleanPath join ('/', @_);
767
}
768
 
769
#-------------------------------------------------------------------------------
227 dpurdie 770
# Function        : StripDrive
771
#
772
# Description     : Strip any leading drive speification
773
#
774
# Inputs          : $fname          - Path to process
775
#
776
# Returns         : Path, with drive letter stripped
777
#                   Will do nothing on Unix systems
778
#
779
sub StripDrive
780
{
781
    my( $fname ) = @_;                          # Full name
782
 
783
    $fname =~ s/^[A-Za-z]://g                  # leading drive spec
784
        if ( ! $isUnix );
785
    return $fname;
786
}
787
 
788
#-------------------------------------------------------------------------------
789
# Function        : StripDir
790
#
791
# Description     : Strip directory (returns file, including extension)
792
#
793
# Inputs          : $fname          - Path to process
794
#
795
# Returns         : filename + extension
796
#
797
sub StripDir
798
{
799
    my( $fname ) = @_;                          # Full name
800
    my( $idx );
801
 
802
    if (($idx = rindex($fname, "/")) == -1) {
803
        if (($idx = rindex($fname, "\\")) == -1) {
804
            return $fname;                      # No path ...
805
        }
806
    }
807
    return substr($fname, $idx+1, 512);
808
}
809
 
810
#-------------------------------------------------------------------------------
811
# Function        : StripExt
812
#
813
# Description     : Strip extension (return basename, plus any dir)
814
#
815
# Inputs          : $fname          - Path to process
816
#
817
# Returns         : basename, plus any dir
818
#                   Simply removes one extension
819
#
820
sub StripExt
821
{
822
    my( $fname ) = @_;
823
 
824
    $fname =~ s/(\S+)(\.\S+)/$1/;               # strip out trailing '.<ext>'
825
    return ($fname);
826
}
827
 
828
#-------------------------------------------------------------------------------
829
# Function        : StripFile
830
#
831
# Description     : Strip filename (returns extension)
832
#
833
# Inputs          : $fname          - Path to process
834
#
835
# Returns         : extension
836
#                   Will return an empty string if the input does not have an
837
#                   extension.
838
#
839
sub StripFile
840
{
841
    my( $fname ) = @_;
842
 
843
    $fname =~ s/(\S+)(\.\S+)/$2/;               # Strip out items before '.<ext>'
844
    return ("")                                 # No extension
845
        if ("$fname" eq "@_");
846
    return ($fname);
847
}
848
 
849
#-------------------------------------------------------------------------------
850
# Function        : StripFileExt
851
#
852
# Description     : Strip filename and ext (returns dir)
853
#
854
# Inputs          : $fname          - Path to process
855
#
856
# Returns         : Directory of a file path
857
#
858
 
859
 
860
#   StripFileExt( path ) ---
861
#       Strip filename and ext (returns dir)
862
#..
863
 
864
sub StripFileExt
865
{
866
    my( $fname ) = @_;                          # Full name
867
    my( $idx );
868
    my $dir;
869
 
870
    if (($idx = rindex($fname, "/")) == -1) {
871
        if (($idx = rindex($fname, "\\")) == -1) {
872
            return "";                          # No path ...
873
        }
874
    }
875
 
876
    return substr($fname, 0, $idx);
877
}
878
 
879
#-------------------------------------------------------------------------------
880
# Function        : StripDirExt
881
#
882
# Description     : Strip the directory and extension from a file
883
#                   Returning the base file. Optionally replace the extension
884
#                   with a user value
885
#
886
# Inputs          : Full path name
887
#                   Optional extension to be replaced
888
#
889
# Returns         :
890
#
891
sub StripDirExt
892
{
893
    my ($fname, $ext ) = (@_, '');
894
    $fname =~ s~.*[/\\]~~;                      # Strip directory
895
    $fname =~ s/\.[^.]+$/$ext/;
896
    return $fname;
897
}
898
 
899
 
900
#-------------------------------------------------------------------------------
901
# Function        : CleanDirName
902
#
903
# Description     : Clean up a directory path string
904
#                       1) Remove multiple //
905
#                       2) Remove multiple /./
906
#                       2) Remove leading ./
907
#                       3) Remove trailing /
908
#                       4) Remove /xxxx/../
909
#
910
# Inputs          : A dirty directory path
911
#
912
# Returns         : A clean directory path
913
#
914
sub CleanDirName
915
{
916
    my ( $dir ) = @_;
917
    $dir =~ s~//~/~g;                   # Kill multiple //
918
    $dir =~ s~/\./~/~g;                 # Kill multiple /./
919
    $dir =~ s~^\./~~;                   # Kill leading ./
920
    $dir = '.' unless ( $dir );         # Ensure we have a path
921
 
922
    #
923
    #   Remove /xxxxx/../ bits
924
    #
925
    unless ( $dir =~ m~^\.\./~  )
926
    {
927
        while ( $dir =~ s~
928
                        (^|/)               # Allow for stings that may not start with a /
929
                        [^/]+/\.\.          # xxxxx/.., where xxxx is anything other than a /
930
                        (/|$)               # Allow for strings ending with /..
931
                        ~$1~x               # Replace with the start character
932
              )
933
        {
934
            last if ( $dir =~ m~^\.\./~ );  # Too far. Stop now !
935
        }
936
    }
937
 
938
    $dir =~ s~/$~~;                     # No trailing /
939
    $dir =~ s~/\.$~~;                   # No trailing /.
940
    return $dir;
941
}
942
 
943
#-------------------------------------------------------------------------------
944
# Function        : DisplayPath
945
#
946
# Description     : Cleanup a path for display purposes
947
#                   Useful under windows to provide paths with \ that can be
948
#                   cut and pasted.
949
#
950
#                   If cygwin is located in the environment, then this function
951
#                   will not convert / to \.
952
#
953
# Inputs          : A path to modify
954
#
955
# Returns         : Modified path
956
#
957
sub DisplayPath
958
{
959
    my ($path) = @_;
960
    if ( ! $isUnix && ! $isCygWin )
961
    {
962
        $path =~ s~/~\\~g;
963
    }
4546 dpurdie 964
    else
965
    {
966
        $path =~ s~\\~/~g;
967
    }
227 dpurdie 968
    return $path;
969
}
970
 
361 dpurdie 971
#-------------------------------------------------------------------------------
972
# Function        : RmDirTree
973
#
974
# Description     : Delete a directory tree
975
#                   Really delete it. Allow for users to remove directory
976
#                   without search permissions under unix.
977
#
978
#                   Can also delete a file
979
#
2439 dpurdie 980
#                   This function has a bit of history
981
#                   I've tried the Perl rmtree(), but there were situations
982
#                   where the OS(WIN32) says the directory exists after its been
983
#                   deleted. Also the Jats-Win32 version of chmod would issue
984
#                   messages if it couldn't find the dir/file.
985
#
986
#                   The solution is to use JATS' own JatsFileUtil utility
987
#                   This appears to do the right thing
988
#
361 dpurdie 989
# Inputs          : $path                   - Path to directory
4344 dpurdie 990
#                                             May be empty, in which case nothing is done
361 dpurdie 991
#
992
# Returns         : 1                       - Still there
993
#
994
sub RmDirTree
995
{
996
    my ($path) = @_;
4344 dpurdie 997
    return 0 unless $path;
361 dpurdie 998
    if ( -e $path )
999
    {
2439 dpurdie 1000
        #  Need to know if its a file or a directory
1001
        #
1002
        my $mode = ( -d $path ) ? 'T' : 'r';
1003
 
1004
        #
1005
        #   Use JATS's own utility to do the hardwork
1006
        #   Used as it address a number of issues
1007
        #
1008
        #   Merge in verbosity
1009
        #
1010
        system ("$ENV{GBE_BIN}/JatsFileUtil", $mode . $::ScmVerbose, '', $path );
1011
 
1012
        #
1013
        #   Shouldn't happen but ...
1014
        #   If the path still exists try another (one this has known problems)
1015
        #
1016
        if ( -e $path )
1017
        {
1018
            Verbose3 ("RmDirTree: Directory still exists. Change permissions: $path");
1019
            system ("$ENV{GBE_BIN}/chmod", '-R', 'u+wrx', $path);
5568 dpurdie 1020
            eval { rmtree( $path ); };
2439 dpurdie 1021
        }
361 dpurdie 1022
    }
1023
    return ( -e $path );
1024
}
1025
 
227 dpurdie 1026
1;
1027
 
1028