root/gs2-extensions/parallel-building/trunk/src/perllib/FileUtils/LocalFS.pm @ 30351

Revision 30351, 14.8 KB (checked in by jmt12, 5 years ago)

Restructured readDirectory to not die if directory isn't readable

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