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

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

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