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

Last change on this file since 27306 was 27306, checked in by jmt12, 11 years ago

Moving the critical file-related functions (copy, rm, etc) out of util.pm into their own proper class FileUtils. Use of the old functions in util.pm will prompt deprecated warning messages. There may be further functions that could be moved across in the future, but these are the critical ones when considering supporting other filesystems (HTTP, HDFS, WebDav, etc). Updated some key files to use the new functions so now deprecated messages thrown when importing/building demo collection 'out of the box'
File size: 30.0 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
34# Greenstone modules
35use util;
36
37################################################################################
38# util::cachedir() => FileUtils::synchronizeDirectories()
39# util::cp() => FileUtils::copyFiles()
40# util::cp_r() => FileUtils::copyFilesRecursive()
41# util::cp_r_nosvn() => FileUtils::copyFilesRecursiveNoSVN()
42# util::cp_r_toplevel() => FileUtils::copyFilesRecursiveTopLevel()
43# util::different_files() => FileUtils::differentFiles()
44# util::dir_exists() => FileUtils::directoryExists()
45# util::fd_exists() => FileUtils::fileTest()
46# util::file_exists() => FileUtils::fileExists()
47# util::filename_cat() => FileUtils::filenameConcatenate()
48# util::filename_is_absolute() => FileUtils::isFilenameAbsolute()
49# util::filtered_rm_r() => FileUtils::removeFilesFiltered()
50# util::hard_link() => FileUtils::hardLink()
51# util::mk_all_dir() => FileUtils::makeAllDirectories()
52# util::mv() => FileUtils::moveFiles()
53# util::mk_dir() => FileUtils::makeDirectory()
54# util::mv_dir_contents() => FileUtils::moveDirectoryContents()
55# util::rm() => FileUtils::removeFiles()
56# util::rm_r() => FileUtils::removeFilesRecursive()
57# util::soft_link() => FileUtils::softLink()
58
59################################################################################
60# Note: there are lots of functions involving files/directories/paths
61# etc found in utils.pm that are not represented here. My intention
62# was to just have those functions that need to be dynamic based on
63# filesystem, or need some rejigging to be filesystem aware. There is
64# an argument, I guess, for moving some of the other functions here so
65# that they are nicely encapsulated - but the question is what to do
66# with functions like filename_within_directory_url_format() which is
67# more URL based than file based.
68################################################################################
69
70## @function differentFiles()
71#
72# this function returns -1 if either file is not found assumes that
73# $file1 and $file2 are absolute file names or in the current
74# directory $file2 is allowed to be newer than $file1
75#
76sub differentFiles
77{
78 my ($file1, $file2, $verbosity) = @_;
79 $verbosity = 1 unless defined $verbosity;
80
81 $file1 =~ s/\/+$//;
82 $file2 =~ s/\/+$//;
83
84 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
85 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
86
87 return -1 unless (-e $file1 && -e $file2);
88 if ($file1name ne $file2name)
89 {
90 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
91 return 1;
92 }
93
94 my @file1stat = stat ($file1);
95 my @file2stat = stat ($file2);
96
97 if (-d $file1)
98 {
99 if (! -d $file2)
100 {
101 print STDERR "one file is a directory\n" if ($verbosity >= 2);
102 return 1;
103 }
104 return 0;
105 }
106
107 # both must be regular files
108 unless (-f $file1 && -f $file2)
109 {
110 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
111 return 1;
112 }
113
114 # the size of the files must be the same
115 if ($file1stat[7] != $file2stat[7])
116 {
117 print STDERR "different sized files\n" if ($verbosity >= 2);
118 return 1;
119 }
120
121 # the second file cannot be older than the first
122 if ($file1stat[9] > $file2stat[9])
123 {
124 print STDERR "file is older\n" if ($verbosity >= 2);
125 return 1;
126 }
127
128 return 0;
129}
130## differentFiles()
131
132## @function directoryExists()
133#
134sub directoryExists
135{
136 my ($filename_full_path) = @_;
137 return &fileTest($filename_full_path, '-d');
138}
139## directoryExists()
140
141## @function closeFileHandle
142#
143sub closeFileHandle
144{
145 my ($path, $fh_ref) = @_;
146 close($$fh_ref);
147}
148## closeFileHandle()
149
150## @function copyFiles()
151#
152# copies a file or a group of files
153#
154sub copyFiles
155{
156 my $dest = pop (@_);
157 my (@srcfiles) = @_;
158
159 # remove trailing slashes from source and destination files
160 $dest =~ s/[\\\/]+$//;
161 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
162
163 # a few sanity checks
164 if (scalar (@srcfiles) == 0)
165 {
166 print STDERR "FileUtils::copyFiles() no destination directory given\n";
167 return;
168 }
169 elsif ((scalar (@srcfiles) > 1) && (!-d $dest))
170 {
171 print STDERR "FileUtils::copyFiles() if multiple source files are given the destination must be a directory\n";
172 return;
173 }
174
175 # copy the files
176 foreach my $file (@srcfiles)
177 {
178 my $tempdest = $dest;
179 if (-d $tempdest)
180 {
181 my ($filename) = $file =~ /([^\\\/]+)$/;
182 $tempdest .= "/$filename";
183 }
184 if (!-e $file)
185 {
186 print STDERR "FileUtils::copyFiles() $file does not exist\n";
187 }
188 elsif (!-f $file)
189 {
190 print STDERR "FileUtils::copyFiles() $file is not a plain file\n";
191 }
192 else
193 {
194 &File::Copy::copy ($file, $tempdest);
195 }
196 }
197}
198## copyFiles()
199
200## @function copyFilesRecursive()
201#
202# recursively copies a file or group of files syntax: cp_r
203# (sourcefiles, destination directory) destination must be a directory
204# to copy one file to another use cp instead
205#
206sub copyFilesRecursive
207{
208 my $dest = pop (@_);
209 my (@srcfiles) = @_;
210
211 # a few sanity checks
212 if (scalar (@srcfiles) == 0)
213 {
214 print STDERR "FileUtils::copyFilesRecursive() no destination directory given\n";
215 return;
216 }
217 elsif (-f $dest)
218 {
219 print STDERR "FileUtils::copyFilesRecursive() destination must be a directory\n";
220 return;
221 }
222
223 # create destination directory if it doesn't exist already
224 if (! -d $dest)
225 {
226 my $store_umask = umask(0002);
227 mkdir ($dest, 0777);
228 umask($store_umask);
229 }
230
231 # copy the files
232 foreach my $file (@srcfiles)
233 {
234
235 if (!-e $file)
236 {
237 print STDERR "FileUtils::copyFilesRecursive() $file does not exist\n";
238 }
239 elsif (-d $file)
240 {
241 # make the new directory
242 my ($filename) = $file =~ /([^\\\/]*)$/;
243 $dest = &filenameConcatenate($dest, $filename);
244 my $store_umask = umask(0002);
245 mkdir ($dest, 0777);
246 umask($store_umask);
247
248 # get the contents of this directory
249 if (!opendir (INDIR, $file))
250 {
251 print STDERR "FileUtils::copyFilesRecursive() could not open directory $file\n";
252 }
253 else
254 {
255 my @filedir = readdir (INDIR);
256 closedir (INDIR);
257 foreach my $f (@filedir)
258 {
259 next if $f =~ /^\.\.?$/;
260 # copy all the files in this directory
261 my $ff = &filenameConcatenate($file, $f);
262 &copyFilesRecursive($ff, $dest);
263 }
264 }
265
266 }
267 else
268 {
269 &copyFiles($file, $dest);
270 }
271 }
272}
273## copyFilesRecursive()
274
275## @function copyFilesRecursiveNoSVN()
276#
277# recursively copies a file or group of files, excluding SVN
278# directories, with syntax: cp_r (sourcefiles, destination directory)
279# destination must be a directory - to copy one file to another use cp
280# instead
281#
282# this should be merged with copyFilesRecursive() at some stage - jmt12
283#
284sub copyFilesRecursiveNoSVN
285{
286 my $dest = pop (@_);
287 my (@srcfiles) = @_;
288
289 # a few sanity checks
290 if (scalar (@srcfiles) == 0)
291 {
292 print STDERR "FileUtils::copyFilesRecursiveNoSVN() no destination directory given\n";
293 return;
294 }
295 elsif (-f $dest)
296 {
297 print STDERR "FileUtils::copyFilesRecursiveNoSVN() destination must be a directory\n";
298 return;
299 }
300
301 # create destination directory if it doesn't exist already
302 if (! -d $dest)
303 {
304 my $store_umask = umask(0002);
305 mkdir ($dest, 0777);
306 umask($store_umask);
307 }
308
309 # copy the files
310 foreach my $file (@srcfiles)
311 {
312 if (!-e $file)
313 {
314 print STDERR "copyFilesRecursiveNoSVN() $file does not exist\n";
315 }
316 elsif (-d $file)
317 {
318 # make the new directory
319 my ($filename) = $file =~ /([^\\\/]*)$/;
320 $dest = &filenameConcatnate($dest, $filename);
321 my $store_umask = umask(0002);
322 mkdir ($dest, 0777);
323 umask($store_umask);
324
325 # get the contents of this directory
326 if (!opendir (INDIR, $file))
327 {
328 print STDERR "copyFilesRecursiveNoSVN() could not open directory $file\n";
329 }
330 else
331 {
332 my @filedir = readdir (INDIR);
333 closedir (INDIR);
334 foreach my $f (@filedir)
335 {
336 next if $f =~ /^\.\.?$/;
337 next if $f =~ /^\.svn$/;
338 # copy all the files in this directory
339 my $ff = &filenameConcatenate($file, $f);
340 # util.pm version incorrectly called cp_r here - jmt12
341 &recursiveCopyNoSVN($ff, $dest);
342 }
343 }
344 }
345 else
346 {
347 &copyFiles($file, $dest);
348 }
349 }
350}
351## copyFilesRecursiveNoSVN()
352
353## @function copyFilesRecursiveTopLevel()
354#
355# copies a directory and its contents, excluding subdirectories, into a new directory
356#
357# another candidate for merging in with copyFilesRecursive() - jmt12
358#
359sub copyFilesRecursiveTopLevel
360{
361 my $dest = pop (@_);
362 my (@srcfiles) = @_;
363
364 # a few sanity checks
365 if (scalar (@srcfiles) == 0)
366 {
367 print STDERR "FileUtils::copyFilesRecursiveTopLevel() no destination directory given\n";
368 return;
369 }
370 elsif (-f $dest)
371 {
372 print STDERR "FileUtils::copyFilesRecursiveTopLevel() destination must be a directory\n";
373 return;
374 }
375
376 # create destination directory if it doesn't exist already
377 if (! -d $dest)
378 {
379 my $store_umask = umask(0002);
380 mkdir ($dest, 0777);
381 umask($store_umask);
382 }
383
384 # copy the files
385 foreach my $file (@srcfiles)
386 {
387 if (!-e $file)
388 {
389 print STDERR "FileUtils::copyFilesRecursiveTopLevel() $file does not exist\n";
390 }
391 elsif (-d $file)
392 {
393 # make the new directory
394 my ($filename) = $file =~ /([^\\\/]*)$/;
395 $dest = &filenameConcatenate($dest, $filename);
396 my $store_umask = umask(0002);
397 mkdir ($dest, 0777);
398 umask($store_umask);
399
400 # get the contents of this directory
401 if (!opendir (INDIR, $file))
402 {
403 print STDERR "FileUtils::copyFilesRecursiveTopLevel() could not open directory $file\n";
404 }
405 else
406 {
407 my @filedir = readdir (INDIR);
408 closedir (INDIR);
409 foreach my $f (@filedir)
410 {
411 next if $f =~ /^\.\.?$/;
412
413 # copy all the files in this directory, but not directories
414 my $ff = &filenameConcatenate($file, $f);
415 if (-f $ff)
416 {
417 &copyFiles($ff, $dest);
418 #&cp_r ($ff, $dest);
419 }
420 }
421 }
422 }
423 else
424 {
425 &copyFiles($file, $dest);
426 }
427 }
428}
429## copyFilesRecursiveTopLevel()
430
431## @function fileExists()
432#
433sub fileExists
434{
435 my ($filename_full_path) = @_;
436 return &fileTest($filename_full_path, '-f');
437}
438## fileExists()
439
440## @function filenameConcatenate()
441#
442sub filenameConcatenate
443{
444 my $first_file = shift(@_);
445 my (@filenames) = @_;
446
447 # Useful for debugging
448 # -- might make sense to call caller(0) rather than (1)??
449 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
450 # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
451
452 # If first_file is not null or empty, then add it back into the list
453 if (defined $first_file && $first_file =~ /\S/)
454 {
455 unshift(@filenames, $first_file);
456 }
457
458 my $filename = join("/", @filenames);
459
460 # remove duplicate slashes and remove the last slash
461 if ($ENV{'GSDLOS'} =~ /^windows$/i)
462 {
463 $filename =~ s/[\\\/]+/\\/g;
464 }
465 else
466 {
467 $filename =~ s/[\/]+/\//g;
468 # DB: want a filename abc\de.html to remain like this
469 }
470 $filename =~ s/[\\\/]$//;
471
472 return $filename;
473}
474## filenameConcatenate()
475
476## @function filePutContents()
477#
478# Create a file and write the given string directly to it
479# @param $path the full path of the file to write as a String
480# @param $content the String to be written to the file
481#
482sub filePutContents
483{
484 my ($path, $content) = @_;
485 if (open(FOUT, '>:utf8', $path))
486 {
487 print FOUT $content;
488 close(FOUT);
489 }
490 else
491 {
492 die('Error! Failed to open file for writing: ' . $path . "\n");
493 }
494}
495## filePutContents()
496
497## @function fileSize()
498#
499sub fileSize
500{
501 my $path = shift(@_);
502 my $file_size = -s $path;
503 return $file_size;
504}
505## fileSize()
506
507## @function fileTest()
508#
509sub fileTest
510{
511 my $filename_full_path = shift @_;
512 my $test_op = shift @_ || "-e";
513
514 # By default tests for existance of file or directory (-e)
515 # Can be made more specific by providing second parameter (e.g. -f or -d)
516
517 my $exists = 0;
518
519 if ($ENV{'GSDLOS'} =~ m/^windows$/i)
520 {
521 require Win32;
522 my $filename_short_path = Win32::GetShortPathName($filename_full_path);
523 if (!defined $filename_short_path)
524 {
525 # Was probably still in UTF8 form (not what is needed on Windows)
526 my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
527 if (defined $unicode_filename_full_path)
528 {
529 $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
530 }
531 }
532 $filename_full_path = $filename_short_path;
533 }
534
535 if (defined $filename_full_path)
536 {
537 $exists = eval "($test_op \$filename_full_path)";
538 }
539
540 return $exists;
541}
542## fileTest()
543
544## @function hardLink()
545# make hard link to file if supported by OS, otherwise copy the file
546#
547sub hardLink
548{
549 my ($src, $dest, $verbosity) = @_;
550
551 # remove trailing slashes from source and destination files
552 $src =~ s/[\\\/]+$//;
553 $dest =~ s/[\\\/]+$//;
554
555 ## print STDERR "**** src = ", unicode::debug_unicode_string($src),"\n";
556 # a few sanity checks
557 if (-e $dest)
558 {
559 # destination file already exists
560 return;
561 }
562 elsif (!-e $src)
563 {
564 print STDERR "FileUtils::hardLink() source file \"" . $src . "\" does not exist\n";
565 return 1;
566 }
567 elsif (-d $src)
568 {
569 print STDERR "FileUtils::hardLink() source \"" . $src . "\" is a directory\n";
570 return 1;
571 }
572
573 my $dest_dir = &File::Basename::dirname($dest);
574 if (!-e $dest_dir)
575 {
576 &makeAllDirectories($dest_dir);
577 }
578
579 if (!link($src, $dest))
580 {
581 if ((!defined $verbosity) || ($verbosity>2))
582 {
583 print STDERR "FileUtils::hardLink(): unable to create hard link. ";
584 print STDERR " Copying file: $src -> $dest\n";
585 }
586 &File::Copy::copy ($src, $dest);
587 }
588 return 0;
589}
590## hardLink()
591
592## @function isDirectoryEmpty()
593#
594# A method to check if a directory is empty (note that an empty
595# directory still has non-zero size!!!). Code is from
596# http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
597#
598sub isDirectoryEmpty
599{
600 my ($path) = @_;
601 opendir DIR, $path;
602 while(my $entry = readdir DIR)
603 {
604 next if($entry =~ /^\.\.?$/);
605 closedir DIR;
606 return 0;
607 }
608 closedir DIR;
609 return 1;
610}
611## isDirectoryEmpty()
612
613## @function isFilenameAbsolute()
614#
615sub isFilenameAbsolute
616{
617 my ($filename) = @_;
618 if ($ENV{'GSDLOS'} =~ /^windows$/i)
619 {
620 return ($filename =~ m/^(\w:)?\\/);
621 }
622 return ($filename =~ m/^\//);
623}
624# isFilenameAbsolute()
625
626## @function isSymbolicLink
627#
628# Determine if a given path is a symbolic link (soft link)
629#
630sub isSymbolicLink
631{
632 my $path = shift(@_);
633 my $is_soft_link = -l $path;
634 return $is_soft_link;
635}
636## isSymbolicLink()
637
638## @function makeAllDirectories()
639#
640# in case anyone cares - I did some testing (using perls Benchmark module)
641# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
642# slightly faster (surprisingly) - Stefan.
643#
644sub makeAllDirectories
645{
646 my ($dir) = @_;
647
648 # use / for the directory separator, remove duplicate and
649 # trailing slashes
650 $dir=~s/[\\\/]+/\//g;
651 $dir=~s/[\\\/]+$//;
652
653 # make sure the cache directory exists
654 my $dirsofar = "";
655 my $first = 1;
656 foreach my $dirname (split ("/", $dir))
657 {
658 $dirsofar .= "/" unless $first;
659 $first = 0;
660
661 $dirsofar .= $dirname;
662
663 next if $dirname =~ /^(|[a-z]:)$/i;
664 if (!-e $dirsofar)
665 {
666 my $store_umask = umask(0002);
667 my $mkdir_ok = mkdir ($dirsofar, 0777);
668 umask($store_umask);
669 if (!$mkdir_ok)
670 {
671 print STDERR "FileUtils::makeAllDirectories() could not create directory $dirsofar\n";
672 return;
673 }
674 }
675 }
676}
677## makeAllDirectories()
678
679## @function makeDirectory()
680#
681sub makeDirectory
682{
683 my ($dir) = @_;
684
685 my $store_umask = umask(0002);
686 my $mkdir_ok = mkdir ($dir, 0777);
687 umask($store_umask);
688
689 if (!$mkdir_ok)
690 {
691 print STDERR "FileUtils::makeDirectory() could not create directory $dir\n";
692 return;
693 }
694}
695## makeDirectory()
696
697## @function modificationTime()
698#
699sub modificationTime
700{
701 my $path = shift(@_);
702 my @file_status = stat($path);
703 return $file_status[9];
704}
705## modificationTime()
706
707## @function moveDirectoryContents()
708#
709# Move the contents of source directory into target directory (as
710# opposed to merely replacing target dir with the src dir) This can
711# overwrite any files with duplicate names in the target but other
712# files and folders in the target will continue to exist
713#
714sub moveDirectoryContents
715{
716 my ($src_dir, $dest_dir) = @_;
717
718 # Obtain listing of all files within src_dir
719 # Note that readdir lists relative paths, as well as . and ..
720 opendir(DIR, "$src_dir");
721 my @files= readdir(DIR);
722 close(DIR);
723
724 my @full_path_files = ();
725 foreach my $file (@files)
726 {
727 # process all except . and ..
728 unless($file eq "." || $file eq "..")
729 {
730 my $dest_subdir = &filenameConcatenate($dest_dir, $file); # $file is still a relative path
731
732 # construct absolute paths
733 $file = &filenameConcatenate($src_dir, $file); # $file is now an absolute path
734
735 # Recurse on directories which have an equivalent in target dest_dir
736 # If $file is a directory that already exists in target $dest_dir,
737 # then a simple move operation will fail (definitely on Windows).
738 if(-d $file && -d $dest_subdir)
739 {
740 #print STDERR "**** $file is a directory also existing in target, its contents to be copied to $dest_subdir\n";
741 &moveDirectoryContents($file, $dest_subdir);
742
743 # now all content is moved across, delete empty dir in source folder
744 if(&isDirectoryEmpty($file))
745 {
746 if (!rmdir $file)
747 {
748 print STDERR "ERROR. FileUtils::moveDirectoryContents() couldn't remove directory $file\n";
749 }
750 }
751 # error
752 else
753 {
754 print STDERR "ERROR. FileUtils::moveDirectoryContents(): subfolder $file still non-empty after moving contents to $dest_subdir\n";
755 }
756 }
757 # process files and any directories that don't already exist with a simple move
758 else
759 {
760 push(@full_path_files, $file);
761 }
762 }
763 }
764
765 # create target toplevel folder or subfolders if they don't exist
766 if(!&directoryExists($dest_dir))
767 {
768 &makeDirectory($dest_dir);
769 }
770
771 #print STDERR "@@@@@ Copying files |".join(",", @full_path_files)."| to: $dest_dir\n";
772
773 # if non-empty, there's something to copy across
774 if(@full_path_files)
775 {
776 &moveFiles(@full_path_files, $dest_dir);
777 }
778}
779## moveDirectoryContents()
780
781## @function moveFiles()
782#
783# moves a file or a group of files
784#
785sub moveFiles
786{
787 my $dest = pop (@_);
788 my (@srcfiles) = @_;
789
790 # remove trailing slashes from source and destination files
791 $dest =~ s/[\\\/]+$//;
792 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
793
794 # a few sanity checks
795 if (scalar (@srcfiles) == 0)
796 {
797 print STDERR "FileUtils::moveFiles() no destination directory given\n";
798 return;
799 }
800 elsif ((scalar (@srcfiles) > 1) && (!-d $dest))
801 {
802 print STDERR "FileUtils::moveFiles() if multiple source files are given the destination must be a directory\n";
803 return;
804 }
805
806 # move the files
807 foreach my $file (@srcfiles)
808 {
809 my $tempdest = $dest;
810 if (-d $tempdest)
811 {
812 my ($filename) = $file =~ /([^\\\/]+)$/;
813 $tempdest .= "/$filename";
814 }
815 if (!-e $file)
816 {
817 print STDERR "FileUtils::moveFiles() $file does not exist\n";
818 }
819 else
820 {
821 if(!rename ($file, $tempdest))
822 {
823 print STDERR "**** Failed to rename $file to $tempdest\n";
824 &File::Copy::copy($file, $tempdest);
825 &removeFiles($file);
826 }
827 # rename (partially) succeeded) but srcfile still exists after rename
828 elsif(-e $file)
829 {
830 #print STDERR "*** srcfile $file still exists after rename to $tempdest\n";
831 if(!-e $tempdest)
832 {
833 print STDERR "@@@@ ERROR: $tempdest does not exist\n";
834 }
835 # Sometimes the rename operation fails (as does
836 # File::Copy::move). This turns out to be because the files
837 # are hardlinked. Need to do a copy-delete in this case,
838 # however, the copy step is not necessary: the srcfile got
839 # renamed into tempdest, but srcfile itself still exists,
840 # delete it. &File::Copy::copy($file, $tempdest);
841 &removeFiles($file);
842 }
843 }
844 }
845}
846## moveFiles()
847
848## @function openFileHandle()
849#
850sub openFileHandle
851{
852 my $path = shift(@_);
853 my $mode = shift(@_);
854 my $fh_ref = shift(@_);
855 my $encoding = shift(@_);
856 my $mode_symbol = '<';
857 if ($mode eq 'w')
858 {
859 $mode_symbol = '>';
860 }
861 if (defined $encoding)
862 {
863 $mode_symbol .= ':' . $encoding;
864 }
865 if (!open($$fh_ref, $mode_symbol, $path))
866 {
867 $mode = 'writing';
868 if ($mode eq '>')
869 {
870 $mode = 'reading';
871 }
872 die("Error! Failed to open file for " . $mode . ": " . $path . "\n");
873 }
874 return 1;
875}
876## openFileHandle()
877
878## @function readDirectory()
879#
880sub readDirectory
881{
882 my $path = shift(@_);
883 my @files;
884 if (opendir(DH, $path))
885 {
886 @files = readdir(DH);
887 close(DH);
888 }
889 else
890 {
891 die("Error! Failed to open directory to list files: " . $path . "\n");
892 }
893 return \@files;
894}
895## readDirectory()
896
897## @function removeFiles()
898#
899# removes files (but not directories)
900#
901sub removeFiles
902{
903 my (@files) = @_;
904 my @filefiles = ();
905
906 # make sure the files we want to delete exist
907 # and are regular files
908 foreach my $file (@files)
909 {
910 if (!-e $file)
911 {
912 print STDERR "FileUtils::removeFiles() $file does not exist\n";
913 }
914 elsif ((!-f $file) && (!-l $file))
915 {
916 print STDERR "FileUtils::removeFiles() $file is not a regular (or symbolic) file\n";
917 }
918 else
919 {
920 push (@filefiles, $file);
921 }
922 }
923
924 # remove the files
925 my $numremoved = unlink @filefiles;
926
927 # check to make sure all of them were removed
928 if ($numremoved != scalar(@filefiles))
929 {
930 print STDERR "FileUtils::removeFiles() Not all files were removed\n";
931 }
932}
933## removeFiles()
934
935## @function removeFilesDebug()
936#
937# removes files (but not directories) - can rename this to the default
938# "rm" subroutine when debugging the deletion of individual files.
939# Unused?
940#
941sub removeFilesDebug
942{
943 my (@files) = @_;
944 my @filefiles = ();
945
946 # make sure the files we want to delete exist
947 # and are regular files
948 foreach my $file (@files)
949 {
950 if (!-e $file)
951 {
952 print STDERR "FileUtils::removeFilesDebug() " . $file . " does not exist\n";
953 }
954 elsif ((!-f $file) && (!-l $file))
955 {
956 print STDERR "FileUtils::removeFilesDebug() " . $file . " is not a regular (or symbolic) file\n";
957 }
958 # debug message
959 else
960 {
961 unlink($file) or warn "Could not delete file " . $file . ": " . $! . "\n";
962 }
963 }
964}
965## removeFilesDebug()
966
967## @function removeFilesFiltered()
968#
969sub removeFilesFiltered
970{
971 my ($files,$file_accept_re,$file_reject_re) = @_;
972
973 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
974 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
975 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
976
977 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
978
979 # recursively remove the files
980 foreach my $file (@files_array)
981 {
982 $file =~ s/[\/\\]+$//; # remove trailing slashes
983
984 if (!-e $file)
985 {
986 print STDERR "FileUtils::removeFilesFiltered() $file does not exist\n";
987 }
988 # don't recurse down symbolic link
989 elsif ((-d $file) && (!-l $file))
990 {
991 # get the contents of this directory
992 if (!opendir (INDIR, $file))
993 {
994 print STDERR "FileUtils::removeFilesFiltered() could not open directory $file\n";
995 }
996 else
997 {
998 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
999 closedir (INDIR);
1000
1001 # remove all the files in this directory
1002 map {$_="$file/$_";} @filedir;
1003 &removeFilesFiltered(\@filedir,$file_accept_re,$file_reject_re);
1004
1005 if (!defined $file_accept_re && !defined $file_reject_re)
1006 {
1007 # remove this directory
1008 if (!rmdir $file)
1009 {
1010 print STDERR "FileUtils::removeFilesFiltered() couldn't remove directory $file\n";
1011 }
1012 }
1013 }
1014 }
1015 else
1016 {
1017 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
1018
1019 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
1020 {
1021 # remove this file
1022 &removeFiles($file);
1023 }
1024 }
1025 }
1026}
1027## removeFilesFiltered()
1028
1029## @function removeFilesRecursive()
1030#
1031# The equivalent of "rm -rf" with all the dangers therein
1032#
1033sub removeFilesRecursive
1034{
1035 my (@files) = @_;
1036
1037 # use the more general (but reterospectively written) function
1038 # filtered_rm_r function() with no accept or reject expressions
1039 &removeFilesFiltered(\@files,undef,undef);
1040}
1041## removeFilesRecursive()
1042
1043## @function sanitizePath()
1044#
1045sub sanitizePath
1046{
1047 my ($path) = @_;
1048
1049 # fortunately filename concatenate will perform all the double slash
1050 # removal and end slash removal we need, and in a protocol aware
1051 # fashion
1052 return &filenameConcatenate($path);
1053}
1054## sanitizePath()
1055
1056## @function softLink()
1057#
1058# make soft link to file if supported by OS, otherwise copy file
1059#
1060sub softLink
1061{
1062 my ($src, $dest, $ensure_paths_absolute) = @_;
1063
1064 # remove trailing slashes from source and destination files
1065 $src =~ s/[\\\/]+$//;
1066 $dest =~ s/[\\\/]+$//;
1067
1068 # Ensure file paths are absolute IF requested to do so
1069 # Soft_linking didn't work for relative paths
1070 if(defined $ensure_paths_absolute && $ensure_paths_absolute)
1071 {
1072 # We need to ensure that the src file is the absolute path
1073 # See http://perldoc.perl.org/File/Spec.html
1074 # it's relative
1075 if(!File::Spec->file_name_is_absolute( $src ))
1076 {
1077 $src = File::Spec->rel2abs($src); # make absolute
1078 }
1079 # Might as well ensure that the destination file's absolute path is used
1080 if(!File::Spec->file_name_is_absolute( $dest ))
1081 {
1082 $dest = File::Spec->rel2abs($dest); # make absolute
1083 }
1084 }
1085
1086 # a few sanity checks
1087 if (!-e $src)
1088 {
1089 print STDERR "FileUtils::softLink() source file $src does not exist\n";
1090 return 0;
1091 }
1092
1093 my $dest_dir = &File::Basename::dirname($dest);
1094 if (!-e $dest_dir)
1095 {
1096 &makeAllDirectories($dest_dir);
1097 }
1098
1099 if ($ENV{'GSDLOS'} =~ /^windows$/i)
1100 {
1101 # symlink not supported on windows
1102 &File::Copy::copy ($src, $dest);
1103 }
1104 elsif (!eval {symlink($src, $dest)})
1105 {
1106 print STDERR "FileUtils::softLink(): unable to create soft link.\n";
1107 return 0;
1108 }
1109 return 1;
1110}
1111## softLink()
1112
1113## @function synchronizeDirectory()
1114#
1115# updates a copy of a directory in some other part of the filesystem
1116# verbosity settings are: 0=low, 1=normal, 2=high
1117# both $fromdir and $todir should be absolute paths
1118#
1119sub synchronizeDirectory
1120{
1121 my ($fromdir, $todir, $verbosity) = @_;
1122 $verbosity = 1 unless defined $verbosity;
1123
1124 # use / for the directory separator, remove duplicate and
1125 # trailing slashes
1126 $fromdir=~s/[\\\/]+/\//g;
1127 $fromdir=~s/[\\\/]+$//;
1128 $todir=~s/[\\\/]+/\//g;
1129 $todir=~s/[\\\/]+$//;
1130
1131 &makeAllDirectories($todir);
1132
1133 # get the directories in ascending order
1134 if (!opendir (FROMDIR, $fromdir))
1135 {
1136 print STDERR "FileUtils::synchronizeDirectory() could not read directory $fromdir\n";
1137 return;
1138 }
1139 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
1140 closedir (FROMDIR);
1141
1142 if (!opendir (TODIR, $todir))
1143 {
1144 print STDERR "FileUtils::synchronizeDirectory() could not read directory $todir\n";
1145 return;
1146 }
1147 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
1148 closedir (TODIR);
1149
1150 my $fromi = 0;
1151 my $toi = 0;
1152
1153 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
1154 {
1155 # print "fromi: $fromi toi: $toi\n";
1156
1157 # see if we should delete a file/directory
1158 # this should happen if the file/directory
1159 # is not in the from list or if its a different
1160 # size, or has an older timestamp
1161 if ($toi < scalar(@todir))
1162 {
1163 if (($fromi >= scalar(@fromdir)) || ($todir[$toi] lt $fromdir[$fromi] || ($todir[$toi] eq $fromdir[$fromi] && &differentFiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]", $verbosity))))
1164 {
1165
1166 # the files are different
1167 &removeFilesRecursive("$todir/$todir[$toi]");
1168 splice(@todir, $toi, 1); # $toi stays the same
1169
1170 }
1171 elsif ($todir[$toi] eq $fromdir[$fromi])
1172 {
1173 # the files are the same
1174 # if it is a directory, check its contents
1175 if (-d "$todir/$todir[$toi]")
1176 {
1177 &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
1178 }
1179
1180 $toi++;
1181 $fromi++;
1182 next;
1183 }
1184 }
1185
1186 # see if we should insert a file/directory
1187 # we should insert a file/directory if there
1188 # is no tofiles left or if the tofile does not exist
1189 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) || $todir[$toi] gt $fromdir[$fromi]))
1190 {
1191 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
1192 splice (@todir, $toi, 0, $fromdir[$fromi]);
1193
1194 $toi++;
1195 $fromi++;
1196 }
1197 }
1198}
1199## synchronizeDirectory()
1200
12011;
Note: See TracBrowser for help on using the repository browser.