source: main/trunk/greenstone2/perllib/FileUtils.pm@ 37233

Last change on this file since 37233 was 37200, checked in by davidb, 17 months ago

New minus option added in to allow control over whether hardlinking or copying of files is used; also removed some deprecated functions from FileUtils.pm
File size: 43.4 KB
Line 
1###########################################################################
2#
3# FileUtils.pm -- functions for dealing with files. Skeleton for more
4# advanced system using dynamic class cloading available in extensions.
5#
6# A component of the Greenstone digital library software
7# from the New Zealand Digital Library Project at the
8# University of Waikato, New Zealand.
9#
10# Copyright (C) 2013 New Zealand Digital Library Project
11#
12# This program is free software; you can redistribute it and/or modify
13# it under the terms of the GNU General Public License as published by
14# the Free Software Foundation; either version 2 of the License, or
15# (at your option) any later version.
16#
17# This program is distributed in the hope that it will be useful,
18# but WITHOUT ANY WARRANTY; without even the implied warranty of
19# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20# GNU General Public License for more details.
21#
22# You should have received a copy of the GNU General Public License
23# along with this program; if not, write to the Free Software
24# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25#
26###########################################################################
27
28package FileUtils;
29
30# Pragma
31use strict;
32use warnings;
33
34use FileHandle;
35use File::stat;
36
37# Greenstone modules
38use util;
39
40################################################################################
41# util::cachedir() => FileUtils::synchronizeDirectory()
42# util::cp() => FileUtils::copyFiles()
43# util::cp_r() => FileUtils::copyFilesRecursive()
44# util::cp_r_nosvn() => FileUtils::copyFilesRecursiveNoSVN()
45# util::cp_r_toplevel() => FileUtils::copyFilesRecursiveTopLevel()
46# util::differentfiles() => FileUtils::differentFiles()
47# util::dir_exists() => FileUtils::directoryExists()
48# util::fd_exists() => FileUtils::fileTest()
49# util::file_exists() => FileUtils::fileExists()
50# util::filename_cat() => FileUtils::filenameConcatenate()
51# util::filename_is_absolute() => FileUtils::isFilenameAbsolute()
52# util::filtered_rm_r() => FileUtils::removeFilesFiltered()
53# util::hard_link() => FileUtils::hardLink()
54# util::is_dir_empty() => FileUtils::isDirectoryEmpty()
55# util::mk_all_dir() => FileUtils::makeAllDirectories()
56# util::mk_dir() => FileUtils::makeDirectory()
57# util::mv() => FileUtils::moveFiles()
58# util::mv_dir_contents() => FileUtils::moveDirectoryContents()
59# util::rm() => FileUtils::removeFiles()
60# util::rm_r() => FileUtils::removeFilesRecursive()
61# util::soft_link() => FileUtils::softLink()
62
63# Functions that have been added, but not by John Thompson,
64# So the implementations don't support parallel processing yet, but they print a warning and the
65# correct implementation can be put into here. So that if all calls for reading and writing UTF8
66# file content go through here, then they will do the right thing when the functions are updated.
67#
68# => FileUtils::readUTF8File()
69# => FileUtils::writeUTF8File()
70#
71
72# Other functions in this file (perhaps some of these may have counterparts in util.pm too):
73
74#canRead
75#getTimestamp
76#isSymbolicLink
77#modificationTime
78#readDirectory
79#removeFilesDebug
80#sanitizePath
81#openFileHandle
82#closeFileHandle
83#differentFiles
84#filePutContents
85#fileSize
86#readDirectory
87
88################################################################################
89# Note: there are lots of functions involving files/directories/paths
90# etc found in utils.pm that are not represented here. My intention
91# was to just have those functions that need to be dynamic based on
92# filesystem, or need some rejigging to be filesystem aware. There is
93# an argument, I guess, for moving some of the other functions here so
94# that they are nicely encapsulated - but the question is what to do
95# with functions like filename_within_directory_url_format() which is
96# more URL based than file based.
97################################################################################
98
99
100## @function canRead()
101#
102sub canRead
103{
104 my ($filename_full_path) = @_;
105 return &fileTest($filename_full_path, '-R');
106}
107## canRead()
108
109
110## @function getTimestamp()
111#
112sub getTimestamp
113{
114 my ($filename) = @_;
115
116 my $file_stat = stat($filename);
117 my $mtime = $file_stat->mtime;
118
119 return $mtime;
120}
121## getTimestamp()
122
123## @function closeFileHandle
124#
125sub closeFileHandle
126{
127 my ($path, $fh_ref) = @_;
128 close($$fh_ref);
129}
130## closeFileHandle()
131
132
133## @function _copyFilesGeneral()
134#
135# internal version that copies a file or a group of files
136#
137sub copyFilesGeneral
138{
139 my ($srcfiles_ref,$dest,$options) = @_;
140
141 # upgrade srcfiles_ref to array reference, if what is passed in is a single (scalar) filename
142 $srcfiles_ref = [ $srcfiles_ref] if (ref $srcfiles_ref eq "");
143
144 my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0;
145 my $hardlink = (defined $options && $options->{'hardlink'}) ? $options->{'hardlink'} : 0;
146
147 # remove trailing slashes from source and destination files
148 $dest =~ s/[\\\/]+$//;
149 map {$_ =~ s/[\\\/]+$//;} @$srcfiles_ref;
150
151 # a few sanity checks
152 if (scalar(@$srcfiles_ref) == 0)
153 {
154 print STDERR "FileUtils::copyFilesGeneral() no destination directory given\n";
155 return 0;
156 }
157 elsif ((scalar(@$srcfiles_ref) > 1) && (!-d $dest))
158 {
159 print STDERR "FileUtils::copyFilesGeneral() if multiple source files are given the destination must be a directory\n";
160 return 0;
161 }
162
163 my $had_an_error = 0;
164
165 # copy the files
166 foreach my $file (@$srcfiles_ref)
167 {
168 my $tempdest = $dest;
169 if (-d $tempdest)
170 {
171 my ($filename) = $file =~ /([^\\\/]+)$/;
172 $tempdest .= "/$filename";
173 }
174 if (!-e $file)
175 {
176 print STDERR "FileUtils::copyFilesGeneral() $file does not exist\n";
177 $had_an_error = 1;
178 if ($strict) {
179 return 0;
180 }
181 }
182 elsif (!-f $file)
183 {
184 print STDERR "FileUtils::copyFilesGeneral() $file is not a regular file\n";
185 $had_an_error = 1;
186 if ($strict) {
187 return 0;
188 }
189 }
190 else
191 {
192 my $success = undef;
193
194 if ($hardlink) {
195
196 if (!link($file, $tempdest))
197 {
198 print STDERR "Warning: FileUtils::copyFilesGeneral(): unable to create hard link. ";
199 print STDERR " Attempting file copy: $file -> $tempdest\n";
200 $success = &File::Copy::copy($file, $tempdest);
201 }
202 else {
203 $success = 1;
204 }
205
206 }
207 else {
208 $success = &File::Copy::copy($file, $tempdest);
209 }
210
211 if (!$success) {
212 print STDERR "FileUtils::copyFilesGeneral() failed to copy $file -> $tempdest\n";
213 $had_an_error = 1;
214
215 if ($strict) {
216 return 0;
217 }
218 }
219 }
220 }
221
222 if ($had_an_error) {
223 return 0;
224 }
225 else {
226 # true => everything OK
227 return 1;
228 }
229
230}
231
232
233
234## @function copyFiles()
235#
236# copies a file or a group of files
237#
238sub copyFiles
239{
240 my $dest = pop (@_);
241 my (@srcfiles) = @_;
242
243 return &copyFilesGeneral(\@srcfiles,$dest,undef);
244}
245
246## copyFiles()
247
248
249## @function _readdirWithOptions()
250#
251# Internal version to support public functions such as readdirFullpath and readDirectory
252
253sub _readdirWithOptions
254{
255 my ($src_dir_fullpath,$options) = @_;
256
257 my $ret_val_success = 1; # default (true) is to assume things will work out!
258
259 my $all_files_and_dirs = [];
260
261 my $strict = 0;
262 my $make_fullpath = 0;
263 my $exclude_dirs = 0;
264 my $exclude_files = 0;
265 my $exclude_filter_re = undef;
266 my $include_filter_re = undef;
267
268 if (defined $options) {
269 $strict = $options->{'strict'} if defined $options->{'strict'};
270 $make_fullpath = $options->{'make_fullpath'} if defined $options->{'make_fullpath'};
271 $exclude_dirs = $options->{'exclude_dirs'} if defined $options->{'exclude_dirs'};
272 $exclude_files = $options->{'exclude_files'} if defined $options->{'exclude_files'};
273 $exclude_filter_re = $options->{'exclude_filter_re'} if defined $options->{'exclude_filter_re'};
274 $include_filter_re = $options->{'include_filter_re'} if defined $options->{'include_filter_re'};
275 }
276
277 # get the contents of this directory
278 if (!opendir(INDIR, $src_dir_fullpath))
279 {
280 print STDERR "FileUtils::readdirFullpath() could not open directory $src_dir_fullpath\n";
281 $ret_val_success = 0;
282 }
283 else
284 {
285 my @next_files_and_dirs = readdir(INDIR);
286 closedir (INDIR);
287
288 foreach my $f_or_d (@next_files_and_dirs)
289 {
290 next if $f_or_d =~ /^\.\.?$/;
291 next if $exclude_dirs && -d &filenameConcatenate($src_dir_fullpath, $f_or_d);
292 next if $exclude_files && -f &filenameConcatenate($src_dir_fullpath, $f_or_d);
293 next if (defined $exclude_filter_re && ($f_or_d =~ m/$exclude_filter_re/));
294
295 if ((!defined $include_filter_re) || ($f_or_d =~ m/$include_filter_re/)) {
296 if ($make_fullpath) {
297 my $ff_or_dd = &filenameConcatenate($src_dir_fullpath, $f_or_d);
298 push(@$all_files_and_dirs,$ff_or_dd);
299 }
300 else {
301 push(@$all_files_and_dirs,$f_or_d);
302 }
303 }
304 }
305
306 }
307
308 return ($ret_val_success,$all_files_and_dirs);
309}
310
311
312
313## @function readdirFullpath()
314#
315# For the given input directory, return full-path versions of the
316# files and directories it contains
317#
318# returned data is in the form of the tuple (status, fullpath-listing)
319#
320
321sub readdirFullpath
322{
323 my ($src_dir_fullpath,$options) = @_;
324
325 my $topped_up_options = { %$options };
326
327 $topped_up_options->{'make_fullpath'} = 1;
328
329 my ($ret_val_success,$fullpath_files_and_dirs) = _readdirWithOptions($src_dir_fullpath,$topped_up_options);
330
331 return ($ret_val_success,$fullpath_files_and_dirs);
332}
333
334
335## @function _copyFilesRecursiveGeneral()
336#
337# internal support routine for recursively copying or hard-linking files
338#
339# Notes that the src-files are passed as a reference, and so a single arguemnt,
340# whereas the the public facing functions take a array or arguments, and pops off the
341# final entry and treats it as the 'dest'
342
343sub _copyFilesRecursiveGeneral
344{
345 my ($srcfiles_ref,$dest,$depth,$options) = @_;
346
347 # upgrade srcfiles_ref to array reference, if what is passed in is a single (scalar) filename
348 $srcfiles_ref = [ $srcfiles_ref] if (ref $srcfiles_ref eq "");
349
350 # 'strict' defaults to false
351 # when false, this means, in situations where it can, even if an error is encountered it keeps going
352 my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0;
353 my $hardlink = (defined $options && $options->{'hardlink'}) ? $options->{'hardlink'} : 0;
354 my $copytype = (defined $options && $options->{'copytype'}) ? $options->{'copytype'} : "recursive";
355
356 # a few sanity checks
357 my $num_src_files = scalar (@$srcfiles_ref);
358
359 if ($num_src_files == 0)
360 {
361 print STDERR "FileUtils::_copyFilesRecursiveGeneral() no destination directory given\n";
362 return 0;
363 }
364 elsif (-f $dest)
365 {
366 print STDERR "FileUtils::_copyFilesRecursiveGeneral() destination must be a directory\n";
367 return 0;
368 }
369
370 if ($depth == 0) {
371 # Test for the special (top-level) case where:
372 # there is only one src file
373 # it is a directory
374 # and dest as a directory does not exits
375 #
376 # => This is a case similar to something like cp -r abc/ def/
377 # where we *don't* want abc ending up inside def
378
379
380 if ($num_src_files == 1) {
381
382 my $src_first_fullpath = $srcfiles_ref->[0];
383
384 if (-d $src_first_fullpath) {
385 my $src_dir_fullpath = $src_first_fullpath;
386
387 if (! -e $dest) {
388 # Do slight of hand, and replace the supplied single src_dir_fullpath with the contents of
389 # that directory
390
391 my ($readdir_status, $fullpath_subfiles_and_subdirs) = &readdirFullpath($src_dir_fullpath,$options);
392
393 if (!$readdir_status) {
394 return 0;
395 }
396 else
397 {
398 $srcfiles_ref = $fullpath_subfiles_and_subdirs;
399 }
400 }
401 }
402 }
403 }
404
405
406 # create destination directory if it doesn't exist already
407 if (! -d $dest)
408 {
409 my $store_umask = umask(0002);
410 my $mkdir_status = mkdir($dest, 0777);
411
412 if (!$mkdir_status) {
413 print STDERR "$!\n";
414 print STDERR "FileUtils::_copyFilesRecursiveGeneral() failed to create directory $dest\n";
415 umask($store_umask);
416
417 return 0;
418 }
419 umask($store_umask);
420 }
421
422 my $had_an_error = 0;
423
424 # copy the files
425 foreach my $file (@$srcfiles_ref)
426 {
427 if (! -e $file)
428 {
429 print STDERR "FileUtils::_copyFilesRecursiveGeneral() $file does not exist\n";
430
431 if ($strict) {
432 return 0;
433 }
434 else {
435 $had_an_error = 1;
436 }
437 }
438 elsif (-d $file)
439 {
440 # src-file is a diretory => recursive case
441
442 my $src_dir_fullpath = $file;
443
444 # make the new directory
445 my ($src_dirname_tail) = $src_dir_fullpath =~ /([^\\\/]*)$/;
446
447 my $next_dest = &filenameConcatenate($dest, $src_dirname_tail);
448
449 my $store_umask = umask(0002);
450 my $mkdir_success_ok = mkdir($next_dest, 0777);
451 umask($store_umask);
452
453 if (!$mkdir_success_ok) {
454 $had_an_error = 1;
455 if ($strict) {
456 return 0;
457 }
458 }
459
460 my ($readdir_status, $fullpath_src_subfiles_and_subdirs) = &readdirFullpath($src_dir_fullpath,$options);
461
462 if (!$readdir_status) {
463 $had_an_error = 1;
464 if ($strict) {
465 return 0;
466 }
467 }
468 else {
469
470 if ($copytype eq "toplevel") {
471 foreach my $fullpath_subf_or_subd (@$fullpath_src_subfiles_and_subdirs)
472 {
473 if (-f $fullpath_subf_or_subd)
474 {
475 my $fullpath_subf = $fullpath_subf_or_subd;
476 my $ret_val_success = &copyFilesGeneral([$fullpath_subf],$dest,$options);
477
478 if ($ret_val_success == 0) {
479
480 $had_an_error = 1;
481 if ($strict) {
482 return 0;
483 }
484 }
485 }
486
487 }
488 }
489 else {
490 # Recursively copy all the files/dirs in this directory:
491 my $ret_val_success = &_copyFilesRecursiveGeneral($fullpath_src_subfiles_and_subdirs,$next_dest, $depth+1, $options);
492
493 if ($ret_val_success == 0) {
494
495 $had_an_error = 1;
496 if ($strict) {
497 return 0;
498 }
499 }
500 }
501 }
502 }
503 else
504 {
505 my $ret_val_success = &copyFilesGeneral([$file], $dest, $options);
506 if ($ret_val_success == 0) {
507
508 $had_an_error = 1;
509 if ($strict) {
510 # Error condition encountered in copy => immediately bail, passing the error on to outer calling function
511 return 0;
512 }
513 }
514 }
515 }
516
517 # get to here, then everything went well
518
519 if ($had_an_error) {
520 return 0;
521 }
522 else {
523 # true => everything OK
524 return 1;
525 }
526}
527## _copyFilesRecursiveGeneral()
528
529
530
531## @function copyFilesRecursive()
532#
533# recursively copies a file or group of files syntax: cp_r
534# (sourcefiles, destination directory) destination must be a directory
535# to copy one file to another use cp instead
536#
537sub copyFilesRecursive
538{
539 my $dest = pop (@_);
540 my (@srcfiles) = @_;
541
542 return _copyFilesRecursiveGeneral(\@srcfiles,$dest,0,undef);
543}
544
545## copyFilesRecursive()
546
547
548## @function copyFilesRecursiveNoSVN()
549#
550# recursively copies a file or group of files, excluding SVN
551# directories, with syntax: cp_r (sourcefiles, destination directory)
552# destination must be a directory - to copy one file to another use cp
553# instead
554#
555# this should be merged with copyFilesRecursive() at some stage - jmt12
556#
557sub copyFilesRecursiveNoSVN
558{
559 my $dest = pop (@_);
560 my (@srcfiles) = @_;
561
562 return _copyFilesRecursiveGeneral(\@srcfiles,$dest, 0, { 'exclude_filter_re' => "^\\.svn\$" } );
563}
564
565## copyFilesRecursiveNoSVN()
566
567
568## @function copyFilesRecursiveTopLevel()
569#
570# copies a directory and its contents, excluding subdirectories, into a new directory
571#
572# another candidate for merging in with copyFilesRecursive() - jmt12
573#
574sub copyFilesRecursiveTopLevel
575{
576 my $dest = pop (@_);
577 my (@srcfiles) = @_;
578
579 return _copyFilesRecursiveGeneral(\@srcfiles,$dest, 0, { 'copytype' => "toplevel" } );
580}
581
582## copyFilesRecursiveTopLevel()
583
584
585## @function hardlinkFilesRecursive()
586#
587# recursively hard-links a file or group of files syntax similar to
588# how 'cp -r' operates (only hard-linking of course!)
589# (sourcefiles, destination directory) destination must be a directory
590# to copy one file to another use cp instead
591#
592
593sub hardlinkFilesRefRecursive
594{
595 my ($srcfiles_ref,$dest, $options) = @_;
596
597 # only dealing with scalar values in 'options' so OK to shallow copy
598 my $options_clone = (defined $options) ? { %$options } : {};
599
600 # top-up with setting to trigger hard-linking
601 $options_clone->{'hardlink'} = 1;
602
603 _copyFilesRecursiveGeneral($srcfiles_ref,$dest,0, $options_clone);
604}
605
606sub hardlinkFilesRecursive
607{
608 my $dest = pop (@_);
609 my (@srcfiles) = @_;
610
611 _copyFilesRecursiveGeneral(\@srcfiles,$dest,0, { 'hardlink' => 1 });
612}
613
614
615## @function differentFiles()
616#
617# this function returns -1 if either file is not found assumes that
618# $file1 and $file2 are absolute file names or in the current
619# directory $file2 is allowed to be newer than $file1
620#
621sub differentFiles
622{
623 my ($file1, $file2, $verbosity) = @_;
624 $verbosity = 1 unless defined $verbosity;
625
626 $file1 =~ s/\/+$//;
627 $file2 =~ s/\/+$//;
628
629 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
630 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
631
632 return -1 unless (-e $file1 && -e $file2);
633 if ($file1name ne $file2name)
634 {
635 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
636 return 1;
637 }
638
639 my @file1stat = stat ($file1);
640 my @file2stat = stat ($file2);
641
642 if (-d $file1)
643 {
644 if (! -d $file2)
645 {
646 print STDERR "one file is a directory\n" if ($verbosity >= 2);
647 return 1;
648 }
649 return 0;
650 }
651
652 # both must be regular files
653 unless (-f $file1 && -f $file2)
654 {
655 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
656 return 1;
657 }
658
659 # the size of the files must be the same
660 if ($file1stat[7] != $file2stat[7])
661 {
662 print STDERR "different sized files\n" if ($verbosity >= 2);
663 return 1;
664 }
665
666 # the second file cannot be older than the first
667 if ($file1stat[9] > $file2stat[9])
668 {
669 print STDERR "file is older\n" if ($verbosity >= 2);
670 return 1;
671 }
672
673 return 0;
674}
675## differentFiles()
676
677
678## @function directoryExists()
679#
680sub directoryExists
681{
682 my ($filename_full_path) = @_;
683 return &fileTest($filename_full_path, '-d');
684}
685## directoryExists()
686
687
688## @function fileExists()
689#
690sub fileExists
691{
692 my ($filename_full_path) = @_;
693 return &fileTest($filename_full_path, '-f');
694}
695## fileExists()
696
697## @function filenameConcatenate()
698#
699sub filenameConcatenate
700{
701 my $first_file = shift(@_);
702 my (@filenames) = @_;
703
704 # Useful for debugging
705 # -- might make sense to call caller(0) rather than (1)??
706 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
707 # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
708
709 # If first_file is not null or empty, then add it back into the list
710 if (defined $first_file && $first_file =~ /\S/)
711 {
712 unshift(@filenames, $first_file);
713 }
714
715 my $filename = join("/", @filenames);
716
717 # remove duplicate slashes and remove the last slash
718 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin"))
719 {
720 $filename =~ s/[\\\/]+/\\/g;
721 }
722 else
723 {
724 $filename =~ s/[\/]+/\//g;
725 # DB: want a filename abc\de.html to remain like this
726 }
727 $filename =~ s/[\\\/]$//;
728
729 return $filename;
730}
731## filenameConcatenate()
732
733
734
735## @function javaFilenameConcatenate()
736#
737# Same as filenameConcatenate(), except because on Cygwin
738# the java we run is still Windows native, then this means
739# we want the generate filename to be in native Windows format
740sub javaFilenameConcatenate
741{
742 my (@filenames) = @_;
743
744 my $filename_cat = filenameConcatenate(@filenames);
745
746 if ($^O eq "cygwin") {
747 # java program, using a binary that is native to Windows, so need
748 # Windows directory and path separators
749
750 $filename_cat = `cygpath -wp "$filename_cat"`;
751 chomp($filename_cat);
752 $filename_cat =~ s%\\%\\\\%g;
753 }
754
755 return $filename_cat;
756}
757## javaFilenameConcatenate()
758
759
760## @function filePutContents()
761#
762# Create a file and write the given string directly to it
763# @param $path the full path of the file to write as a String
764# @param $content the String to be written to the file
765#
766sub filePutContents
767{
768 my ($path, $content) = @_;
769 if (open(FOUT, '>:utf8', $path))
770 {
771 print FOUT $content;
772 close(FOUT);
773 }
774 else
775 {
776 die('Error! Failed to open file for writing: ' . $path . "\n");
777 }
778}
779## filePutContents()
780
781## @function fileSize()
782#
783sub fileSize
784{
785 my $path = shift(@_);
786 my $file_size = -s $path;
787 return $file_size;
788}
789## fileSize()
790
791## @function fileTest()
792#
793sub fileTest
794{
795 my $filename_full_path = shift @_;
796 my $test_op = shift @_ || "-e";
797
798 # By default tests for existance of file or directory (-e)
799 # Can be made more specific by providing second parameter (e.g. -f or -d)
800
801 my $exists = 0;
802
803 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin"))
804 {
805 require Win32;
806 my $filename_short_path = Win32::GetShortPathName($filename_full_path);
807 if (!defined $filename_short_path)
808 {
809 # Was probably still in UTF8 form (not what is needed on Windows)
810 my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
811 if (defined $unicode_filename_full_path)
812 {
813 $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
814 }
815 }
816 $filename_full_path = $filename_short_path;
817 }
818
819 if (defined $filename_full_path)
820 {
821 $exists = eval "($test_op \$filename_full_path)";
822 }
823
824 return $exists || 0;
825}
826## fileTest()
827
828## @function hardLink()
829# make hard link to file if supported by OS, otherwise copy the file
830#
831sub hardLink
832{
833 my ($src, $dest, $verbosity, $options) = @_;
834
835 # 'strict' defaults to false
836 # see _copyFilesRecursiveGeneral for more details
837 my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0;
838
839 # remove trailing slashes from source and destination files
840 $src =~ s/[\\\/]+$//;
841 $dest =~ s/[\\\/]+$//;
842
843 my $had_an_error = 0;
844
845 ## print STDERR "**** src = ", unicode::debug_unicode_string($src),"\n";
846 # a few sanity checks
847 if (!-e $src)
848 {
849 print STDERR "FileUtils::hardLink() source file \"" . $src . "\" does not exist\n";
850 if ($strict) {
851 return 0;
852 }
853 else {
854 $had_an_error = 1;
855 }
856 }
857 elsif (-d $src)
858 {
859 print STDERR "FileUtils::hardLink() source \"" . $src . "\" is a directory\n";
860 if ($strict) {
861 return 0;
862 }
863 else {
864 $had_an_error = 1;
865 }
866 }
867 elsif (-e $dest)
868 {
869 if ($strict) {
870 return 0;
871 }
872 else {
873 print STDERR "FileUtils::hardLink() dest file ($dest) exists, removing it\n";
874 my $status_ok = &removeFiles($dest);
875
876 if (!$status_ok) {
877 $had_an_error = 1;
878 }
879 }
880 }
881
882 my $dest_dir = &File::Basename::dirname($dest);
883 if (!-e $dest_dir)
884 {
885 my $status_ok = &makeAllDirectories($dest_dir);
886 if ($strict) {
887 return 0;
888 }
889 else {
890 $had_an_error = 1;
891 }
892 }
893
894 if (!link($src, $dest))
895 {
896 if ((!defined $verbosity) || ($verbosity>2))
897 {
898 print STDERR "Warning: FileUtils::hardLink(): unable to create hard link. ";
899 print STDERR " Copying file: $src -> $dest\n";
900 }
901 my $status_ok = &File::Copy::copy($src, $dest);
902 if (!$status_ok) {
903 $had_an_error = 1;
904 }
905 }
906
907 if ($had_an_error) {
908 return 0;
909 }
910 else {
911 # no fatal issue encountered => return true
912 return 1;
913 }
914}
915## hardLink()
916
917## @function isDirectoryEmpty()
918#
919# A method to check if a directory is empty (note that an empty
920# directory still has non-zero size!!!). Code is from
921# http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
922#
923sub isDirectoryEmpty
924{
925 my ($path) = @_;
926 opendir DIR, $path;
927 while(my $entry = readdir DIR)
928 {
929 next if($entry =~ /^\.\.?$/);
930 closedir DIR;
931 return 0;
932 }
933 closedir DIR;
934 return 1;
935}
936## isDirectoryEmpty()
937
938## @function isFilenameAbsolute()
939#
940sub isFilenameAbsolute
941{
942 my ($filename) = @_;
943 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin"))
944 {
945 return ($filename =~ m/^(\w:)?\\/);
946 }
947 return ($filename =~ m/^\//);
948}
949# isFilenameAbsolute()
950
951## @function isSymbolicLink
952#
953# Determine if a given path is a symbolic link (soft link)
954#
955sub isSymbolicLink
956{
957 my $path = shift(@_);
958 my $is_soft_link = -l $path;
959 return $is_soft_link;
960}
961## isSymbolicLink()
962
963## @function makeAllDirectories()
964#
965# in case anyone cares - I did some testing (using perls Benchmark module)
966# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
967# slightly faster (surprisingly) - Stefan.
968#
969sub makeAllDirectories
970{
971 my ($dir) = @_;
972
973 # use / for the directory separator, remove duplicate and trailing slashes
974 $dir=~s/[\\\/]+/\//g;
975 $dir=~s/[\\\/]+$//;
976
977 # make sure the cache directory exists
978 my $dirsofar = "";
979 my $first = 1;
980 foreach my $dirname (split ("/", $dir))
981 {
982 $dirsofar .= "/" unless $first;
983 $first = 0;
984
985 $dirsofar .= $dirname;
986
987 next if $dirname =~ /^(|[a-z]:)$/i;
988 if (!-e $dirsofar)
989 {
990 my $store_umask = umask(0002);
991 my $mkdir_ok = mkdir ($dirsofar, 0777);
992 umask($store_umask);
993 if (!$mkdir_ok)
994 {
995 print STDERR "FileUtils::makeAllDirectories() could not create directory $dirsofar\n";
996 return 0;
997 }
998 }
999 }
1000 return 1;
1001}
1002## makeAllDirectories()
1003
1004## @function makeDirectory()
1005#
1006sub makeDirectory
1007{
1008 my ($dir) = @_;
1009
1010 my $store_umask = umask(0002);
1011 my $mkdir_ok = mkdir ($dir, 0777);
1012 umask($store_umask);
1013
1014 if (!$mkdir_ok)
1015 {
1016 print STDERR "FileUtils::makeDirectory() could not create directory $dir\n";
1017 return 0;
1018 }
1019
1020 # get to here, everything went as expected
1021 return 1;
1022}
1023## makeDirectory()
1024
1025## @function modificationTime()
1026#
1027sub modificationTime
1028{
1029 my $path = shift(@_);
1030 my @file_status = stat($path);
1031 return $file_status[9];
1032}
1033## modificationTime()
1034
1035## @function moveDirectoryContents()
1036#
1037# Move the contents of source directory into target directory (as
1038# opposed to merely replacing target dir with the src dir) This can
1039# overwrite any files with duplicate names in the target but other
1040# files and folders in the target will continue to exist
1041#
1042sub moveDirectoryContents
1043{
1044 # Currently has no return values!!!
1045
1046 #### !!!! worthy of upgrading to include $options, and then use
1047 #### !!!! 'strict' to determine whether it returns 0 when hitting
1048 #### !!!! an issue immediately, or else persevere, and continue
1049
1050 my ($src_dir, $dest_dir) = @_;
1051
1052 # Obtain listing of all files within src_dir
1053 # Note that readdir lists relative paths, as well as . and ..
1054 opendir(DIR, "$src_dir");
1055 my @files= readdir(DIR);
1056 close(DIR);
1057
1058 my @full_path_files = ();
1059 foreach my $file (@files)
1060 {
1061 # process all except . and ..
1062 unless($file eq "." || $file eq "..")
1063 {
1064 my $dest_subdir = &filenameConcatenate($dest_dir, $file); # $file is still a relative path
1065
1066 # construct absolute paths
1067 $file = &filenameConcatenate($src_dir, $file); # $file is now an absolute path
1068
1069 # Recurse on directories which have an equivalent in target dest_dir
1070 # If $file is a directory that already exists in target $dest_dir,
1071 # then a simple move operation will fail (definitely on Windows).
1072 if(-d $file && -d $dest_subdir)
1073 {
1074 #print STDERR "**** $file is a directory also existing in target, its contents to be copied to $dest_subdir\n";
1075 &moveDirectoryContents($file, $dest_subdir);
1076
1077 # now all content is moved across, delete empty dir in source folder
1078 if(&isDirectoryEmpty($file))
1079 {
1080 if (!rmdir $file)
1081 {
1082 print STDERR "ERROR. FileUtils::moveDirectoryContents() couldn't remove directory $file\n";
1083 }
1084 }
1085 # error
1086 else
1087 {
1088 print STDERR "ERROR. FileUtils::moveDirectoryContents(): subfolder $file still non-empty after moving contents to $dest_subdir\n";
1089 }
1090 }
1091 # process files and any directories that don't already exist with a simple move
1092 else
1093 {
1094 push(@full_path_files, $file);
1095 }
1096 }
1097 }
1098
1099 # create target toplevel folder or subfolders if they don't exist
1100 if(!&directoryExists($dest_dir))
1101 {
1102 &makeDirectory($dest_dir);
1103 }
1104
1105 #print STDERR "@@@@@ Copying files |".join(",", @full_path_files)."| to: $dest_dir\n";
1106
1107 # if non-empty, there's something to copy across
1108 if(@full_path_files)
1109 {
1110 &moveFiles(@full_path_files, $dest_dir);
1111 }
1112}
1113## moveDirectoryContents()
1114
1115## @function moveFiles()
1116#
1117# moves a file or a group of files
1118#
1119sub moveFiles
1120{
1121 my $dest = pop (@_);
1122 my (@srcfiles) = @_;
1123
1124 # remove trailing slashes from source and destination files
1125 $dest =~ s/[\\\/]+$//;
1126 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
1127
1128 # a few sanity checks
1129 if (scalar (@srcfiles) == 0)
1130 {
1131 print STDERR "FileUtils::moveFiles() no destination directory given\n";
1132 return 0;
1133 }
1134 elsif ((scalar (@srcfiles) > 1) && (!-d $dest))
1135 {
1136 print STDERR "FileUtils::moveFiles() if multiple source files are given the destination must be a directory\n";
1137 return 0;
1138 }
1139
1140 my $had_an_error = 0;
1141
1142 # move the files
1143 foreach my $file (@srcfiles)
1144 {
1145 my $tempdest = $dest;
1146 if (-d $tempdest)
1147 {
1148 my ($filename) = $file =~ /([^\\\/]+)$/;
1149 $tempdest .= "/$filename";
1150 }
1151 if (!-e $file)
1152 {
1153 print STDERR "FileUtils::moveFiles() $file does not exist\n";
1154 $had_an_error = 1;
1155 }
1156 else
1157 {
1158 if (!rename($file, $tempdest))
1159 {
1160 print STDERR "**** Failed to rename $file to $tempdest. Attempting copy and then delete\n";
1161 my $copy_status_ok = &File::Copy::copy($file, $tempdest);
1162 if ($copy_status_ok) {
1163 my $remove_status_ok = &removeFiles($file);
1164 if (!$remove_status_ok) {
1165 $had_an_error = 1;
1166 }
1167 }
1168 else {
1169 $had_an_error = 1;
1170 }
1171 }
1172 # rename (partially) succeeded) but srcfile still exists after rename
1173 elsif (-e $file)
1174 {
1175 #print STDERR "*** srcfile $file still exists after rename to $tempdest\n";
1176 if (!-e $tempdest)
1177 {
1178 print STDERR "@@@@ ERROR: $tempdest does not exist\n";
1179 }
1180 # Sometimes the rename operation fails (as does
1181 # File::Copy::move). This turns out to be because the files
1182 # are hard-linked. Need to do a copy-delete in this case,
1183 # however, the copy step is not necessary: the srcfile got
1184 # renamed into tempdest, but srcfile itself still exists,
1185 # delete it. &File::Copy::copy($file, $tempdest);
1186 my $remove_status_ok = &removeFiles($file);
1187 if (!$remove_status_ok) {
1188 $had_an_error = 1;
1189 }
1190 }
1191 }
1192 }
1193
1194 if ($had_an_error) {
1195 return 0;
1196 }
1197 else {
1198 return 1;
1199 }
1200}
1201## moveFiles()
1202
1203
1204## @function renameDirectory()
1205#
1206# rename a directory
1207# (effectively a move, where the destination name cannot already exist)
1208#
1209sub renameDirectory
1210{
1211 my ($srcdir,$dstdir) = @_;
1212
1213 my $had_an_error = 0;
1214
1215 if (!-d $srcdir) {
1216 print STDERR "FileUtils::renameDirectory() Error - Source name must be an existing directory\n";
1217 print STDERR "Source name was: $srcdir\n";
1218 $had_an_error = 1;
1219 }
1220 elsif (-e $dstdir) {
1221 print STDERR "FileUtils::renameDirectory() Error - Destination name must not already exist\n";
1222 print STDERR "Destination name was: $dstdir\n";
1223 $had_an_error = 1;
1224
1225 }
1226 else {
1227 if (!rename($srcdir,$dstdir)) {
1228 print STDERR "FileUtils::renameDirectory() -- Error occured moving source name to destination name\n";
1229 print STDERR "Source name was: $srcdir\n";
1230 print STDERR "Destination name was: $dstdir\n";
1231 $had_an_error = 1;
1232 }
1233 }
1234
1235 if ($had_an_error) {
1236 return 0; # i.e., not OK!
1237 }
1238 else {
1239 return 1;
1240 }
1241}
1242## renameDirectory()
1243
1244## @function openFileHandle()
1245#
1246sub openFileHandle
1247{
1248 my $path = shift(@_);
1249 my $mode = shift(@_);
1250 my $fh_ref = shift(@_);
1251 my $encoding = shift(@_);
1252 my $mode_symbol;
1253 if ($mode eq 'w' || $mode eq '>')
1254 {
1255 $mode_symbol = '>';
1256 $mode = 'writing';
1257 }
1258 elsif ($mode eq 'a' || $mode eq '>>')
1259 {
1260 $mode_symbol = '>>';
1261 $mode = 'appending';
1262 }
1263 else
1264 {
1265 $mode_symbol = '<';
1266 $mode = 'reading';
1267 }
1268 if (defined $encoding)
1269 {
1270 $mode_symbol .= ':' . $encoding;
1271 }
1272 return open($$fh_ref, $mode_symbol, $path);
1273}
1274## openFileHandle()
1275
1276
1277
1278## @function readDirectory()
1279#
1280sub readDirectory
1281{
1282 my $path = shift(@_);
1283
1284 my $options = { 'strict' => 1 };
1285
1286 my ($ret_val_success,$files_and_dirs) = _readdirWithOptions($path,$options);
1287
1288 if (!$ret_val_success) {
1289 die("Error! Failed to list files in directory: " . $path . "\n");
1290 }
1291
1292 return $files_and_dirs;
1293}
1294## readDirectory()
1295
1296## @function readDirectoryFiltered()
1297#
1298sub readDirectoryFiltered
1299{
1300 my ($path,$exclude_filter_re,$include_filter_re) = @_;
1301
1302 my $options = { 'strict' => 1 };
1303
1304 $options->{'exclude_filter_re'} = $exclude_filter_re if defined $exclude_filter_re;
1305 $options->{'include_filter_re'} = $include_filter_re if defined $include_filter_re;
1306
1307 my ($ret_val_success,$files_and_dirs) = _readdirWithOptions($path,$options);
1308
1309 if (!$ret_val_success) {
1310 die("Error! Failed to list files in directory: " . $path . "\n");
1311 }
1312
1313 return $files_and_dirs;
1314}
1315
1316## readDirectoryFiltered()
1317
1318## @function readUTF8File()
1319#
1320# read contents from a file containing UTF8 using sysread, a fast implementation of file 'slurp'
1321#
1322# Parameter filename, the filepath to read from.
1323# Returns undef if there was any trouble opening the file or reading from it.
1324#
1325sub readUTF8File
1326{
1327 my $filename = shift(@_);
1328
1329 print STDERR "@@@ Warning FileUtils::readFile() not yet implemented for parallel processing. Using regular version...\n";
1330
1331 #open(FIN,"<$filename") or die "FileUtils::readFile: Unable to open $filename for reading...ERROR: $!\n";
1332
1333 if(!open(FIN,"<$filename")) {
1334 print STDERR "FileUtils::readFile: Unable to open $filename for reading...ERROR: $!\n";
1335 return undef;
1336 }
1337
1338 # decode the bytes in the file with UTF8 enc,
1339 # to get unicode aware strings that represent utf8 chars
1340 binmode(FIN,":utf8");
1341
1342 my $contents = undef;
1343 # Read in the entire contents of the file in one hit
1344 sysread(FIN, $contents, -s FIN);
1345 close(FIN);
1346 return $contents;
1347}
1348## readUTF8File()
1349
1350## @function writeUTF8File()
1351#
1352# write UTF8 contents to a file.
1353#
1354# Parameter filename, the filepath to write to
1355# Parameter contentRef, a *reference* to the contents to write out
1356#
1357sub writeUTF8File
1358{
1359 my ($filename, $contentRef) = @_;
1360
1361 print STDERR "@@@ Warning FileUtils::writeFile() not yet implemented for parallel processing. Using regular version...\n";
1362
1363 open(FOUT, ">$filename") or die "FileUtils::writeFile: Unable to open $filename for writing out contents...ERROR: $!\n";
1364 # encode the unicode aware characters in the string as utf8
1365 # before writing out the resulting bytes
1366 binmode(FOUT,":utf8");
1367
1368 print FOUT $$contentRef;
1369 close(FOUT);
1370}
1371## writeUTF8File()
1372
1373## @function removeFiles()
1374#
1375# removes files (but not directories)
1376#
1377sub removeFiles
1378{
1379 my (@files) = @_;
1380 my @filefiles = ();
1381
1382 my $ret_val_success = 1; # default (true) is to assume everything works out
1383
1384 # make sure the files we want to delete exist
1385 # and are regular files
1386 foreach my $file (@files)
1387 {
1388 if (!-e $file)
1389 {
1390 print STDERR "Warning: FileUtils::removeFiles() $file does not exist\n";
1391 }
1392 elsif ((!-f $file) && (!-l $file))
1393 {
1394 print STDERR "Warning: FileUtils::removeFiles() $file is not a regular (or symbolic) file\n";
1395 }
1396 else
1397 {
1398 push (@filefiles, $file);
1399 }
1400 }
1401
1402 # remove the files
1403 my $numremoved = unlink @filefiles;
1404
1405 # check to make sure all of them were removed
1406 if ($numremoved != scalar(@filefiles)) {
1407 print STDERR "FileUtils::removeFiles() Not all files were removed\n";
1408
1409 if ($numremoved == 0) {
1410 # without a '$options' parameter to provide strict=true/false then
1411 # interpret this particular situation as a "major" fail
1412 # => asked to remove files and not a single one was removed!
1413 $ret_val_success = 0;
1414 }
1415 }
1416
1417 return $ret_val_success;
1418}
1419## removeFiles()
1420
1421## @function removeFilesDebug()
1422#
1423# removes files (but not directories) - can rename this to the default
1424# "rm" subroutine when debugging the deletion of individual files.
1425# Unused?
1426#
1427sub removeFilesDebug
1428{
1429 my (@files) = @_;
1430 my @filefiles = ();
1431
1432 # make sure the files we want to delete exist
1433 # and are regular files
1434 foreach my $file (@files)
1435 {
1436 if (!-e $file)
1437 {
1438 print STDERR "FileUtils::removeFilesDebug() " . $file . " does not exist\n";
1439 }
1440 elsif ((!-f $file) && (!-l $file))
1441 {
1442 print STDERR "FileUtils::removeFilesDebug() " . $file . " is not a regular (or symbolic) file\n";
1443 }
1444 # debug message
1445 else
1446 {
1447 unlink($file) or warn "Could not delete file " . $file . ": " . $! . "\n";
1448 }
1449 }
1450}
1451## removeFilesDebug()
1452
1453## @function removeFilesFiltered()
1454#
1455# NOTE: counterintuitively named, the parameter:
1456# $file_accept_re determines which files are blacklisted (will be REMOVED by this sub)
1457# $file_reject_re determines which files are whitelisted (will NOT be REMOVED)
1458#
1459sub removeFilesFiltered
1460{
1461 my ($files,$file_accept_re,$file_reject_re, $options) = @_;
1462
1463 # 'strict' defaults to false
1464 # see _copyFilesRecursiveGeneral for more details
1465 my $strict = (defined $options && $options->{'strict'}) ? $options->{'strict'} : 0;
1466
1467 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
1468 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
1469 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
1470
1471 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
1472
1473 my $had_an_error = 0;
1474
1475 # recursively remove the files
1476 foreach my $file (@files_array)
1477 {
1478 $file =~ s/[\/\\]+$//; # remove trailing slashes
1479
1480 if (!-e $file)
1481 {
1482 # handle this as a warning rather than a fatal error that stops deleting files/dirs
1483 print STDERR "FileUtils::removeFilesFiltered() $file does not exist\n";
1484 $had_an_error = 1;
1485 last if ($strict);
1486 }
1487 # don't recurse down symbolic link
1488 elsif ((-d $file) && (!-l $file))
1489 {
1490 # specified '$file' is a directory => get the contents of this directory
1491 if (!opendir (INDIR, $file))
1492 {
1493 print STDERR "FileUtils::removeFilesFiltered() could not open directory $file\n";
1494 $had_an_error = 1;
1495 last;
1496 }
1497 else
1498 {
1499 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
1500 closedir (INDIR);
1501
1502 # remove all the files in this directory
1503 map {$_="$file/$_";} @filedir;
1504 my $remove_success_ok = &removeFilesFiltered(\@filedir,$file_accept_re,$file_reject_re);
1505
1506 if ($remove_success_ok) {
1507 if (!defined $file_accept_re && !defined $file_reject_re)
1508 {
1509 # no filters were in effect, and all files were removed
1510 # => remove this directory
1511 if (!rmdir $file)
1512 {
1513 print STDERR "FileUtils::removeFilesFiltered() couldn't remove directory $file\n";
1514
1515 $had_an_error = 1; # back to there being a problem
1516 last if ($strict);
1517 }
1518 }
1519 }
1520 else {
1521 # had a problems in the above
1522 $had_an_error = 1;
1523 last if ($strict);
1524 }
1525 }
1526 }
1527 else
1528 {
1529 # File exists => skip if it matches the file_reject_re
1530
1531 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
1532
1533 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
1534 {
1535 # remove this file
1536 my $remove_success_ok = &removeFiles($file);
1537
1538 if (!$remove_success_ok) {
1539 $had_an_error = 1;
1540 last if ($strict);
1541 }
1542 }
1543 }
1544 }
1545
1546 if ($had_an_error) {
1547 return 0;
1548 }
1549 else {
1550 return 1;
1551 }
1552}
1553## removeFilesFiltered()
1554
1555## @function removeFilesRecursive()
1556#
1557# The equivalent of "rm -rf" with all the dangers therein
1558#
1559sub removeFilesRecursive
1560{
1561 my (@files) = @_;
1562
1563 # use the more general (but reterospectively written) function
1564 # filtered_rm_r function() with no accept or reject expressions
1565 return &removeFilesFiltered(\@files,undef,undef);
1566}
1567## removeFilesRecursive()
1568
1569## @function sanitizePath()
1570#
1571sub sanitizePath
1572{
1573 my ($path) = @_;
1574
1575 # fortunately filename concatenate will perform all the double slash
1576 # removal and end slash removal we need, and in a protocol aware
1577 # fashion
1578 return &filenameConcatenate($path);
1579}
1580## sanitizePath()
1581
1582## @function softLink()
1583#
1584# make soft link to file if supported by OS, otherwise copy file
1585#
1586sub softLink
1587{
1588 my ($src, $dest, $ensure_paths_absolute) = @_;
1589
1590 # remove trailing slashes from source and destination files
1591 $src =~ s/[\\\/]+$//;
1592 $dest =~ s/[\\\/]+$//;
1593
1594 # Ensure file paths are absolute IF requested to do so
1595 # Soft_linking didn't work for relative paths
1596 if(defined $ensure_paths_absolute && $ensure_paths_absolute)
1597 {
1598 # We need to ensure that the src file is the absolute path
1599 # See http://perldoc.perl.org/File/Spec.html
1600 # it's relative
1601 if(!File::Spec->file_name_is_absolute( $src ))
1602 {
1603 $src = File::Spec->rel2abs($src); # make absolute
1604 }
1605 # Might as well ensure that the destination file's absolute path is used
1606 if(!File::Spec->file_name_is_absolute( $dest ))
1607 {
1608 $dest = File::Spec->rel2abs($dest); # make absolute
1609 }
1610 }
1611
1612 # a few sanity checks
1613 if (!-e $src)
1614 {
1615 print STDERR "FileUtils::softLink() source file $src does not exist\n";
1616 return 0;
1617 }
1618
1619 my $dest_dir = &File::Basename::dirname($dest);
1620 if (!-e $dest_dir)
1621 {
1622 &makeAllDirectories($dest_dir);
1623 }
1624
1625 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin"))
1626 {
1627 # symlink not supported on windows
1628 &File::Copy::copy ($src, $dest);
1629 }
1630 elsif (!eval {symlink($src, $dest)})
1631 {
1632 print STDERR "FileUtils::softLink(): unable to create soft link.\n";
1633 return 0;
1634 }
1635 return 1;
1636}
1637## softLink()
1638
1639## @function synchronizeDirectory()
1640#
1641# updates a copy of a directory in some other part of the filesystem
1642# verbosity settings are: 0=low, 1=normal, 2=high
1643# both $fromdir and $todir should be absolute paths
1644#
1645sub synchronizeDirectory
1646{
1647 my ($fromdir, $todir, $verbosity) = @_;
1648 $verbosity = 1 unless defined $verbosity;
1649
1650 # use / for the directory separator, remove duplicate and
1651 # trailing slashes
1652 $fromdir=~s/[\\\/]+/\//g;
1653 $fromdir=~s/[\\\/]+$//;
1654 $todir=~s/[\\\/]+/\//g;
1655 $todir=~s/[\\\/]+$//;
1656
1657 &makeAllDirectories($todir);
1658
1659 # get the directories in ascending order
1660 if (!opendir (FROMDIR, $fromdir))
1661 {
1662 print STDERR "FileUtils::synchronizeDirectory() could not read directory $fromdir\n";
1663 return;
1664 }
1665 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
1666 closedir (FROMDIR);
1667
1668 if (!opendir (TODIR, $todir))
1669 {
1670 print STDERR "FileUtils::synchronizeDirectory() could not read directory $todir\n";
1671 return;
1672 }
1673 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
1674 closedir (TODIR);
1675
1676 my $fromi = 0;
1677 my $toi = 0;
1678
1679 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
1680 {
1681 # print "fromi: $fromi toi: $toi\n";
1682
1683 # see if we should delete a file/directory
1684 # this should happen if the file/directory
1685 # is not in the from list or if its a different
1686 # size, or has an older timestamp
1687 if ($toi < scalar(@todir))
1688 {
1689 if (($fromi >= scalar(@fromdir)) || ($todir[$toi] lt $fromdir[$fromi] || ($todir[$toi] eq $fromdir[$fromi] && &differentFiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]", $verbosity))))
1690 {
1691
1692 # the files are different
1693 &removeFilesRecursive("$todir/$todir[$toi]");
1694 splice(@todir, $toi, 1); # $toi stays the same
1695
1696 }
1697 elsif ($todir[$toi] eq $fromdir[$fromi])
1698 {
1699 # the files are the same
1700 # if it is a directory, check its contents
1701 if (-d "$todir/$todir[$toi]")
1702 {
1703 &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
1704 }
1705
1706 $toi++;
1707 $fromi++;
1708 next;
1709 }
1710 }
1711
1712 # see if we should insert a file/directory
1713 # we should insert a file/directory if there
1714 # is no tofiles left or if the tofile does not exist
1715 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) || $todir[$toi] gt $fromdir[$fromi]))
1716 {
1717 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
1718 splice (@todir, $toi, 0, $fromdir[$fromi]);
1719
1720 $toi++;
1721 $fromi++;
1722 }
1723 }
1724}
1725## synchronizeDirectory()
1726
17271;
Note: See TracBrowser for help on using the repository browser.