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

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

Adding canRead() and isAbsolute() functions
File size: 14.3 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 linkFile()
146#
147sub linkFile
148{
149 my ($mode, $src, $dest, $ensure_paths_absolute) = @_;
150
151 # remove trailing slashes from source and destination files
152 $src =~ s/[\\\/]+$//;
153 $dest =~ s/[\\\/]+$//;
154
155 # Ensure file paths are absolute IF requested to do so
156 # Soft_linking didn't work for relative paths
157 if($mode eq 'HARD' || (defined $ensure_paths_absolute && $ensure_paths_absolute))
158 {
159 # We need to ensure that the src file is the absolute path
160 # See http://perldoc.perl.org/File/Spec.html
161 if(!File::Spec->file_name_is_absolute( $src ))
162 {
163 # it's relative
164 $src = File::Spec->rel2abs($src); # make absolute
165 }
166 # Might as well ensure that the destination file's absolute path is used
167 if(!File::Spec->file_name_is_absolute( $dest ))
168 {
169 $dest = File::Spec->rel2abs($dest); # make absolute
170 }
171 }
172
173 # a few sanity checks
174 if (!-e $src)
175 {
176 &FileUtils::printError('Source file does not exist: ' . $src);
177 return 0;
178 }
179
180 my $dest_dir = &File::Basename::dirname($dest);
181 if (!-e $dest_dir)
182 {
183 &makeAllDirectories($dest_dir);
184 }
185
186 if ($ENV{'GSDLOS'} =~ /^windows$/i)
187 {
188 # symlink not supported on windows
189 &FileUtils::printWarning('Symlink not supported on windows');
190 }
191 elsif ($mode eq 'HARD')
192 {
193 if (!eval {link($src, $dest)})
194 {
195 &FileUtils::printWarning('Unable to create hard link: ' . $dest);
196 }
197 }
198 elsif ($mode eq 'SOFT')
199 {
200 if (!eval {symlink($src, $dest)})
201 {
202 &FileUtils::printWarning('Unable to create soft link: ' . $src);
203 }
204 }
205 else
206 {
207 &FileUtils::printError('Unknown mode requested: ' . $mode);
208 }
209 if (!-e $dest)
210 {
211 &_printWarning('linkFile', 'Link failed. Attempting to copy instead.');
212 &File::Copy::copy ($src, $dest);
213 }
214 return (-e $dest);
215}
216# /** linkFile() **/
217
218## @function makeAllDirectories()
219#
220# in case anyone cares - I did some testing (using perls Benchmark module)
221# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
222# slightly faster (surprisingly) - Stefan.
223#
224sub makeAllDirectories
225{
226 my ($dir) = @_;
227
228 # use / for the directory separator, remove duplicate and
229 # trailing slashes
230 $dir=~s/[\\\/]+/\//g;
231 $dir=~s/[\\\/]+$//;
232
233 # ensure the directory doesn't already exist
234 if (-e $dir)
235 {
236 return 0;
237 }
238
239 # make sure the cache directory exists
240 my $dirsofar = "";
241 my $first = 1;
242 foreach my $dirname (split ("/", $dir))
243 {
244 $dirsofar .= "/" unless $first;
245 $first = 0;
246
247 $dirsofar .= $dirname;
248
249 next if $dirname =~ /^(|[a-z]:)$/i;
250 if (!-e $dirsofar)
251 {
252 my $store_umask = umask(0002);
253 my $mkdir_ok = mkdir ($dirsofar, 0777);
254 umask($store_umask);
255 if (!$mkdir_ok)
256 {
257 &FileUtils::printError('Could not create directory: ' . $dirsofar);
258 return 0;
259 }
260 }
261 }
262 return (-e $dir);
263}
264## makeAllDirectories()
265
266
267## @function makeDirectory()
268#
269sub makeDirectory
270{
271 my $dir = shift(@_);
272 my $store_umask = umask(0002);
273 my $mkdir_ok = mkdir ($dir, 0777);
274 umask($store_umask);
275 return $mkdir_ok;
276}
277## makeDirectory()
278
279
280## @function modificationTime()
281#
282sub modificationTime
283{
284 my $path = shift(@_);
285 my @file_status = stat($path);
286 return $file_status[9];
287}
288## modificationTime()
289
290## @function openFileHandle()
291#
292sub openFileHandle
293{
294 my $path = shift(@_);
295 my $mode = shift(@_);
296 my $fh_ref = shift(@_);
297 my $encoding = shift(@_);
298 my $mode_symbol;
299 if ($mode eq 'w' || $mode eq '>')
300 {
301 $mode_symbol = '>';
302 $mode = 'writing';
303 }
304 elsif ($mode eq 'a' || $mode eq '>>')
305 {
306 $mode_symbol = '>>';
307 $mode = 'appending';
308 }
309 else
310 {
311 $mode_symbol = '<';
312 $mode = 'reading';
313 }
314 if (defined $encoding)
315 {
316 $mode_symbol .= ':' . $encoding;
317 }
318 if (!open($$fh_ref, $mode_symbol, $path))
319 {
320 &FileUtils::printError('Failed to open file for ' . $mode . ': ' . $path, 1);
321 }
322 return 1;
323}
324## openFileHandle()
325
326# /**
327# */
328sub readDirectory
329{
330 my $path = shift(@_);
331 opendir(DH, $path) or &FileUtils::printError('Failed to open directory for reading: ' . $path, 1);
332 my @files = readdir(DH);
333 close(DH);
334 return \@files;
335}
336# /** readDirectory() **/
337
338
339## @function removeFiles()
340#
341sub removeFiles
342{
343 my $file = shift(@_);
344 my $result = 0;
345 if (!-e $file && !-l $file)
346 {
347 &FileUtils::printError('File does not exist: ' . $file);
348 }
349 elsif ((!-f $file) && (!-l $file))
350 {
351 &FileUtils::printError('Not a regular file: ' . $file);
352 }
353 else
354 {
355 $result = unlink($file);
356 if (!$result)
357 {
358 &FileUtils::printError('Failed to remove file: ' . $file);
359 }
360 }
361 return $result;
362}
363## removeFiles()
364
365
366## @function removeFilesFiltered()
367#
368# recursive removal
369#
370sub removeFilesFiltered
371{
372 my ($files, $file_accept_re, $file_reject_re) = @_;
373 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
374 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
375 # print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
376 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
377
378 my $num_removed = 0;
379
380 foreach my $file (@files_array)
381 {
382 # remove trailing slashes
383 $file =~ s/[\/\\]+$//;
384
385 if (!-e $file)
386 {
387 print STDERR "util::filtered_rm_r $file does not exist\n";
388 }
389 # don't recurse down symbolic link
390 elsif ((-d $file) && (!-l $file))
391 {
392 # get the contents of this directory
393 if (!opendir (INDIR, $file))
394 {
395 print STDERR "util::filtered_rm_r could not open directory $file\n";
396 }
397 else
398 {
399 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
400 closedir (INDIR);
401
402 # remove all the files in this directory
403 map {$_="$file/$_";} @filedir;
404 $num_removed += &FileUtils::LocalFS::removeFilesFiltered(\@filedir, $file_accept_re, $file_reject_re);
405
406 if (!defined $file_accept_re && !defined $file_reject_re)
407 {
408 # remove this directory
409 if (!rmdir $file)
410 {
411 print STDERR "util::filtered_rm_r couldn't remove directory $file\n";
412 }
413 else
414 {
415 $num_removed++;
416 }
417 }
418 }
419 }
420 else
421 {
422 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
423
424 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
425 {
426 # remove this file
427 $num_removed += &removeFiles($file);
428 }
429 }
430 }
431 return $num_removed;
432}
433## removeFilesFiltered()
434
435
436## @function removeFilesRecursive()
437#
438sub removeFilesRecursive
439{
440 my $path = shift(@_);
441 # use the more general (but reterospectively written filteredRemove()
442 # function with no accept or reject expressions
443 return FileUtils::LocalFS::removeFilesFiltered($path, undef, undef);
444}
445## removeFilesRecursive()
446
447
448## @function supportsSymbolicLink
449#
450sub supportsSymbolicLink
451{
452 return 1;
453}
454## supportsSymbolicLink()
455
456
457## @function synchronizeDirectory()
458#
459# updates a copy of a directory in some other part of the filesystem
460# verbosity settings are: 0=low, 1=normal, 2=high
461# both $fromdir and $todir should be absolute paths
462#
463sub synchronizeDirectory
464{
465 my ($fromdir, $todir, $verbosity) = @_;
466 $verbosity = 1 unless defined $verbosity;
467
468 # use / for the directory separator, remove duplicate and
469 # trailing slashes
470 $fromdir=~s/[\\\/]+/\//g;
471 $fromdir=~s/[\\\/]+$//;
472 $todir=~s/[\\\/]+/\//g;
473 $todir=~s/[\\\/]+$//;
474
475 &mk_all_dir ($todir);
476
477 # get the directories in ascending order
478 if (!opendir (FROMDIR, $fromdir))
479 {
480 print STDERR "util::cachedir could not read directory $fromdir\n";
481 return;
482 }
483 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
484 closedir (FROMDIR);
485
486 if (!opendir (TODIR, $todir))
487 {
488 print STDERR "util::cacedir could not read directory $todir\n";
489 return;
490 }
491 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
492 closedir (TODIR);
493
494 my $fromi = 0;
495 my $toi = 0;
496
497 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
498 {
499 # print "fromi: $fromi toi: $toi\n";
500
501 # see if we should delete a file/directory
502 # this should happen if the file/directory
503 # is not in the from list or if its a different
504 # size, or has an older timestamp
505 if ($toi < scalar(@todir))
506 {
507 if (($fromi >= scalar(@fromdir)) ||
508 ($todir[$toi] lt $fromdir[$fromi] ||
509 ($todir[$toi] eq $fromdir[$fromi] &&
510 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
511 $verbosity))))
512 {
513 # the files are different
514 &rm_r("$todir/$todir[$toi]");
515 splice(@todir, $toi, 1); # $toi stays the same
516 }
517 elsif ($todir[$toi] eq $fromdir[$fromi])
518 {
519 # the files are the same
520 # if it is a directory, check its contents
521 if (-d "$todir/$todir[$toi]")
522 {
523 &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
524 }
525
526 $toi++;
527 $fromi++;
528 next;
529 }
530 }
531
532 # see if we should insert a file/directory
533 # we should insert a file/directory if there
534 # is no tofiles left or if the tofile does not exist
535 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
536 $todir[$toi] gt $fromdir[$fromi]))
537 {
538 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
539 splice (@todir, $toi, 0, $fromdir[$fromi]);
540 $toi++;
541 $fromi++;
542 }
543 }
544}
545## synchronizeDirectory()
546
547
548# /**
549# */
550sub transferFile
551{
552 my ($mode, $file, $dest) = @_;
553 # remove trailing slashes from source and destination files
554 $file =~ s/[\\\/]+$//;
555 $dest =~ s/[\\\/]+$//;
556 my $tempdest = $dest;
557 if (!-e $file)
558 {
559 &FileUtils::printError('File does not exist: ' . $file);
560 }
561 else
562 {
563 if (-d $tempdest)
564 {
565 my ($filename) = $file =~ /([^\\\/]+)$/;
566 $tempdest .= "/$filename";
567 }
568 # start by processing any move request
569 if ($mode eq 'MOVE')
570 {
571 &File::Copy::move($file, $tempdest);
572 }
573 # now if we were instead doing a copy, or if the move request above failed
574 # for some reason, we process a copy request
575 if ($mode eq 'COPY' || !-e $tempdest)
576 {
577 &File::Copy::copy($file, $tempdest);
578 }
579 # finally, we check if a successful move command has somehow left the origin
580 # file lying around (rename partially succeeded - for instance when moving
581 # hardlinks)
582 if ($mode eq 'MOVE' && -e $tempdest && -e $file)
583 {
584 unlink($file);
585 }
586 }
587 # Have we successfully moved the file?
588 my $result = 0;
589 if (-e $tempdest)
590 {
591 if ($mode eq 'MOVE')
592 {
593 if (-e $file)
594 {
595 &FileUtils::printError('Failed to remove original file during move: ' . $file);
596 }
597 else
598 {
599 $result = 1;
600 }
601 }
602 else
603 {
604 $result = 1;
605 }
606 }
607 else
608 {
609 &FileUtils::printError('Failed to move/copy file: ' . $file);
610 }
611 return $result;
612}
613# /** moveFile() **/
614
6151;
Note: See TracBrowser for help on using the repository browser.