Subversion Repositories DevTools

Rev

Rev 261 | Rev 285 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 261 Rev 283
Line 1... Line -...
1
#! perl
-
 
2
########################################################################
1
########################################################################
3
# Copyright ( C ) 2005 ERG Limited, All rights reserved
2
# Copyright ( C ) 2005 ERG Limited, All rights reserved
4
#
3
#
5
# Module name   : jats.sh
4
# Module name   : jats.sh
6
# Module type   : Perl Package
5
# Module type   : Perl Package
Line 42... Line 41...
42
#   Global variables used by functions in this package
41
#   Global variables used by functions in this package
43
#   For historical reasons many of these variabeles are global
42
#   For historical reasons many of these variabeles are global
44
#
43
#
45
 
44
 
46
package FileUtils;
45
package FileUtils;
-
 
46
use base qw(Exporter);
-
 
47
 
47
use JatsError;
48
use JatsError;
48
use Cwd;
49
use Cwd;
49
 
-
 
50
our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
50
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
51
use Exporter;
-
 
52
 
51
 
53
$VERSION = 1.00;
52
$VERSION = 1.00;
54
@ISA = qw(Exporter);
-
 
55
 
53
 
56
# Symbols to autoexport (:DEFAULT tag)
54
# Symbols to autoexport (:DEFAULT tag)
57
@EXPORT = qw(   InitFileUtils
55
@EXPORT = qw(   InitFileUtils
58
                Getcwd
56
                Getcwd
59
                Realpath
57
                Realpath
Line 185... Line 183...
185
#
183
#
186
sub TouchFile
184
sub TouchFile
187
{
185
{
188
    my ($path, $text) = @_;
186
    my ($path, $text) = @_;
189
    my $result = 0;
187
    my $result = 0;
-
 
188
    my $tfh;
-
 
189
 
190
    Verbose ("Touching file: $path" );
190
    Verbose ("Touching file: $path" );
191
    if ( ! -f $path )
191
    if ( ! -f $path )
192
    {
192
    {
193
        open (TOUCH, ">>", $path) || ($result = 1);
193
        open ($tfh, ">>", $path) || ($result = 1);
194
        close (TOUCH);
194
        close $tfh;
195
    }
195
    }
196
    else
196
    else
197
    {
197
    {
198
 
198
 
199
        #
199
        #
Line 206... Line 206...
206
        #
206
        #
207
        #   Read in the first character of the file, rewind and write it
207
        #   Read in the first character of the file, rewind and write it
208
        #   out again.
208
        #   out again.
209
        #
209
        #
210
        my $data;
210
        my $data;
211
        open (TOUCH , "+<", $path ) || return 1;
211
        open ($tfh , "+<", $path ) || return 1;
212
        if ( read ( TOUCH, $data, 1 ) ) {
212
        if ( read ( $tfh, $data, 1 ) )
-
 
213
        {
213
            seek ( TOUCH, 0, 0 );
214
            seek  ( $tfh, 0, 0 );
214
            print TOUCH $data;
215
            print $tfh $data;
215
        }
216
        }
216
        else
217
        else
217
        {
218
        {
218
            #
219
            #
219
            #   File must have been of zero length
220
            #   File must have been of zero length
220
            #   Delete the file and create it
221
            #   Delete the file and create it
221
            #
222
            #
222
            close (TOUCH);
223
            close ($tfh);
223
            unlink ( $path );
224
            unlink ( $path );
224
            open (TOUCH, ">>", $path) || ($result = 1);
225
            open ($tfh, ">>", $path) || ($result = 1);
225
        }
226
        }
226
        close (TOUCH);
227
        close ($tfh);
227
    }
228
    }
228
    return $result;
229
    return $result;
229
}
230
}
230
 
231
 
231
#-------------------------------------------------------------------------------
232
#-------------------------------------------------------------------------------
Line 257... Line 258...
257
 
258
 
258
sub _FileWrite
259
sub _FileWrite
259
{
260
{
260
    my $mode = shift @_;
261
    my $mode = shift @_;
261
    my $name = shift @_;
262
    my $name = shift @_;
-
 
263
    my $fh;
262
 
264
 
263
    Error ("FileCreate: No file specified") unless ( $name );
265
    Error ("FileCreate: No file specified") unless ( $name );
264
    Error ("FileCreate: Path is directory") if ( -d $name );
266
    Error ("FileCreate: Path is directory") if ( -d $name );
265
 
267
 
266
    local ( *FN );
-
 
267
    open  (FN, $mode, $name ) || Error( "Cannot create file: $name", "Reason: $!" );
268
    open  ($fh, $mode, $name ) || Error( "Cannot create file: $name", "Reason: $!" );
268
 
269
 
269
    foreach my $entry ( @_ ) {
270
    foreach my $entry ( @_ ) {
270
        if ( ref ($entry ) eq 'ARRAY'  ) {
271
        if ( ref ($entry ) eq 'ARRAY'  ) {
271
            print FN $_ . "\n" foreach  ( @$entry );
272
            print $fh $_ . "\n" foreach  ( @$entry );
272
        } else {
273
        } else {
273
            print FN $entry . "\n"
274
            print $fh $entry . "\n"
274
        }
275
        }
275
    }
276
    }
276
    close FN;
277
    close $fh;
277
}
278
}
278
 
279
 
279
#-------------------------------------------------------------------------------
280
#-------------------------------------------------------------------------------
280
# Function        : FileIsNewer
281
# Function        : FileIsNewer
281
#
282
#
Line 417... Line 418...
417
#
418
#
418
sub AbsPath
419
sub AbsPath
419
{
420
{
420
    my ($dpath) = @_;
421
    my ($dpath) = @_;
421
    my @result;
422
    my @result;
422
    my $drive;
-
 
423
 
423
 
424
    #
424
    #
425
    #   If we have a relative path then prepend the current directory
425
    #   If we have a relative path then prepend the current directory
426
    #   An absolute path is:
426
    #   An absolute path is:
427
    #           /aaa/aa/aa
427
    #           /aaa/aa/aa
Line 632... Line 632...
632
        }
632
        }
633
        else
633
        else
634
        {
634
        {
635
            if ( $#result >= 0 )
635
            if ( $#result >= 0 )
636
            {
636
            {
637
                my $last = pop @result;
637
                my $last_dir = pop @result;
638
                push (@result, $last, $_)
638
                push (@result, $last_dir, $_)
639
                    if ($last eq '..' || $last eq '');
639
                    if ($last_dir eq '..' || $last_dir eq '');
640
            }
640
            }
641
        }
641
        }
642
    }
642
    }
643
 
643
 
644
    my $result = join ( '/', @result );
644
    my $result = join ( '/', @result );