root/main/trunk/greenstone2/perllib/FileUtils.pm @ 31187

Revision 31187, 31.2 KB (checked in by ak19, 3 years ago)

Useful changes not specifically related to upcoming oaiinfo db related commit.

Line 
1###########################################################################
2#
3# FileUtils.pm -- functions for dealing with files. Skeleton for more
4# advanced system using dynamic class cloading available in extensions.
5#
6# A component of the Greenstone digital library software
7# from the New Zealand Digital Library Project at the
8# University of Waikato, New Zealand.
9#
10# Copyright (C) 2013 New Zealand Digital Library Project
11#
12# This program is free software; you can redistribute it and/or modify
13# it under the terms of the GNU General Public License as published by
14# the Free Software Foundation; either version 2 of the License, or
15# (at your option) any later version.
16#
17# This program is distributed in the hope that it will be useful,
18# but WITHOUT ANY WARRANTY; without even the implied warranty of
19# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20# GNU General Public License for more details.
21#
22# You should have received a copy of the GNU General Public License
23# along with this program; if not, write to the Free Software
24# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25#
26###########################################################################
27
28package FileUtils;
29
30# Pragma
31use strict;
32use warnings;
33
34use FileHandle;
35
36# Greenstone modules
37use util;
38
39################################################################################
40# util::cachedir()             => FileUtils::synchronizeDirectory()
41# util::cp()                   => FileUtils::copyFiles()
42# util::cp_r()                 => FileUtils::copyFilesRecursive()
43# util::cp_r_nosvn()           => FileUtils::copyFilesRecursiveNoSVN()
44# util::cp_r_toplevel()        => FileUtils::copyFilesRecursiveTopLevel()
45# util::differentfiles()       => FileUtils::differentFiles()
46# util::dir_exists()           => FileUtils::directoryExists()
47# util::fd_exists()            => FileUtils::fileTest()
48# util::file_exists()          => FileUtils::fileExists()
49# util::filename_cat()         => FileUtils::filenameConcatenate()
50# util::filename_is_absolute() => FileUtils::isFilenameAbsolute()
51# util::filtered_rm_r()        => FileUtils::removeFilesFiltered()
52# util::hard_link()            => FileUtils::hardLink()
53# util::is_dir_empty()         => FileUtils::isDirectoryEmpty()
54# util::mk_all_dir()           => FileUtils::makeAllDirectories()
55# util::mk_dir()               => FileUtils::makeDirectory()
56# util::mv()                   => FileUtils::moveFiles()
57# util::mv_dir_contents()      => FileUtils::moveDirectoryContents()
58# util::rm()                   => FileUtils::removeFiles()
59# util::rm_r()                 => FileUtils::removeFilesRecursive()
60# util::soft_link()            => FileUtils::softLink()
61
62# Other functions in this file (perhaps some of these may have counterparts in util.pm too):
63
64#canRead
65#isSymbolicLink
66#modificationTime
67#readDirectory
68#removeFilesDebug
69#sanitizePath
70#openFileHandle
71#closeFileHandle
72#differentFiles
73#filePutContents
74#fileSize
75#readDirectory
76
77################################################################################
78# Note: there are lots of functions involving files/directories/paths
79# etc found in utils.pm that are not represented here. My intention
80# was to just have those functions that need to be dynamic based on
81# filesystem, or need some rejigging to be filesystem aware. There is
82# an argument, I guess, for moving some of the other functions here so
83# that they are nicely encapsulated - but the question is what to do
84# with functions like filename_within_directory_url_format() which is
85# more URL based than file based.
86################################################################################
87
88
89## @function canRead()
90#
91sub canRead
92{
93  my ($filename_full_path) = @_;
94  return &fileTest($filename_full_path, '-R');
95}
96## canRead()
97
98
99## @function closeFileHandle
100#
101sub closeFileHandle
102{
103  my ($path, $fh_ref) = @_;
104  close($$fh_ref);
105}
106## closeFileHandle()
107
108
109## @function copyFiles()
110#
111# copies a file or a group of files
112#
113sub copyFiles
114{
115  my $dest = pop (@_);
116  my (@srcfiles) = @_;
117
118  # remove trailing slashes from source and destination files
119  $dest =~ s/[\\\/]+$//;
120  map {$_ =~ s/[\\\/]+$//;} @srcfiles;
121
122  # a few sanity checks
123  if (scalar (@srcfiles) == 0)
124  {
125    print STDERR "FileUtils::copyFiles() no destination directory given\n";
126    return;
127  }
128  elsif ((scalar (@srcfiles) > 1) && (!-d $dest))
129  {
130    print STDERR "FileUtils::copyFiles() if multiple source files are given the destination must be a directory\n";
131    return;
132  }
133
134  # copy the files
135  foreach my $file (@srcfiles)
136  {
137    my $tempdest = $dest;
138    if (-d $tempdest)
139    {
140      my ($filename) = $file =~ /([^\\\/]+)$/;
141      $tempdest .= "/$filename";
142    }
143    if (!-e $file)
144    {
145      print STDERR "FileUtils::copyFiles() $file does not exist\n";
146    }
147    elsif (!-f $file)
148    {
149      print STDERR "FileUtils::copyFiles() $file is not a plain file\n";
150    }
151    else
152    {
153      &File::Copy::copy ($file, $tempdest);
154    }
155  }
156}
157## copyFiles()
158
159
160## @function copyFilesRecursive()
161#
162# recursively copies a file or group of files syntax: cp_r
163# (sourcefiles, destination directory) destination must be a directory
164# to copy one file to another use cp instead
165#
166sub copyFilesRecursive
167{
168  my $dest = pop (@_);
169  my (@srcfiles) = @_;
170
171  # a few sanity checks
172  if (scalar (@srcfiles) == 0)
173  {
174    print STDERR "FileUtils::copyFilesRecursive() no destination directory given\n";
175    return;
176  }
177  elsif (-f $dest)
178  {
179    print STDERR "FileUtils::copyFilesRecursive() destination must be a directory\n";
180    return;
181  }
182
183  # create destination directory if it doesn't exist already
184  if (! -d $dest)
185  {
186    my $store_umask = umask(0002);
187    mkdir ($dest, 0777);
188    umask($store_umask);
189  }
190
191  # copy the files
192  foreach my $file (@srcfiles)
193  {
194
195    if (!-e $file)
196    {
197      print STDERR "FileUtils::copyFilesRecursive() $file does not exist\n";
198    }
199    elsif (-d $file)
200    {
201      # make the new directory
202      my ($filename) = $file =~ /([^\\\/]*)$/;
203      $dest = &filenameConcatenate($dest, $filename);
204      my $store_umask = umask(0002);
205      mkdir ($dest, 0777);
206      umask($store_umask);
207
208      # get the contents of this directory
209      if (!opendir (INDIR, $file))
210      {
211        print STDERR "FileUtils::copyFilesRecursive() could not open directory $file\n";
212      }
213      else
214      {
215        my @filedir = readdir (INDIR);
216        closedir (INDIR);
217        foreach my $f (@filedir)
218        {
219          next if $f =~ /^\.\.?$/;
220          # copy all the files in this directory
221          my $ff = &filenameConcatenate($file, $f);
222          &copyFilesRecursive($ff, $dest);
223        }
224      }
225
226    }
227    else
228    {
229      &copyFiles($file, $dest);
230    }
231  }
232}
233## copyFilesRecursive()
234
235
236## @function copyFilesRecursiveNoSVN()
237#
238# recursively copies a file or group of files, excluding SVN
239# directories, with syntax: cp_r (sourcefiles, destination directory)
240# destination must be a directory - to copy one file to another use cp
241# instead
242#
243# this should be merged with copyFilesRecursive() at some stage - jmt12
244#
245sub copyFilesRecursiveNoSVN
246{
247  my $dest = pop (@_);
248  my (@srcfiles) = @_;
249
250  # a few sanity checks
251  if (scalar (@srcfiles) == 0)
252  {
253    print STDERR "FileUtils::copyFilesRecursiveNoSVN() no destination directory given\n";
254    return;
255  }
256  elsif (-f $dest)
257  {
258    print STDERR "FileUtils::copyFilesRecursiveNoSVN() destination must be a directory\n";
259    return;
260  }
261
262  # create destination directory if it doesn't exist already
263  if (! -d $dest)
264  {
265    my $store_umask = umask(0002);
266    mkdir ($dest, 0777);
267    umask($store_umask);
268  }
269
270  # copy the files
271  foreach my $file (@srcfiles)
272  {
273    if (!-e $file)
274    {
275      print STDERR "copyFilesRecursiveNoSVN() $file does not exist\n";
276    }
277    elsif (-d $file)
278    {
279      # make the new directory
280      my ($filename) = $file =~ /([^\\\/]*)$/;
281      $dest = &filenameConcatenate($dest, $filename);
282      my $store_umask = umask(0002);
283      mkdir ($dest, 0777);
284      umask($store_umask);
285
286      # get the contents of this directory
287      if (!opendir (INDIR, $file))
288      {
289        print STDERR "copyFilesRecursiveNoSVN() could not open directory $file\n";
290      }
291      else
292      {
293        my @filedir = readdir (INDIR);
294        closedir (INDIR);
295        foreach my $f (@filedir)
296        {
297          next if $f =~ /^\.\.?$/;
298          next if $f =~ /^\.svn$/;
299          # copy all the files in this directory
300          my $ff = &filenameConcatenate($file, $f);
301          # util.pm version incorrectly called cp_r here - jmt12
302          &copyFilesRecursiveNoSVN($ff, $dest);
303        }
304      }
305    }
306    else
307    {
308      &copyFiles($file, $dest);
309    }
310  }
311}
312## copyFilesRecursiveNoSVN()
313
314
315## @function copyFilesRecursiveTopLevel()
316#
317# copies a directory and its contents, excluding subdirectories, into a new directory
318#
319# another candidate for merging in with copyFilesRecursive() - jmt12
320#
321sub copyFilesRecursiveTopLevel
322{
323  my $dest = pop (@_);
324  my (@srcfiles) = @_;
325
326  # a few sanity checks
327  if (scalar (@srcfiles) == 0)
328  {
329    print STDERR "FileUtils::copyFilesRecursiveTopLevel() no destination directory given\n";
330    return;
331  }
332  elsif (-f $dest)
333  {
334    print STDERR "FileUtils::copyFilesRecursiveTopLevel() destination must be a directory\n";
335    return;
336  }
337
338  # create destination directory if it doesn't exist already
339  if (! -d $dest)
340  {
341    my $store_umask = umask(0002);
342    mkdir ($dest, 0777);
343    umask($store_umask);
344  }
345
346  # copy the files
347  foreach my $file (@srcfiles)
348  {
349    if (!-e $file)
350    {
351      print STDERR "FileUtils::copyFilesRecursiveTopLevel() $file does not exist\n";
352    }
353    elsif (-d $file)
354    {
355      # make the new directory
356      my ($filename) = $file =~ /([^\\\/]*)$/;
357      $dest = &filenameConcatenate($dest, $filename);
358      my $store_umask = umask(0002);
359      mkdir ($dest, 0777);
360      umask($store_umask);
361
362      # get the contents of this directory
363      if (!opendir (INDIR, $file))
364      {
365        print STDERR "FileUtils::copyFilesRecursiveTopLevel() could not open directory $file\n";
366      }
367      else
368      {
369        my @filedir = readdir (INDIR);
370        closedir (INDIR);
371        foreach my $f (@filedir)
372        {
373          next if $f =~ /^\.\.?$/;
374
375          # copy all the files in this directory, but not directories
376          my $ff = &filenameConcatenate($file, $f);
377          if (-f $ff)
378          {
379            &copyFiles($ff, $dest);
380            #&cp_r ($ff, $dest);
381          }
382        }
383      }
384    }
385    else
386    {
387      &copyFiles($file, $dest);
388    }
389  }
390}
391## copyFilesRecursiveTopLevel()
392
393
394## @function differentFiles()
395#
396# this function returns -1 if either file is not found assumes that
397# $file1 and $file2 are absolute file names or in the current
398# directory $file2 is allowed to be newer than $file1
399#
400sub differentFiles
401{
402  my ($file1, $file2, $verbosity) = @_;
403  $verbosity = 1 unless defined $verbosity;
404
405  $file1 =~ s/\/+$//;
406  $file2 =~ s/\/+$//;
407
408  my ($file1name) = $file1 =~ /\/([^\/]*)$/;
409  my ($file2name) = $file2 =~ /\/([^\/]*)$/;
410
411  return -1 unless (-e $file1 && -e $file2);
412  if ($file1name ne $file2name)
413  {
414    print STDERR "filenames are not the same\n" if ($verbosity >= 2);
415    return 1;
416  }
417
418  my @file1stat = stat ($file1);
419  my @file2stat = stat ($file2);
420
421  if (-d $file1)
422  {
423    if (! -d $file2)
424    {
425      print STDERR "one file is a directory\n" if ($verbosity >= 2);
426      return 1;
427    }
428    return 0;
429  }
430
431  # both must be regular files
432  unless (-f $file1 && -f $file2)
433  {
434    print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
435    return 1;
436  }
437
438  # the size of the files must be the same
439  if ($file1stat[7] != $file2stat[7])
440  {
441    print STDERR "different sized files\n" if ($verbosity >= 2);
442    return 1;
443  }
444
445  # the second file cannot be older than the first
446  if ($file1stat[9] > $file2stat[9])
447  {
448    print STDERR "file is older\n" if ($verbosity >= 2);
449    return 1;
450  }
451
452  return 0;
453}
454## differentFiles()
455
456
457## @function directoryExists()
458#
459sub directoryExists
460{
461  my ($filename_full_path) = @_;
462  return &fileTest($filename_full_path, '-d');
463}
464## directoryExists()
465
466
467## @function fileExists()
468#
469sub fileExists
470{
471  my ($filename_full_path) = @_;
472  return &fileTest($filename_full_path, '-f');
473}
474## fileExists()
475
476## @function filenameConcatenate()
477#
478sub filenameConcatenate
479{
480  my $first_file = shift(@_);
481  my (@filenames) = @_;
482
483  #   Useful for debugging
484  #     -- might make sense to call caller(0) rather than (1)??
485  #   my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
486  #   print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
487
488  # If first_file is not null or empty, then add it back into the list
489  if (defined $first_file && $first_file =~ /\S/)
490  {
491    unshift(@filenames, $first_file);
492  }
493
494  my $filename = join("/", @filenames);
495
496  # remove duplicate slashes and remove the last slash
497  if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin"))
498  {
499    $filename =~ s/[\\\/]+/\\/g;
500  }
501  else
502  {
503    $filename =~ s/[\/]+/\//g;
504    # DB: want a filename abc\de.html to remain like this
505  }
506  $filename =~ s/[\\\/]$//;
507
508  return $filename;
509}
510## filenameConcatenate()
511
512
513
514## @function javaFilenameConcatenate()
515#
516# Same as filenameConcatenate(), except because on Cygwin
517# the java we run is still Windows native, then this means
518# we want the generate filename to be in native Windows format
519sub javaFilenameConcatenate
520{
521  my (@filenames) = @_;
522
523  my $filename_cat = filenameConcatenate(@filenames);
524
525  if ($^O eq "cygwin") {
526      # java program, using a binary that is native to Windows, so need
527      # Windows directory and path separators
528
529      $filename_cat = `cygpath -wp "$filename_cat"`;
530      chomp($filename_cat);
531      $filename_cat =~ s%\\%\\\\%g;
532  }
533
534  return $filename_cat;
535}
536## javaFilenameConcatenate()
537
538
539## @function filePutContents()
540#
541# Create a file and write the given string directly to it
542# @param $path the full path of the file to write as a String
543# @param $content the String to be written to the file
544#
545sub filePutContents
546{
547  my ($path, $content) = @_;
548  if (open(FOUT, '>:utf8', $path))
549  {
550    print FOUT $content;
551    close(FOUT);
552  }
553  else
554  {
555    die('Error! Failed to open file for writing: ' . $path . "\n");
556  }
557}
558## filePutContents()
559
560## @function fileSize()
561#
562sub fileSize
563{
564  my $path = shift(@_);
565  my $file_size = -s $path;
566  return $file_size;
567}
568## fileSize()
569
570## @function fileTest()
571#
572sub fileTest
573{
574  my $filename_full_path = shift @_;
575  my $test_op = shift @_ || "-e";
576
577  # By default tests for existance of file or directory (-e)
578  # Can be made more specific by providing second parameter (e.g. -f or -d)
579
580  my $exists = 0;
581
582  if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin"))
583  {
584    require Win32;
585    my $filename_short_path = Win32::GetShortPathName($filename_full_path);
586    if (!defined $filename_short_path)
587    {
588      # Was probably still in UTF8 form (not what is needed on Windows)
589      my $unicode_filename_full_path = eval "decode(\"utf8\",\$filename_full_path)";
590      if (defined $unicode_filename_full_path)
591      {
592        $filename_short_path = Win32::GetShortPathName($unicode_filename_full_path);
593      }
594    }
595    $filename_full_path = $filename_short_path;
596  }
597
598  if (defined $filename_full_path)
599  {
600    $exists = eval "($test_op \$filename_full_path)";
601  }
602
603  return $exists;
604}
605## fileTest()
606
607## @function hardLink()
608# make hard link to file if supported by OS, otherwise copy the file
609#
610sub hardLink
611{
612  my ($src, $dest, $verbosity) = @_;
613
614  # remove trailing slashes from source and destination files
615  $src =~ s/[\\\/]+$//;
616  $dest =~ s/[\\\/]+$//;
617
618  ##    print STDERR "**** src = ", unicode::debug_unicode_string($src),"\n";
619  # a few sanity checks
620  if (-e $dest)
621  {
622    # destination file already exists
623    return;
624  }
625  elsif (!-e $src)
626  {
627    print STDERR "FileUtils::hardLink() source file \"" . $src . "\" does not exist\n";
628    return 1;
629  }
630  elsif (-d $src)
631  {
632    print STDERR "FileUtils::hardLink() source \"" . $src . "\" is a directory\n";
633    return 1;
634  }
635
636  my $dest_dir = &File::Basename::dirname($dest);
637  if (!-e $dest_dir)
638  {
639    &makeAllDirectories($dest_dir);
640  }
641
642  if (!link($src, $dest))
643  {
644    if ((!defined $verbosity) || ($verbosity>2))
645    {
646      print STDERR "FileUtils::hardLink(): unable to create hard link. ";
647      print STDERR " Copying file: $src -> $dest\n";
648    }
649    &File::Copy::copy ($src, $dest);
650  }
651  return 0;
652}
653## hardLink()
654
655## @function isDirectoryEmpty()
656#
657# A method to check if a directory is empty (note that an empty
658# directory still has non-zero size!!!).  Code is from
659# http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
660#
661sub isDirectoryEmpty
662{
663  my ($path) = @_;
664  opendir DIR, $path;
665  while(my $entry = readdir DIR)
666  {
667    next if($entry =~ /^\.\.?$/);
668    closedir DIR;
669    return 0;
670  }
671  closedir DIR;
672  return 1;
673}
674## isDirectoryEmpty()
675
676## @function isFilenameAbsolute()
677#
678sub isFilenameAbsolute
679{
680  my ($filename) = @_;
681  if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin"))
682  {
683    return ($filename =~ m/^(\w:)?\\/);
684  }
685  return ($filename =~ m/^\//);
686}
687# isFilenameAbsolute()
688
689## @function isSymbolicLink
690#
691# Determine if a given path is a symbolic link (soft link)
692#
693sub isSymbolicLink
694{
695  my $path = shift(@_);
696  my $is_soft_link = -l $path;
697  return $is_soft_link;
698}
699## isSymbolicLink()
700
701## @function makeAllDirectories()
702#
703# in case anyone cares - I did some testing (using perls Benchmark module)
704# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
705# slightly faster (surprisingly) - Stefan.
706#
707sub makeAllDirectories
708{
709  my ($dir) = @_;
710
711  # use / for the directory separator, remove duplicate and
712  # trailing slashes
713  $dir=~s/[\\\/]+/\//g;
714  $dir=~s/[\\\/]+$//;
715
716  # make sure the cache directory exists
717  my $dirsofar = "";
718  my $first = 1;
719  foreach my $dirname (split ("/", $dir))
720  {
721    $dirsofar .= "/" unless $first;
722    $first = 0;
723
724    $dirsofar .= $dirname;
725
726    next if $dirname =~ /^(|[a-z]:)$/i;
727    if (!-e $dirsofar)
728    {
729      my $store_umask = umask(0002);
730      my $mkdir_ok = mkdir ($dirsofar, 0777);
731      umask($store_umask);
732      if (!$mkdir_ok)
733      {
734        print STDERR "FileUtils::makeAllDirectories() could not create directory $dirsofar\n";
735        return;
736      }
737    }
738  }
739 return 1;
740}
741## makeAllDirectories()
742
743## @function makeDirectory()
744#
745sub makeDirectory
746{
747  my ($dir) = @_;
748
749  my $store_umask = umask(0002);
750  my $mkdir_ok = mkdir ($dir, 0777);
751  umask($store_umask);
752
753  if (!$mkdir_ok)
754  {
755    print STDERR "FileUtils::makeDirectory() could not create directory $dir\n";
756    return;
757  }
758}
759## makeDirectory()
760
761## @function modificationTime()
762#
763sub modificationTime
764{
765  my $path = shift(@_);
766  my @file_status = stat($path);
767  return $file_status[9];
768}
769## modificationTime()
770
771## @function moveDirectoryContents()
772#
773# Move the contents of source directory into target directory (as
774# opposed to merely replacing target dir with the src dir) This can
775# overwrite any files with duplicate names in the target but other
776# files and folders in the target will continue to exist
777#
778sub moveDirectoryContents
779{
780  my ($src_dir, $dest_dir) = @_;
781
782  # Obtain listing of all files within src_dir
783  # Note that readdir lists relative paths, as well as . and ..
784  opendir(DIR, "$src_dir");
785  my @files= readdir(DIR);
786  close(DIR);
787
788  my @full_path_files = ();
789  foreach my $file (@files)
790  {
791    # process all except . and ..
792    unless($file eq "." || $file eq "..")
793    {
794      my $dest_subdir = &filenameConcatenate($dest_dir, $file); # $file is still a relative path
795
796      # construct absolute paths
797      $file = &filenameConcatenate($src_dir, $file); # $file is now an absolute path
798
799      # Recurse on directories which have an equivalent in target dest_dir
800      # If $file is a directory that already exists in target $dest_dir,
801      # then a simple move operation will fail (definitely on Windows).
802      if(-d $file && -d $dest_subdir)
803      {
804        #print STDERR "**** $file is a directory also existing in target, its contents to be copied to $dest_subdir\n";
805        &moveDirectoryContents($file, $dest_subdir);
806
807        # now all content is moved across, delete empty dir in source folder
808        if(&isDirectoryEmpty($file))
809        {
810          if (!rmdir $file)
811          {
812            print STDERR "ERROR. FileUtils::moveDirectoryContents() couldn't remove directory $file\n";
813          }
814        }
815        # error
816        else
817        {
818          print STDERR "ERROR. FileUtils::moveDirectoryContents(): subfolder $file still non-empty after moving contents to $dest_subdir\n";
819        }
820      }
821      # process files and any directories that don't already exist with a simple move
822      else
823      {
824        push(@full_path_files, $file);
825      }
826    }
827  }
828
829  # create target toplevel folder or subfolders if they don't exist
830  if(!&directoryExists($dest_dir))
831  {
832    &makeDirectory($dest_dir);
833  }
834
835  #print STDERR "@@@@@ Copying files |".join(",", @full_path_files)."| to: $dest_dir\n";
836
837  # if non-empty, there's something to copy across
838  if(@full_path_files)
839  {
840    &moveFiles(@full_path_files, $dest_dir);
841  }
842}
843## moveDirectoryContents()
844
845## @function moveFiles()
846#
847# moves a file or a group of files
848#
849sub moveFiles
850{
851  my $dest = pop (@_);
852  my (@srcfiles) = @_;
853
854  # remove trailing slashes from source and destination files
855  $dest =~ s/[\\\/]+$//;
856  map {$_ =~ s/[\\\/]+$//;} @srcfiles;
857
858  # a few sanity checks
859  if (scalar (@srcfiles) == 0)
860  {
861    print STDERR "FileUtils::moveFiles() no destination directory given\n";
862    return;
863  }
864  elsif ((scalar (@srcfiles) > 1) && (!-d $dest))
865  {
866    print STDERR "FileUtils::moveFiles() if multiple source files are given the destination must be a directory\n";
867    return;
868  }
869
870  # move the files
871  foreach my $file (@srcfiles)
872  {
873    my $tempdest = $dest;
874    if (-d $tempdest)
875    {
876      my ($filename) = $file =~ /([^\\\/]+)$/;
877      $tempdest .= "/$filename";
878    }
879    if (!-e $file)
880    {
881      print STDERR "FileUtils::moveFiles() $file does not exist\n";
882    }
883    else
884    {
885      if(!rename ($file, $tempdest))
886      {
887        print STDERR "**** Failed to rename $file to $tempdest\n";
888        &File::Copy::copy($file, $tempdest);
889        &removeFiles($file);
890      }
891      # rename (partially) succeeded) but srcfile still exists after rename
892      elsif(-e $file)
893      {
894        #print STDERR "*** srcfile $file still exists after rename to $tempdest\n";
895        if(!-e $tempdest)
896        {
897          print STDERR "@@@@ ERROR: $tempdest does not exist\n";
898        }
899        # Sometimes the rename operation fails (as does
900        # File::Copy::move).  This turns out to be because the files
901        # are hardlinked.  Need to do a copy-delete in this case,
902        # however, the copy step is not necessary: the srcfile got
903        # renamed into tempdest, but srcfile itself still exists,
904        # delete it.  &File::Copy::copy($file, $tempdest);
905        &removeFiles($file);
906      }
907    }
908  }
909}
910## moveFiles()
911
912## @function openFileHandle()
913#
914sub openFileHandle
915{
916  my $path = shift(@_);
917  my $mode = shift(@_);
918  my $fh_ref = shift(@_);
919  my $encoding = shift(@_);
920  my $mode_symbol;
921  if ($mode eq 'w' || $mode eq '>')
922  {
923    $mode_symbol = '>';
924    $mode = 'writing';
925  }
926  elsif ($mode eq 'a' || $mode eq '>>')
927  {
928    $mode_symbol = '>>';
929    $mode = 'appending';
930  }
931  else
932  {
933    $mode_symbol = '<';
934    $mode = 'reading';
935  }
936  if (defined $encoding)
937  {
938    $mode_symbol .= ':' . $encoding;
939  }
940  return open($$fh_ref, $mode_symbol, $path);
941}
942## openFileHandle()
943
944
945## @function readDirectory()
946#
947sub readDirectory
948{
949  my $path = shift(@_);
950  my @files;
951  if (opendir(DH, $path))
952  {
953    @files = readdir(DH);
954    close(DH);
955  }
956  else
957  {
958    die("Error! Failed to open directory to list files: " . $path . "\n");
959  }
960  return \@files;
961}
962## readDirectory()
963
964## @function removeFiles()
965#
966# removes files (but not directories)
967#
968sub removeFiles
969{
970  my (@files) = @_;
971  my @filefiles = ();
972
973  # make sure the files we want to delete exist
974  # and are regular files
975  foreach my $file (@files)
976  {
977    if (!-e $file)
978    {
979      print STDERR "FileUtils::removeFiles() $file does not exist\n";
980    }
981    elsif ((!-f $file) && (!-l $file))
982    {
983      print STDERR "FileUtils::removeFiles() $file is not a regular (or symbolic) file\n";
984    }
985    else
986    {
987      push (@filefiles, $file);
988    }
989  }
990
991  # remove the files
992  my $numremoved = unlink @filefiles;
993
994  # check to make sure all of them were removed
995  if ($numremoved != scalar(@filefiles))
996  {
997    print STDERR "FileUtils::removeFiles() Not all files were removed\n";
998  }
999}
1000## removeFiles()
1001
1002## @function removeFilesDebug()
1003#
1004# removes files (but not directories) - can rename this to the default
1005# "rm" subroutine when debugging the deletion of individual files.
1006# Unused?
1007#
1008sub removeFilesDebug
1009{
1010  my (@files) = @_;
1011  my @filefiles = ();
1012
1013  # make sure the files we want to delete exist
1014  # and are regular files
1015  foreach my $file (@files)
1016  {
1017    if (!-e $file)
1018    {
1019      print STDERR "FileUtils::removeFilesDebug() " . $file . " does not exist\n";
1020    }
1021    elsif ((!-f $file) && (!-l $file))
1022    {
1023      print STDERR "FileUtils::removeFilesDebug() " . $file . " is not a regular (or symbolic) file\n";
1024    }
1025    # debug message
1026    else
1027    {
1028      unlink($file) or warn "Could not delete file " . $file . ": " . $! . "\n";
1029    }
1030  }
1031}
1032## removeFilesDebug()
1033
1034## @function removeFilesFiltered()
1035#
1036sub removeFilesFiltered
1037{
1038  my ($files,$file_accept_re,$file_reject_re) = @_;
1039
1040  #   my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(2);
1041  #   my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
1042  #   print STDERR "** Calling method (2): $lcfilename:$cline $cpackage->$csubr\n";
1043
1044  my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
1045
1046  # recursively remove the files
1047  foreach my $file (@files_array)
1048  {
1049    $file =~ s/[\/\\]+$//; # remove trailing slashes
1050
1051    if (!-e $file)
1052    {
1053      print STDERR "FileUtils::removeFilesFiltered() $file does not exist\n";
1054    }
1055    # don't recurse down symbolic link
1056    elsif ((-d $file) && (!-l $file))
1057    {
1058      # get the contents of this directory
1059      if (!opendir (INDIR, $file))
1060      {
1061        print STDERR "FileUtils::removeFilesFiltered() could not open directory $file\n";
1062      }
1063      else
1064      {
1065        my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
1066        closedir (INDIR);
1067
1068        # remove all the files in this directory
1069        map {$_="$file/$_";} @filedir;
1070        &removeFilesFiltered(\@filedir,$file_accept_re,$file_reject_re);
1071
1072        if (!defined $file_accept_re && !defined $file_reject_re)
1073        {
1074          # remove this directory
1075          if (!rmdir $file)
1076          {
1077            print STDERR "FileUtils::removeFilesFiltered() couldn't remove directory $file\n";
1078          }
1079        }
1080      }
1081    }
1082    else
1083    {
1084      next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
1085
1086      if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/))
1087      {
1088        # remove this file
1089        &removeFiles($file);
1090      }
1091    }
1092  }
1093}
1094## removeFilesFiltered()
1095
1096## @function removeFilesRecursive()
1097#
1098# The equivalent of "rm -rf" with all the dangers therein
1099#
1100sub removeFilesRecursive
1101{
1102  my (@files) = @_;
1103
1104  # use the more general (but reterospectively written) function
1105  # filtered_rm_r function() with no accept or reject expressions
1106  &removeFilesFiltered(\@files,undef,undef);
1107}
1108## removeFilesRecursive()
1109
1110## @function sanitizePath()
1111#
1112sub sanitizePath
1113{
1114  my ($path) = @_;
1115
1116  # fortunately filename concatenate will perform all the double slash
1117  # removal and end slash removal we need, and in a protocol aware
1118  # fashion
1119  return &filenameConcatenate($path);
1120}
1121## sanitizePath()
1122
1123## @function softLink()
1124#
1125# make soft link to file if supported by OS, otherwise copy file
1126#
1127sub softLink
1128{
1129  my ($src, $dest, $ensure_paths_absolute) = @_;
1130
1131  # remove trailing slashes from source and destination files
1132  $src =~ s/[\\\/]+$//;
1133  $dest =~ s/[\\\/]+$//;
1134
1135  # Ensure file paths are absolute IF requested to do so
1136  # Soft_linking didn't work for relative paths
1137  if(defined $ensure_paths_absolute && $ensure_paths_absolute)
1138  {
1139    # We need to ensure that the src file is the absolute path
1140    # See http://perldoc.perl.org/File/Spec.html
1141    # it's relative
1142    if(!File::Spec->file_name_is_absolute( $src ))
1143    {
1144      $src = File::Spec->rel2abs($src); # make absolute
1145    }
1146    # Might as well ensure that the destination file's absolute path is used
1147    if(!File::Spec->file_name_is_absolute( $dest ))
1148    {
1149      $dest = File::Spec->rel2abs($dest); # make absolute
1150    }
1151  }
1152
1153  # a few sanity checks
1154  if (!-e $src)
1155  {
1156    print STDERR "FileUtils::softLink() source file $src does not exist\n";
1157    return 0;
1158  }
1159
1160  my $dest_dir = &File::Basename::dirname($dest);
1161  if (!-e $dest_dir)
1162  {
1163    &makeAllDirectories($dest_dir);
1164  }
1165
1166  if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin"))
1167  {
1168    # symlink not supported on windows
1169    &File::Copy::copy ($src, $dest);
1170  }
1171  elsif (!eval {symlink($src, $dest)})
1172  {
1173    print STDERR "FileUtils::softLink(): unable to create soft link.\n";
1174    return 0;
1175  }
1176  return 1;
1177}
1178## softLink()
1179
1180## @function synchronizeDirectory()
1181#
1182# updates a copy of a directory in some other part of the filesystem
1183# verbosity settings are: 0=low, 1=normal, 2=high
1184# both $fromdir and $todir should be absolute paths
1185#
1186sub synchronizeDirectory
1187{
1188  my ($fromdir, $todir, $verbosity) = @_;
1189  $verbosity = 1 unless defined $verbosity;
1190
1191  # use / for the directory separator, remove duplicate and
1192  # trailing slashes
1193  $fromdir=~s/[\\\/]+/\//g;
1194  $fromdir=~s/[\\\/]+$//;
1195  $todir=~s/[\\\/]+/\//g;
1196  $todir=~s/[\\\/]+$//;
1197
1198  &makeAllDirectories($todir);
1199
1200  # get the directories in ascending order
1201  if (!opendir (FROMDIR, $fromdir))
1202  {
1203    print STDERR "FileUtils::synchronizeDirectory() could not read directory $fromdir\n";
1204    return;
1205  }
1206  my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
1207  closedir (FROMDIR);
1208
1209  if (!opendir (TODIR, $todir))
1210  {
1211    print STDERR "FileUtils::synchronizeDirectory() could not read directory $todir\n";
1212    return;
1213  }
1214  my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
1215  closedir (TODIR);
1216
1217  my $fromi = 0;
1218  my $toi = 0;
1219
1220  while ($fromi < scalar(@fromdir) || $toi < scalar(@todir))
1221  {
1222    #   print "fromi: $fromi toi: $toi\n";
1223
1224    # see if we should delete a file/directory
1225    # this should happen if the file/directory
1226    # is not in the from list or if its a different
1227    # size, or has an older timestamp
1228    if ($toi < scalar(@todir))
1229    {
1230      if (($fromi >= scalar(@fromdir)) || ($todir[$toi] lt $fromdir[$fromi] || ($todir[$toi] eq $fromdir[$fromi] && &differentFiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]", $verbosity))))
1231      {
1232
1233        # the files are different
1234        &removeFilesRecursive("$todir/$todir[$toi]");
1235        splice(@todir, $toi, 1); # $toi stays the same
1236
1237      }
1238      elsif ($todir[$toi] eq $fromdir[$fromi])
1239      {
1240        # the files are the same
1241        # if it is a directory, check its contents
1242        if (-d "$todir/$todir[$toi]")
1243        {
1244          &synchronizeDirectory("$fromdir/$fromdir[$fromi]", "$todir/$todir[$toi]", $verbosity);
1245        }
1246
1247        $toi++;
1248        $fromi++;
1249        next;
1250      }
1251    }
1252
1253    # see if we should insert a file/directory
1254    # we should insert a file/directory if there
1255    # is no tofiles left or if the tofile does not exist
1256    if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) || $todir[$toi] gt $fromdir[$fromi]))
1257    {
1258      &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
1259      splice (@todir, $toi, 0, $fromdir[$fromi]);
1260
1261      $toi++;
1262      $fromi++;
1263    }
1264  }
1265}
1266## synchronizeDirectory()
1267
12681;
Note: See TracBrowser for help on using the browser.