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

Last change on this file since 27311 was 27311, checked in by kjdon, 11 years ago

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