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

Revision 27569, 13.9 KB (checked in by jmt12, 6 years ago)

Trying to streamline the error messages from failing to link (otherwise I get a zillion messages about being unable to link from /tmp to /share as they are different physical media, for instance)

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## @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 browser.