Subversion Repositories DevTools

Rev

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