Subversion Repositories DevTools

Rev

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