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

Revision 27638, 13.8 KB (checked in by jmt12, 6 years ago)

Change it so failure to open a filehandle isn't fatal - leave it up to the caller to deal with

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