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

Last change on this file since 32090 was 32090, checked in by ak19, 6 years ago

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