Subversion Repositories DevTools

Rev

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

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