WebSVN – DevTools – Diff – /core_devl/trunk/TOOLS/LIB/FileUtils.pm



 
########################################################################
# Copyright ( C ) 2005 ERG Limited, All rights reserved
#
# Module name   : jats.sh
# Module type   : Perl Package

#   Global variables used by functions in this package
#   For historical reasons many of these variabeles are global
#
 
package FileUtils;
use base qw(Exporter);
 
use JatsError;
use Cwd;
 
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
 
 
$VERSION = 1.00;
 
 
# Symbols to autoexport (:DEFAULT tag)
@EXPORT = qw(   InitFileUtils
                Getcwd
                Realpath

#
sub TouchFile
{
    my ($path, $text) = @_;
    my $result = 0;
    my $tfh;
 
    Verbose ("Touching file: $path" );
    if ( ! -f $path )
    {
        open ($tfh, ">>", $path) || ($result = 1);
        close $tfh;
    }
    else
    {
 
        #

        #
        #   Read in the first character of the file, rewind and write it
        #   out again.
        #
        my $data;
        open ($tfh , "+<", $path ) || return 1;
        if ( read ( $tfh, $data, 1 ) )
        {
            seek  ( $tfh, 0, 0 );
            print $tfh $data;
        }
        else
        {
            #
            #   File must have been of zero length
            #   Delete the file and create it
            #
            close ($tfh);
            unlink ( $path );
            open ($tfh, ">>", $path) || ($result = 1);
        }
        close ($tfh);
    }
    return $result;
}
 
#-------------------------------------------------------------------------------

 
sub _FileWrite
{
    my $mode = shift @_;
    my $name = shift @_;
    my $fh;
 
    Error ("FileCreate: No file specified") unless ( $name );
    Error ("FileCreate: Path is directory") if ( -d $name );
 
 
    open  ($fh, $mode, $name ) || Error( "Cannot create file: $name", "Reason: $!" );
 
    foreach my $entry ( @_ ) {
        if ( ref ($entry ) eq 'ARRAY'  ) {
            print $fh $_ . "\n" foreach  ( @$entry );
        } else {
            print $fh $entry . "\n"
        }
    }
    close $fh;
}
 
#-------------------------------------------------------------------------------
# Function        : FileIsNewer
#

#
sub AbsPath
{
    my ($dpath) = @_;
    my @result;
 
 
    #
    #   If we have a relative path then prepend the current directory
    #   An absolute path is:
    #           /aaa/aa/aa

        }
        else
        {
            if ( $#result >= 0 )
            {
                my $last_dir = pop @result;
                push (@result, $last_dir, $_)
                    if ($last_dir eq '..' || $last_dir eq '');
            }
        }
    }
 
    my $result = join ( '/', @result );

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 );`

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/LIB/FileUtils.pm – Rev 261 → 283