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

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

Forgot these were just symbolic links to my Dropbox folder - adding in the actual files
File size: 14.0 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 closeFileHandle
33#
34sub closeFileHandle
35{
36 my $fh_ref = shift(@_);
37 close($$fh_ref);
38 return 1;
39}
40## closeFileHandle()
41
42
43## @function filenameConcatenate()
44#
45sub filenameConcatenate
46{
47 my $first_file = shift(@_);
48 my (@filenames) = @_;
49
50 # Useful for debugging
51 # -- might make sense to call caller(0) rather than (1)??
52 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
53 # print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
54
55 # If first_file is not null or empty, then add it back into the list
56 if (defined $first_file && $first_file =~ /\S/) {
57 unshift(@filenames, $first_file);
58 }
59
60 my $filename = join("/", @filenames);
61
62 # remove duplicate slashes and remove the last slash
63 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
64 $filename =~ s/[\\\/]+/\\/g;
65 } else {
66 $filename =~ s/[\/]+/\//g;
67 # DB: want a filename abc\de.html to remain like this
68 }
69 $filename =~ s/[\\\/]$//;
70
71 return $filename;
72}
73## filenameConcatenate()
74
75
76## @function fileSize()
77#
78sub fileSize
79{
80 my ($filename_full_path) = @_;
81 return -s $filename_full_path;
82}
83## fileStatus()
84
85
86## @function fileTest()
87#
88sub fileTest
89{
90 my $filename_full_path = shift(@_);
91 # By default tests for existance of file or directory (-e)
92 # Can be made more specific by providing second parameter (e.g. -f or -d)
93 my $test_op = shift(@_) || '-e';
94
95 my $exists = 0;
96
97 if ($ENV{'GSDLOS'} =~ m/^windows$/i) {
98 require Win32;
99 my $filename_short_path = Win32::GetShortPathName($filename_full_path);
100 if (!defined $filename_short_path) {
101 # Was probably still in UTF8 form (not what is needed on Windows)
102 my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
103 if (defined $unicode_filename_full_path) {
104 $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
105 }
106 }
107 $filename_full_path = $filename_short_path;
108 }
109
110 if (defined $filename_full_path) {
111 $exists = eval "($test_op \$filename_full_path)";
112 }
113
114 # The eval may result in exists being undefined, but we need to return
115 # something
116 return ($exists || 0);
117}
118## fileTest()
119
120
121## @function linkFile()
122#
123sub linkFile
124{
125 my ($mode, $src, $dest, $ensure_paths_absolute) = @_;
126
127 # remove trailing slashes from source and destination files
128 $src =~ s/[\\\/]+$//;
129 $dest =~ s/[\\\/]+$//;
130
131 # Ensure file paths are absolute IF requested to do so
132 # Soft_linking didn't work for relative paths
133 if($mode eq 'HARD' || (defined $ensure_paths_absolute && $ensure_paths_absolute))
134 {
135 # We need to ensure that the src file is the absolute path
136 # See http://perldoc.perl.org/File/Spec.html
137 if(!File::Spec->file_name_is_absolute( $src ))
138 {
139 # it's relative
140 $src = File::Spec->rel2abs($src); # make absolute
141 }
142 # Might as well ensure that the destination file's absolute path is used
143 if(!File::Spec->file_name_is_absolute( $dest ))
144 {
145 $dest = File::Spec->rel2abs($dest); # make absolute
146 }
147 }
148
149 # a few sanity checks
150 if (!-e $src)
151 {
152 &FileUtils::printError('Source file does not exist: ' . $src);
153 return 0;
154 }
155
156 my $dest_dir = &File::Basename::dirname($dest);
157 if (!-e $dest_dir)
158 {
159 &makeAllDirectories($dest_dir);
160 }
161
162 if ($ENV{'GSDLOS'} =~ /^windows$/i)
163 {
164 # symlink not supported on windows
165 &FileUtils::printWarning('Symlink not supported on windows');
166 }
167 elsif ($mode eq 'HARD')
168 {
169 if (!eval {link($src, $dest)})
170 {
171 &FileUtils::printWarning('Unable to create hard link: ' . $dest);
172 }
173 }
174 elsif ($mode eq 'SOFT')
175 {
176 if (!eval {symlink($src, $dest)})
177 {
178 &FileUtils::printWarning('Unable to create soft link: ' . $src);
179 }
180 }
181 else
182 {
183 &FileUtils::printError('Unknown mode requested: ' . $mode);
184 }
185 if (!-e $dest)
186 {
187 &_printWarning('linkFile', 'Link failed. Attempting to copy instead.');
188 &File::Copy::copy ($src, $dest);
189 }
190 return (-e $dest);
191}
192# /** linkFile() **/
193
194## @function makeAllDirectories()
195#
196# in case anyone cares - I did some testing (using perls Benchmark module)
197# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
198# slightly faster (surprisingly) - Stefan.
199#
200sub makeAllDirectories
201{
202 my ($dir) = @_;
203
204 # use / for the directory separator, remove duplicate and
205 # trailing slashes
206 $dir=~s/[\\\/]+/\//g;
207 $dir=~s/[\\\/]+$//;
208
209 # ensure the directory doesn't already exist
210 if (-e $dir)
211 {
212 return 0;
213 }
214
215 # make sure the cache directory exists
216 my $dirsofar = "";
217 my $first = 1;
218 foreach my $dirname (split ("/", $dir))
219 {
220 $dirsofar .= "/" unless $first;
221 $first = 0;
222
223 $dirsofar .= $dirname;
224
225 next if $dirname =~ /^(|[a-z]:)$/i;
226 if (!-e $dirsofar)
227 {
228 my $store_umask = umask(0002);
229 my $mkdir_ok = mkdir ($dirsofar, 0777);
230 umask($store_umask);
231 if (!$mkdir_ok)
232 {
233 &FileUtils::printError('Could not create directory: ' . $dirsofar);
234 return 0;
235 }
236 }
237 }
238 return (-e $dir);
239}
240## makeAllDirectories()
241
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.