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

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

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