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

Revision 27682, 14.8 KB (checked in by jmt12, 6 years ago)

Copying makeAllDirectories() from vanilla FileUtils?.pm

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