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

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

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