source: gs2-extensions/parallel-building/trunk/src/perllib/FileUtils/LocalFS.pm@ 30351

Last change on this file since 30351 was 30351, checked in by jmt12, 8 years ago

Restructured readDirectory to not die if directory isn't readable
File size: 14.8 KB
Line 
1###############################################################################
2#
3# LocalFS.pm -- file functions acting upon the local filesystem
4#
5# A component of the Greenstone digital library software from the New Zealand
6# Digital Library Project at the University of Waikato, New Zealand.
7#
8# Copyright (C) 2013 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify it under
11# the terms of the GNU General Public License as published by the Free Software
12# Foundation; either version 2 of the License, or (at your option) any later
13# version.
14#
15# This program is distributed in the hope that it will be useful, but WITHOUT
16# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
17# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
18# details.
19#
20# You should have received a copy of the GNU General Public License along with
21# this program; if not, write to the Free Software Foundation, Inc., 675 Mass
22# Ave, Cambridge, MA 02139, USA.
23#
24###############################################################################
25
26package FileUtils::LocalFS;
27
28# Pragma
29use strict;
30
31
32# Globals
33my $paths_we_cannot_link_from = {};
34
35
36## @function canRead()
37#
38sub canRead
39{
40 my $path = shift(@_);
41 return &fileTest($path, '-R');
42}
43## canRead()
44
45
46## @function closeFileHandle
47#
48sub closeFileHandle
49{
50 my $fh_ref = shift(@_);
51 close($$fh_ref);
52 return 1;
53}
54## closeFileHandle()
55
56
57## @function filenameConcatenate()
58#
59sub filenameConcatenate
60{
61 my $first_file = shift(@_);
62 my (@filenames) = @_;
63
64 # Useful for debugging
65 # -- might make sense to call caller(0) rather than (1)??
66 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
67 # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
68
69 # If first_file is not null or empty, then add it back into the list
70 if (defined $first_file && $first_file =~ /\S/) {
71 unshift(@filenames, $first_file);
72 }
73
74 my $filename = join("/", @filenames);
75
76 # remove duplicate slashes and remove the last slash
77 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
78 $filename =~ s/[\\\/]+/\\/g;
79 } else {
80 $filename =~ s/[\/]+/\//g;
81 # DB: want a filename abc\de.html to remain like this
82 }
83 $filename =~ s/[\\\/]$//;
84
85 return $filename;
86}
87## filenameConcatenate()
88
89
90## @function fileSize()
91#
92sub fileSize
93{
94 my ($filename_full_path) = @_;
95 return -s $filename_full_path;
96}
97## fileStatus()
98
99
100## @function fileTest()
101#
102sub fileTest
103{
104 my $filename_full_path = shift(@_);
105 # By default tests for existance of file or directory (-e)
106 # Can be made more specific by providing second parameter (e.g. -f or -d)
107 my $test_op = shift(@_) || '-e';
108
109 my $exists = 0;
110
111 if ($ENV{'GSDLOS'} =~ m/^windows$/i) {
112 require Win32;
113 my $filename_short_path = Win32::GetShortPathName($filename_full_path);
114 if (!defined $filename_short_path) {
115 # Was probably still in UTF8 form (not what is needed on Windows)
116 my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
117 if (defined $unicode_filename_full_path) {
118 $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
119 }
120 }
121 $filename_full_path = $filename_short_path;
122 }
123
124 if (defined $filename_full_path) {
125 $exists = eval "($test_op \$filename_full_path)";
126 }
127
128 # The eval may result in exists being undefined, but we need to return
129 # something
130 return ($exists || 0);
131}
132## fileTest()
133
134
135## @function isFilenameAbsolute()
136#
137sub isFilenameAbsolute
138{
139 my ($filename) = @_;
140 if ($ENV{'GSDLOS'} =~ /^windows$/i)
141 {
142 return ($filename =~ m/^(\w:)?\\/);
143 }
144 return ($filename =~ m/^\//);
145}
146# isFilenameAbsolute()
147
148
149## @function isHDFS
150#
151sub isHDFS
152{
153 return 0;
154}
155## isHDFS()
156
157
158## @function linkFile()
159#
160sub linkFile
161{
162 my ($mode, $src, $dest, $ensure_paths_absolute) = @_;
163
164 # remove trailing slashes from source and destination files
165 $src =~ s/[\\\/]+$//;
166 $dest =~ s/[\\\/]+$//;
167
168 # Ensure file paths are absolute IF requested to do so
169 # Soft_linking didn't work for relative paths
170 if($mode eq 'HARD' || (defined $ensure_paths_absolute && $ensure_paths_absolute))
171 {
172 # We need to ensure that the src file is the absolute path
173 # See http://perldoc.perl.org/File/Spec.html
174 if(!File::Spec->file_name_is_absolute( $src ))
175 {
176 # it's relative
177 $src = File::Spec->rel2abs($src); # make absolute
178 }
179 # Might as well ensure that the destination file's absolute path is used
180 if(!File::Spec->file_name_is_absolute( $dest ))
181 {
182 $dest = File::Spec->rel2abs($dest); # make absolute
183 }
184 }
185
186 # a few sanity checks
187 if (!-e $src)
188 {
189 &FileUtils::printError('Source file does not exist: ' . $src);
190 return 0;
191 }
192
193 my $dest_dir = &File::Basename::dirname($dest);
194 if (!-e $dest_dir)
195 {
196 &makeAllDirectories($dest_dir);
197 }
198
199 my $error_message = ucfirst(lc($mode)) . ' link failed';
200 if ($ENV{'GSDLOS'} =~ /^windows$/i)
201 {
202 # symlink not supported on windows
203 $error_message = 'Symlink not supported on windows';
204 }
205 elsif ($mode eq 'HARD')
206 {
207 link($src, $dest);
208 #if (!eval {link($src, $dest)})
209 #{
210 # &FileUtils::printWarning('Unable to create hard link: ' . $dest);
211 #}
212 }
213 elsif ($mode eq 'SOFT')
214 {
215 symlink($src, $dest);
216 #if (!eval {symlink($src, $dest)})
217 #{
218 # &FileUtils::printWarning('Unable to create soft link: ' . $src);
219 #}
220 }
221 else
222 {
223 $error_message = 'Unknown mode requested: ' . $mode;
224 }
225 if (!-e $dest)
226 {
227 # Determine the top source path
228 my ($src_root) = $src =~ /^([a-z]:\\|\/[^\/]+)/i;
229 # If we haven't warned about this yet, warn now and record that we've
230 # warned. I want to let the user know what has happened, but without
231 # bombarding them with a thousand warning messages...
232 if (!defined $paths_we_cannot_link_from->{$src_root})
233 {
234 &FileUtils::printWarning($error_message . '. Will attempt to copy from: ' . $src_root);
235 $paths_we_cannot_link_from->{$src_root} = 1;
236 }
237 &File::Copy::copy ($src, $dest);
238 }
239 return (-e $dest);
240}
241# /** linkFile() **/
242
243
244## @function makeAllDirectories()
245#
246# in case anyone cares - I did some testing (using perls Benchmark module)
247# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
248# slightly faster (surprisingly) - Stefan.
249#
250sub makeAllDirectories
251{
252 my ($dir) = @_;
253
254 # use / for the directory separator, remove duplicate and
255 # trailing slashes
256 $dir=~s/[\\\/]+/\//g;
257 $dir=~s/[\\\/]+$//;
258
259 # make sure the cache directory exists
260 my $dirsofar = "";
261 my $first = 1;
262 foreach my $dirname (split ("/", $dir))
263 {
264 $dirsofar .= "/" unless $first;
265 $first = 0;
266
267 $dirsofar .= $dirname;
268
269 next if $dirname =~ /^(|[a-z]:)$/i;
270 if (!-e $dirsofar)
271 {
272 my $store_umask = umask(0002);
273 my $mkdir_ok = mkdir ($dirsofar, 0777);
274 umask($store_umask);
275 if (!$mkdir_ok)
276 {
277 print STDERR "FileUtils::makeAllDirectories() could not create directory $dirsofar\n";
278 return;
279 }
280 }
281 }
282 return 1;
283}
284## makeAllDirectories()
285
286
287## @function makeDirectory()
288#
289sub makeDirectory
290{
291 my $dir = shift(@_);
292 my $store_umask = umask(0002);
293 my $mkdir_ok = mkdir ($dir, 0777);
294 umask($store_umask);
295 return $mkdir_ok;
296}
297## makeDirectory()
298
299
300## @function modificationTime()
301#
302sub modificationTime
303{
304 my $path = shift(@_);
305 my @file_status = stat($path);
306 return $file_status[9];
307}
308## modificationTime()
309
310## @function openFileHandle()
311#
312sub openFileHandle
313{
314 my $path = shift(@_);
315 my $mode = shift(@_);
316 my $fh_ref = shift(@_);
317 my $encoding = shift(@_);
318 my $mode_symbol;
319 if ($mode eq 'w' || $mode eq '>')
320 {
321 $mode_symbol = '>';
322 $mode = 'writing';
323 }
324 elsif ($mode eq 'a' || $mode eq '>>')
325 {
326 $mode_symbol = '>>';
327 $mode = 'appending';
328 }
329 else
330 {
331 $mode_symbol = '<';
332 $mode = 'reading';
333 }
334 if (defined $encoding)
335 {
336 $mode_symbol .= ':' . $encoding;
337 }
338 return open($$fh_ref, $mode_symbol, $path);
339}
340## openFileHandle()
341
342# /**
343# */
344sub readDirectory
345{
346 my $path = shift(@_);
347 my $rvalue;
348 if (opendir(DH, $path))
349 {
350 my @files = readdir(DH);
351 close(DH);
352 $rvalue = \@files;
353 }
354 return $rvalue;
355}
356# /** readDirectory() **/
357
358
359## @function removeFiles()
360#
361sub removeFiles
362{
363 my $file = shift(@_);
364 my $result = 0;
365 if (!-e $file && !-l $file)
366 {
367 &FileUtils::printError('File does not exist: ' . $file);
368 }
369 elsif ((!-f $file) && (!-l $file))
370 {
371 &FileUtils::printError('Not a regular file: ' . $file);
372 }
373 else
374 {
375 $result = unlink($file);
376 if (!$result)
377 {
378 &FileUtils::printError('Failed to remove file: ' . $file);
379 }
380 }
381 return $result;
382}
383## removeFiles()
384
385
386## @function removeFilesFiltered()
387#
388# recursive removal
389#
390sub removeFilesFiltered
391{
392 my ($files, $file_accept_re, $file_reject_re) = @_;
393 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
394 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
395 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
396 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
397
398 my $num_removed = 0;
399
400 foreach my $file (@files_array)
401 {
402 # remove trailing slashes
403 $file =~ s/[\/\\]+$//;
404
405 if (!-e $file)
406 {
407 print STDERR "util::filtered_rm_r $file does not exist\n";
408 }
409 # don't recurse down symbolic link
410 elsif ((-d $file) && (!-l $file))
411 {
412 # get the contents of this directory
413 if (!opendir (INDIR, $file))
414 {
415 print STDERR "util::filtered_rm_r could not open directory $file\n";
416 }
417 else
418 {
419 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
420 closedir (INDIR);
421
422 # remove all the files in this directory
423 map {$_="$file/$_";} @filedir;
424 $num_removed += &FileUtils::LocalFS::removeFilesFiltered(\@filedir, $file_accept_re, $file_reject_re);
425
426 if (!defined $file_accept_re && !defined $file_reject_re)
427 {
428 # remove this directory
429 if (!rmdir $file)
430 {
431 print STDERR "util::filtered_rm_r couldn't remove directory $file\n";
432 }
433 else
434 {
435 $num_removed++;
436 }
437 }
438 }
439 }
440 else
441 {
442 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
443
444 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
445 {
446 # remove this file
447 $num_removed += &removeFiles($file);
448 }
449 }
450 }
451 return $num_removed;
452}
453## removeFilesFiltered()
454
455
456## @function removeFilesRecursive()
457#
458sub removeFilesRecursive
459{
460 my $path = shift(@_);
461 # use the more general (but reterospectively written filteredRemove()
462 # function with no accept or reject expressions
463 return FileUtils::LocalFS::removeFilesFiltered($path, undef, undef);
464}
465## removeFilesRecursive()
466
467
468## @function supportsSymbolicLink
469#
470sub supportsSymbolicLink
471{
472 return 1;
473}
474## supportsSymbolicLink()
475
476
477## @function synchronizeDirectory()
478#
479# updates a copy of a directory in some other part of the filesystem
480# verbosity settings are: 0=low, 1=normal, 2=high
481# both $fromdir and $todir should be absolute paths
482#
483sub synchronizeDirectory
484{
485 my ($fromdir, $todir, $verbosity) = @_;
486 $verbosity = 1 unless defined $verbosity;
487
488 # use / for the directory separator, remove duplicate and
489 # trailing slashes
490 $fromdir=~s/[\\\/]+/\//g;
491 $fromdir=~s/[\\\/]+$//;
492 $todir=~s/[\\\/]+/\//g;
493 $todir=~s/[\\\/]+$//;
494
495 &mk_all_dir ($todir);
496
497 # get the directories in ascending order
498 if (!opendir (FROMDIR, $fromdir))
499 {
500 print STDERR "util::cachedir could not read directory $fromdir\n";
501 return;
502 }
503 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
504 closedir (FROMDIR);
505
506 if (!opendir (TODIR, $todir))
507 {
508 print STDERR "util::cacedir could not read directory $todir\n";
509 return;
510 }
511 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
512 closedir (TODIR);
513
514 my $fromi = 0;
515 my $toi = 0;
516
517 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
518 {
519 # print "fromi: $fromi toi: $toi\n";
520
521 # see if we should delete a file/directory
522 # this should happen if the file/directory
523 # is not in the from list or if its a different
524 # size, or has an older timestamp
525 if ($toi < scalar(@todir))
526 {
527 if (($fromi >= scalar(@fromdir)) ||
528 ($todir[$toi] lt $fromdir[$fromi] ||
529 ($todir[$toi] eq $fromdir[$fromi] &&
530 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
531 $verbosity))))
532 {
533 # the files are different
534 &rm_r("$todir/$todir[$toi]");
535 splice(@todir, $toi, 1); # $toi stays the same
536 }
537 elsif ($todir[$toi] eq $fromdir[$fromi])
538 {
539 # the files are the same
540 # if it is a directory, check its contents
541 if (-d "$todir/$todir[$toi]")
542 {
543 &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
544 }
545
546 $toi++;
547 $fromi++;
548 next;
549 }
550 }
551
552 # see if we should insert a file/directory
553 # we should insert a file/directory if there
554 # is no tofiles left or if the tofile does not exist
555 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
556 $todir[$toi] gt $fromdir[$fromi]))
557 {
558 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
559 splice (@todir, $toi, 0, $fromdir[$fromi]);
560 $toi++;
561 $fromi++;
562 }
563 }
564}
565## synchronizeDirectory()
566
567
568# /**
569# */
570sub transferFile
571{
572 my ($mode, $file, $dest) = @_;
573 # remove trailing slashes from source and destination files
574 $file =~ s/[\\\/]+$//;
575 $dest =~ s/[\\\/]+$//;
576 my $tempdest = $dest;
577 if (!-e $file)
578 {
579 &FileUtils::printError('File does not exist: ' . $file);
580 }
581 else
582 {
583 if (-d $tempdest)
584 {
585 my ($filename) = $file =~ /([^\\\/]+)$/;
586 $tempdest .= "/$filename";
587 }
588 # start by processing any move request
589 if ($mode eq 'MOVE')
590 {
591 &File::Copy::move($file, $tempdest);
592 }
593 # now if we were instead doing a copy, or if the move request above failed
594 # for some reason, we process a copy request
595 if ($mode eq 'COPY' || !-e $tempdest)
596 {
597 &File::Copy::copy($file, $tempdest);
598 }
599 # finally, we check if a successful move command has somehow left the origin
600 # file lying around (rename partially succeeded - for instance when moving
601 # hardlinks)
602 if ($mode eq 'MOVE' && -e $tempdest && -e $file)
603 {
604 unlink($file);
605 }
606 }
607 # Have we successfully moved the file?
608 my $result = 0;
609 if (-e $tempdest)
610 {
611 if ($mode eq 'MOVE')
612 {
613 if (-e $file)
614 {
615 &FileUtils::printError('Failed to remove original file during move: ' . $file);
616 }
617 else
618 {
619 $result = 1;
620 }
621 }
622 else
623 {
624 $result = 1;
625 }
626 }
627 else
628 {
629 &FileUtils::printError('Failed to move/copy file: ' . $file);
630 }
631 return $result;
632}
633# /** moveFile() **/
634
6351;
Note: See TracBrowser for help on using the repository browser.