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

Last change on this file since 37034 was 37034, checked in by davidb, 9 months ago

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