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

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

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