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

Revision 27422, 14.3 KB (checked in by jmt12, 7 years ago)

Adding canRead() and isAbsolute() functions

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 canRead()
33#
34sub canRead
35{
36  my $path = shift(@_);
37  return &fileTest($path, '-R');
38}
39## canRead()
40
41
42## @function closeFileHandle
43#
44sub closeFileHandle
45{
46  my $fh_ref = shift(@_);
47  close($$fh_ref);
48  return 1;
49}
50## closeFileHandle()
51
52
53## @function filenameConcatenate()
54#
55sub filenameConcatenate
56{
57  my $first_file = shift(@_);
58  my (@filenames) = @_;
59
60  #   Useful for debugging
61  #     -- might make sense to call caller(0) rather than (1)??
62  #   my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
63  #   print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
64
65  # If first_file is not null or empty, then add it back into the list
66  if (defined $first_file && $first_file =~ /\S/) {
67    unshift(@filenames, $first_file);
68  }
69
70  my $filename = join("/", @filenames);
71
72  # remove duplicate slashes and remove the last slash
73  if ($ENV{'GSDLOS'} =~ /^windows$/i) {
74    $filename =~ s/[\\\/]+/\\/g;
75  } else {
76    $filename =~ s/[\/]+/\//g;
77    # DB: want a filename abc\de.html to remain like this
78  }
79  $filename =~ s/[\\\/]$//;
80
81  return $filename;
82}
83## filenameConcatenate()
84
85
86## @function fileSize()
87#
88sub fileSize
89{
90  my ($filename_full_path) = @_;
91  return -s $filename_full_path;
92}
93## fileStatus()
94
95
96## @function fileTest()
97#
98sub fileTest
99{
100  my $filename_full_path = shift(@_);
101  # By default tests for existance of file or directory (-e)
102  # Can be made more specific by providing second parameter (e.g. -f or -d)
103  my $test_op = shift(@_) || '-e';
104
105  my $exists = 0;
106
107  if ($ENV{'GSDLOS'} =~ m/^windows$/i) {
108    require Win32;
109    my $filename_short_path = Win32::GetShortPathName($filename_full_path);
110    if (!defined $filename_short_path) {
111      # Was probably still in UTF8 form (not what is needed on Windows)
112      my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
113      if (defined $unicode_filename_full_path) {
114        $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
115      }
116    }
117    $filename_full_path = $filename_short_path;
118  }
119
120  if (defined $filename_full_path) {
121    $exists = eval "($test_op \$filename_full_path)";
122  }
123
124  # The eval may result in exists being undefined, but we need to return
125  # something
126  return ($exists || 0);
127}
128## fileTest()
129
130
131## @function isFilenameAbsolute()
132#
133sub isFilenameAbsolute
134{
135  my ($filename) = @_;
136  if ($ENV{'GSDLOS'} =~ /^windows$/i)
137  {
138    return ($filename =~ m/^(\w:)?\\/);
139  }
140  return ($filename =~ m/^\//);
141}
142# isFilenameAbsolute()
143
144
145## @function linkFile()
146#
147sub linkFile
148{
149  my ($mode, $src, $dest, $ensure_paths_absolute) = @_;
150
151  # remove trailing slashes from source and destination files
152  $src =~ s/[\\\/]+$//;
153  $dest =~ s/[\\\/]+$//;
154
155  # Ensure file paths are absolute IF requested to do so
156  # Soft_linking didn't work for relative paths
157  if($mode eq 'HARD' || (defined $ensure_paths_absolute && $ensure_paths_absolute))
158  {
159    # We need to ensure that the src file is the absolute path
160    # See http://perldoc.perl.org/File/Spec.html
161    if(!File::Spec->file_name_is_absolute( $src ))
162    {
163      # it's relative
164      $src = File::Spec->rel2abs($src); # make absolute
165    }
166    # Might as well ensure that the destination file's absolute path is used
167    if(!File::Spec->file_name_is_absolute( $dest ))
168    {
169      $dest = File::Spec->rel2abs($dest); # make absolute
170    }
171  }
172
173  # a few sanity checks
174  if (!-e $src)
175  {
176    &FileUtils::printError('Source file does not exist: ' . $src);
177    return 0;
178  }
179
180  my $dest_dir = &File::Basename::dirname($dest);
181  if (!-e $dest_dir)
182  {
183    &makeAllDirectories($dest_dir);
184  }
185
186  if ($ENV{'GSDLOS'} =~ /^windows$/i)
187  {
188    # symlink not supported on windows
189    &FileUtils::printWarning('Symlink not supported on windows');
190  }
191  elsif ($mode eq 'HARD')
192  {
193    if (!eval {link($src, $dest)})
194    {
195      &FileUtils::printWarning('Unable to create hard link: ' . $dest);
196    }
197  }
198  elsif ($mode eq 'SOFT')
199  {
200    if (!eval {symlink($src, $dest)})
201    {
202      &FileUtils::printWarning('Unable to create soft link: ' . $src);
203    }
204  }
205  else
206  {
207    &FileUtils::printError('Unknown mode requested: ' . $mode);
208  }
209  if (!-e $dest)
210  {
211    &_printWarning('linkFile', 'Link failed. Attempting to copy instead.');
212    &File::Copy::copy ($src, $dest);
213  }
214  return (-e $dest);
215}
216# /** linkFile() **/
217
218## @function makeAllDirectories()
219#
220# in case anyone cares - I did some testing (using perls Benchmark module)
221# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
222# slightly faster (surprisingly) - Stefan.
223#
224sub makeAllDirectories
225{
226  my ($dir) = @_;
227
228  # use / for the directory separator, remove duplicate and
229  # trailing slashes
230  $dir=~s/[\\\/]+/\//g;
231  $dir=~s/[\\\/]+$//;
232
233  # ensure the directory doesn't already exist
234  if (-e $dir)
235  {
236    return 0;
237  }
238
239  # make sure the cache directory exists
240  my $dirsofar = "";
241  my $first = 1;
242  foreach my $dirname (split ("/", $dir))
243  {
244    $dirsofar .= "/" unless $first;
245    $first = 0;
246
247    $dirsofar .= $dirname;
248
249    next if $dirname =~ /^(|[a-z]:)$/i;
250    if (!-e $dirsofar)
251    {
252      my $store_umask = umask(0002);
253      my $mkdir_ok = mkdir ($dirsofar, 0777);
254      umask($store_umask);
255      if (!$mkdir_ok)
256      {
257        &FileUtils::printError('Could not create directory: ' . $dirsofar);
258        return 0;
259      }
260    }
261  }
262  return (-e $dir);
263}
264## makeAllDirectories()
265
266
267## @function makeDirectory()
268#
269sub makeDirectory
270{
271  my $dir = shift(@_);
272  my $store_umask = umask(0002);
273  my $mkdir_ok = mkdir ($dir, 0777);
274  umask($store_umask);
275  return $mkdir_ok;
276}
277## makeDirectory()
278
279
280## @function modificationTime()
281#
282sub modificationTime
283{
284  my $path = shift(@_);
285  my @file_status = stat($path);
286  return $file_status[9];
287}
288## modificationTime()
289
290## @function openFileHandle()
291#
292sub openFileHandle
293{
294  my $path = shift(@_);
295  my $mode = shift(@_);
296  my $fh_ref = shift(@_);
297  my $encoding = shift(@_);
298  my $mode_symbol;
299  if ($mode eq 'w' || $mode eq '>')
300  {
301    $mode_symbol = '>';
302    $mode = 'writing';
303  }
304  elsif ($mode eq 'a' || $mode eq '>>')
305  {
306    $mode_symbol = '>>';
307    $mode = 'appending';
308  }
309  else
310  {
311    $mode_symbol = '<';
312    $mode = 'reading';
313  }
314  if (defined $encoding)
315  {
316    $mode_symbol .= ':' . $encoding;
317  }
318  if (!open($$fh_ref, $mode_symbol, $path))
319  {
320    &FileUtils::printError('Failed to open file for ' . $mode . ': ' . $path, 1);
321  }
322  return 1;
323}
324## openFileHandle()
325
326# /**
327#  */
328sub readDirectory
329{
330  my $path = shift(@_);
331  opendir(DH, $path) or &FileUtils::printError('Failed to open directory for reading: ' . $path, 1);
332  my @files = readdir(DH);
333  close(DH);
334  return \@files;
335}
336# /** readDirectory() **/
337
338
339## @function removeFiles()
340#
341sub removeFiles
342{
343  my $file = shift(@_);
344  my $result = 0;
345  if (!-e $file && !-l $file)
346  {
347    &FileUtils::printError('File does not exist: ' . $file);
348  }
349  elsif ((!-f $file) && (!-l $file))
350  {
351    &FileUtils::printError('Not a regular file: ' . $file);
352  }
353  else
354  {
355    $result = unlink($file);
356    if (!$result)
357    {
358      &FileUtils::printError('Failed to remove file: ' . $file);
359    }
360  }
361  return $result;
362}
363## removeFiles()
364
365
366## @function removeFilesFiltered()
367#
368# recursive removal
369#
370sub removeFilesFiltered
371{
372  my ($files, $file_accept_re, $file_reject_re) = @_;
373  #   my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
374  #   my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
375  #   print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
376  my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
377
378  my $num_removed = 0;
379
380  foreach my $file (@files_array)
381  {
382    # remove trailing slashes
383    $file =~ s/[\/\\]+$//;
384
385    if (!-e $file)
386    {
387      print STDERR "util::filtered_rm_r $file does not exist\n";
388    }
389    # don't recurse down symbolic link
390    elsif ((-d $file) && (!-l $file))
391    {
392      # get the contents of this directory
393      if (!opendir (INDIR, $file))
394      {
395        print STDERR "util::filtered_rm_r could not open directory $file\n";
396      }
397      else
398      {
399        my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
400        closedir (INDIR);
401
402        # remove all the files in this directory
403        map {$_="$file/$_";} @filedir;
404        $num_removed += &FileUtils::LocalFS::removeFilesFiltered(\@filedir, $file_accept_re, $file_reject_re);
405
406        if (!defined $file_accept_re && !defined $file_reject_re)
407        {
408          # remove this directory
409          if (!rmdir $file)
410          {
411            print STDERR "util::filtered_rm_r couldn't remove directory $file\n";
412          }
413          else
414          {
415            $num_removed++;
416          }
417        }
418      }
419    }
420    else
421    {
422      next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
423
424      if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
425      {
426        # remove this file
427        $num_removed += &removeFiles($file);
428      }
429    }
430  }
431  return $num_removed;
432}
433## removeFilesFiltered()
434
435
436## @function removeFilesRecursive()
437#
438sub removeFilesRecursive
439{
440  my $path = shift(@_);
441  # use the more general (but reterospectively written filteredRemove()
442  # function with no accept or reject expressions
443  return FileUtils::LocalFS::removeFilesFiltered($path, undef, undef);
444}
445## removeFilesRecursive()
446
447
448## @function supportsSymbolicLink
449#
450sub supportsSymbolicLink
451{
452  return 1;
453}
454## supportsSymbolicLink()
455
456
457## @function synchronizeDirectory()
458#
459# updates a copy of a directory in some other part of the filesystem
460# verbosity settings are: 0=low, 1=normal, 2=high
461# both $fromdir and $todir should be absolute paths
462#
463sub synchronizeDirectory
464{
465  my ($fromdir, $todir, $verbosity) = @_;
466  $verbosity = 1 unless defined $verbosity;
467
468  # use / for the directory separator, remove duplicate and
469  # trailing slashes
470  $fromdir=~s/[\\\/]+/\//g;
471  $fromdir=~s/[\\\/]+$//;
472  $todir=~s/[\\\/]+/\//g;
473  $todir=~s/[\\\/]+$//;
474
475  &mk_all_dir ($todir);
476
477  # get the directories in ascending order
478  if (!opendir (FROMDIR, $fromdir))
479  {
480    print STDERR "util::cachedir could not read directory $fromdir\n";
481    return;
482  }
483  my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
484  closedir (FROMDIR);
485
486  if (!opendir (TODIR, $todir))
487  {
488    print STDERR "util::cacedir could not read directory $todir\n";
489    return;
490  }
491  my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
492  closedir (TODIR);
493
494  my $fromi = 0;
495  my $toi = 0;
496
497  while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
498  {
499    #   print "fromi: $fromi toi: $toi\n";
500
501    # see if we should delete a file/directory
502    # this should happen if the file/directory
503    # is not in the from list or if its a different
504    # size, or has an older timestamp
505    if ($toi < scalar(@todir))
506    {
507      if (($fromi >= scalar(@fromdir)) ||
508          ($todir[$toi] lt $fromdir[$fromi] ||
509           ($todir[$toi] eq $fromdir[$fromi] &&
510            &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
511                            $verbosity))))
512      {
513        # the files are different
514        &rm_r("$todir/$todir[$toi]");
515        splice(@todir, $toi, 1); # $toi stays the same
516      }
517      elsif ($todir[$toi] eq $fromdir[$fromi])
518      {
519        # the files are the same
520        # if it is a directory, check its contents
521        if (-d "$todir/$todir[$toi]")
522        {
523          &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
524        }
525
526        $toi++;
527        $fromi++;
528        next;
529      }
530    }
531
532    # see if we should insert a file/directory
533    # we should insert a file/directory if there
534    # is no tofiles left or if the tofile does not exist
535    if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
536                                      $todir[$toi] gt $fromdir[$fromi]))
537    {
538      &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
539      splice (@todir, $toi, 0, $fromdir[$fromi]);
540      $toi++;
541      $fromi++;
542    }
543  }
544}
545## synchronizeDirectory()
546
547
548# /**
549#  */
550sub transferFile
551{
552  my ($mode, $file, $dest) = @_;
553  # remove trailing slashes from source and destination files
554  $file =~ s/[\\\/]+$//;
555  $dest =~ s/[\\\/]+$//;
556  my $tempdest = $dest;
557  if (!-e $file)
558  {
559    &FileUtils::printError('File does not exist: ' . $file);
560  }
561  else
562  {
563    if (-d $tempdest)
564    {
565      my ($filename) = $file =~ /([^\\\/]+)$/;
566      $tempdest .= "/$filename";
567    }
568    # start by processing any move request
569    if ($mode eq 'MOVE')
570    {
571      &File::Copy::move($file, $tempdest);
572    }
573    # now if we were instead doing a copy, or if the move request above failed
574    # for some reason, we process a copy request
575    if ($mode eq 'COPY' || !-e $tempdest)
576    {
577      &File::Copy::copy($file, $tempdest);
578    }
579    # finally, we check if a successful move command has somehow left the origin
580    # file lying around (rename partially succeeded - for instance when moving
581    # hardlinks)
582    if ($mode eq 'MOVE' && -e $tempdest && -e $file)
583    {
584      unlink($file);
585    }
586  }
587  # Have we successfully moved the file?
588  my $result = 0;
589  if (-e $tempdest)
590  {
591    if ($mode eq 'MOVE')
592    {
593      if (-e $file)
594      {
595        &FileUtils::printError('Failed to remove original file during move: ' . $file);
596      }
597      else
598      {
599        $result = 1;
600      }
601    }
602    else
603    {
604      $result = 1;
605    }
606  }
607  else
608  {
609    &FileUtils::printError('Failed to move/copy file: ' . $file);
610  }
611  return $result;
612}
613# /** moveFile() **/
614
6151;
Note: See TracBrowser for help on using the browser.