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

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

Trying to streamline the error messages from failing to link (otherwise I get a zillion messages about being unable to link from /tmp to /share as they are different physical media, for instance)
File size: 13.9 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## @function makeDirectory()
244#
245sub makeDirectory
246{
247 my $dir = shift(@_);
248 my $store_umask = umask(0002);
249 my $mkdir_ok = mkdir ($dir, 0777);
250 umask($store_umask);
251 return $mkdir_ok;
252}
253## makeDirectory()
254
255
256## @function modificationTime()
257#
258sub modificationTime
259{
260 my $path = shift(@_);
261 my @file_status = stat($path);
262 return $file_status[9];
263}
264## modificationTime()
265
266## @function openFileHandle()
267#
268sub openFileHandle
269{
270 my $path = shift(@_);
271 my $mode = shift(@_);
272 my $fh_ref = shift(@_);
273 my $encoding = shift(@_);
274 my $mode_symbol;
275 if ($mode eq 'w' || $mode eq '>')
276 {
277 $mode_symbol = '>';
278 $mode = 'writing';
279 }
280 elsif ($mode eq 'a' || $mode eq '>>')
281 {
282 $mode_symbol = '>>';
283 $mode = 'appending';
284 }
285 else
286 {
287 $mode_symbol = '<';
288 $mode = 'reading';
289 }
290 if (defined $encoding)
291 {
292 $mode_symbol .= ':' . $encoding;
293 }
294 if (!open($$fh_ref, $mode_symbol, $path))
295 {
296 &FileUtils::printError('Failed to open file for ' . $mode . ': ' . $path, 1);
297 }
298 return 1;
299}
300## openFileHandle()
301
302# /**
303# */
304sub readDirectory
305{
306 my $path = shift(@_);
307 opendir(DH, $path) or &FileUtils::printError('Failed to open directory for reading: ' . $path, 1);
308 my @files = readdir(DH);
309 close(DH);
310 return \@files;
311}
312# /** readDirectory() **/
313
314
315## @function removeFiles()
316#
317sub removeFiles
318{
319 my $file = shift(@_);
320 my $result = 0;
321 if (!-e $file && !-l $file)
322 {
323 &FileUtils::printError('File does not exist: ' . $file);
324 }
325 elsif ((!-f $file) && (!-l $file))
326 {
327 &FileUtils::printError('Not a regular file: ' . $file);
328 }
329 else
330 {
331 $result = unlink($file);
332 if (!$result)
333 {
334 &FileUtils::printError('Failed to remove file: ' . $file);
335 }
336 }
337 return $result;
338}
339## removeFiles()
340
341
342## @function removeFilesFiltered()
343#
344# recursive removal
345#
346sub removeFilesFiltered
347{
348 my ($files, $file_accept_re, $file_reject_re) = @_;
349 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
350 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
351 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
352 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
353
354 my $num_removed = 0;
355
356 foreach my $file (@files_array)
357 {
358 # remove trailing slashes
359 $file =~ s/[\/\\]+$//;
360
361 if (!-e $file)
362 {
363 print STDERR "util::filtered_rm_r $file does not exist\n";
364 }
365 # don't recurse down symbolic link
366 elsif ((-d $file) && (!-l $file))
367 {
368 # get the contents of this directory
369 if (!opendir (INDIR, $file))
370 {
371 print STDERR "util::filtered_rm_r could not open directory $file\n";
372 }
373 else
374 {
375 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
376 closedir (INDIR);
377
378 # remove all the files in this directory
379 map {$_="$file/$_";} @filedir;
380 $num_removed += &FileUtils::LocalFS::removeFilesFiltered(\@filedir, $file_accept_re, $file_reject_re);
381
382 if (!defined $file_accept_re && !defined $file_reject_re)
383 {
384 # remove this directory
385 if (!rmdir $file)
386 {
387 print STDERR "util::filtered_rm_r couldn't remove directory $file\n";
388 }
389 else
390 {
391 $num_removed++;
392 }
393 }
394 }
395 }
396 else
397 {
398 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
399
400 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
401 {
402 # remove this file
403 $num_removed += &removeFiles($file);
404 }
405 }
406 }
407 return $num_removed;
408}
409## removeFilesFiltered()
410
411
412## @function removeFilesRecursive()
413#
414sub removeFilesRecursive
415{
416 my $path = shift(@_);
417 # use the more general (but reterospectively written filteredRemove()
418 # function with no accept or reject expressions
419 return FileUtils::LocalFS::removeFilesFiltered($path, undef, undef);
420}
421## removeFilesRecursive()
422
423
424## @function supportsSymbolicLink
425#
426sub supportsSymbolicLink
427{
428 return 1;
429}
430## supportsSymbolicLink()
431
432
433## @function synchronizeDirectory()
434#
435# updates a copy of a directory in some other part of the filesystem
436# verbosity settings are: 0=low, 1=normal, 2=high
437# both $fromdir and $todir should be absolute paths
438#
439sub synchronizeDirectory
440{
441 my ($fromdir, $todir, $verbosity) = @_;
442 $verbosity = 1 unless defined $verbosity;
443
444 # use / for the directory separator, remove duplicate and
445 # trailing slashes
446 $fromdir=~s/[\\\/]+/\//g;
447 $fromdir=~s/[\\\/]+$//;
448 $todir=~s/[\\\/]+/\//g;
449 $todir=~s/[\\\/]+$//;
450
451 &mk_all_dir ($todir);
452
453 # get the directories in ascending order
454 if (!opendir (FROMDIR, $fromdir))
455 {
456 print STDERR "util::cachedir could not read directory $fromdir\n";
457 return;
458 }
459 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
460 closedir (FROMDIR);
461
462 if (!opendir (TODIR, $todir))
463 {
464 print STDERR "util::cacedir could not read directory $todir\n";
465 return;
466 }
467 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
468 closedir (TODIR);
469
470 my $fromi = 0;
471 my $toi = 0;
472
473 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
474 {
475 # print "fromi: $fromi toi: $toi\n";
476
477 # see if we should delete a file/directory
478 # this should happen if the file/directory
479 # is not in the from list or if its a different
480 # size, or has an older timestamp
481 if ($toi < scalar(@todir))
482 {
483 if (($fromi >= scalar(@fromdir)) ||
484 ($todir[$toi] lt $fromdir[$fromi] ||
485 ($todir[$toi] eq $fromdir[$fromi] &&
486 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
487 $verbosity))))
488 {
489 # the files are different
490 &rm_r("$todir/$todir[$toi]");
491 splice(@todir, $toi, 1); # $toi stays the same
492 }
493 elsif ($todir[$toi] eq $fromdir[$fromi])
494 {
495 # the files are the same
496 # if it is a directory, check its contents
497 if (-d "$todir/$todir[$toi]")
498 {
499 &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
500 }
501
502 $toi++;
503 $fromi++;
504 next;
505 }
506 }
507
508 # see if we should insert a file/directory
509 # we should insert a file/directory if there
510 # is no tofiles left or if the tofile does not exist
511 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
512 $todir[$toi] gt $fromdir[$fromi]))
513 {
514 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
515 splice (@todir, $toi, 0, $fromdir[$fromi]);
516 $toi++;
517 $fromi++;
518 }
519 }
520}
521## synchronizeDirectory()
522
523
524# /**
525# */
526sub transferFile
527{
528 my ($mode, $file, $dest) = @_;
529 # remove trailing slashes from source and destination files
530 $file =~ s/[\\\/]+$//;
531 $dest =~ s/[\\\/]+$//;
532 my $tempdest = $dest;
533 if (!-e $file)
534 {
535 &FileUtils::printError('File does not exist: ' . $file);
536 }
537 else
538 {
539 if (-d $tempdest)
540 {
541 my ($filename) = $file =~ /([^\\\/]+)$/;
542 $tempdest .= "/$filename";
543 }
544 # start by processing any move request
545 if ($mode eq 'MOVE')
546 {
547 &File::Copy::move($file, $tempdest);
548 }
549 # now if we were instead doing a copy, or if the move request above failed
550 # for some reason, we process a copy request
551 if ($mode eq 'COPY' || !-e $tempdest)
552 {
553 &File::Copy::copy($file, $tempdest);
554 }
555 # finally, we check if a successful move command has somehow left the origin
556 # file lying around (rename partially succeeded - for instance when moving
557 # hardlinks)
558 if ($mode eq 'MOVE' && -e $tempdest && -e $file)
559 {
560 unlink($file);
561 }
562 }
563 # Have we successfully moved the file?
564 my $result = 0;
565 if (-e $tempdest)
566 {
567 if ($mode eq 'MOVE')
568 {
569 if (-e $file)
570 {
571 &FileUtils::printError('Failed to remove original file during move: ' . $file);
572 }
573 else
574 {
575 $result = 1;
576 }
577 }
578 else
579 {
580 $result = 1;
581 }
582 }
583 else
584 {
585 &FileUtils::printError('Failed to move/copy file: ' . $file);
586 }
587 return $result;
588}
589# /** moveFile() **/
590
5911;
Note: See TracBrowser for help on using the repository browser.