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

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

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