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

Last change on this file since 38935 was 38492, checked in by kjdon, 5 months ago

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