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

Revision 32090, 33.3 KB (checked in by ak19, 2 years ago)

Related to the previous commit, revision 32089. Some improvements.

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