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

Last change on this file since 28393 was 28393, checked in by davidb, 11 years ago

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