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

Last change on this file since 37248 was 37248, checked in by davidb, 16 months ago

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