source: gs2-extensions/parallel-building/trunk/src/perllib/FileUtils.pm@ 30352

Last change on this file since 30352 was 30352, checked in by jmt12, 8 years ago

Adding in a function to test whether a File driver has a certain function. Also adding in support for an optional driver funtion to determine if a certain path is special (and so shouldn't be changed) or not

File size: 24.4 KB
RevLine 
[27384]1###########################################################################
2#
3# FileUtils.pm -- functions for dealing with files. Will delegate to the
4# appropriate filesystem driver based upon any file
5# protocol specified and dependent on configuration as
6# defined by the collection admin
7#
8# A component of the Greenstone digital library software
9# from the New Zealand Digital Library Project at the
10# University of Waikato, New Zealand.
11#
12# Copyright (C) 2013 New Zealand Digital Library Project
13#
14# This program is free software; you can redistribute it and/or modify
15# it under the terms of the GNU General Public License as published by
16# the Free Software Foundation; either version 2 of the License, or
17# (at your option) any later version.
18#
19# This program is distributed in the hope that it will be useful,
20# but WITHOUT ANY WARRANTY; without even the implied warranty of
21# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22# GNU General Public License for more details.
23#
24# You should have received a copy of the GNU General Public License
25# along with this program; if not, write to the Free Software
26# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
27#
28###########################################################################
29
30package FileUtils;
31
32# Perl Modules
33use strict;
34use Symbol qw<qualify>;
35
36# Greenstone Modules
37use util;
38
39# Configuration
40my $debug = 0;
[30287]41my $linking_disabled = 0;
[27384]42
[27531]43# Globals
44my $done_link_warning = 0;
45
[27421]46## @function _callFunction($driver_name, $function_name, ...)
47#
48# Make a function call to a dynamically loaded database driver.
49# @param $driver_name - The name of the file protocol driver to load
50# @param $function_name - The function within the driver to call
51# @param <rest> - The parameters to be passed to the function called
52#
[27384]53sub _callFunction
54{
55 my $driver_name = shift(@_);
56 my $function_name = shift(@_);
57 &_prettyPrint(0, $driver_name, $function_name, @_) unless (!$debug);
58 # Need to look within fileutils directory
59 my $package_name = 'FileUtils::' . $driver_name;
60 # Try to load the requested infodb type
61 if (!&_loadDriver($package_name))
62 {
63 &printError('Failed to load requested file protocol driver: ' . $package_name, 1);
64 }
65 # Then make call to the newly created package
66 no strict;
67 # Better check that the function we are about to call exists
68 my $symbol = qualify($function_name, $package_name);
69 unless ( defined &{$symbol} )
70 {
71 &printError('Function not found: ' . $package_name . '::' . $function_name, 1);
72 }
73 # Call the function and get result if applicable
74 my $result = &{$symbol}(@_);
75 &_prettyPrint(1, $result) unless (!$debug);
76 return $result;
77}
[27421]78## callFunction()
[27384]79
[30352]80
81## @function _hasFunction()
82#
83sub _hasFunction
84{
85 my $driver_name = shift(@_);
86 my $function_name = shift(@_);
87 # Need to look within fileutils directory
88 my $package_name = 'FileUtils::' . $driver_name;
89 # Try to load the requested infodb type
90 if (!&_loadDriver($package_name))
91 {
92 &printError('Failed to load requested file protocol driver: ' . $package_name, 1);
93 }
94 # Then make call to the newly created package
95 no strict;
96 # Check if the function call exists
97 my $symbol = qualify($function_name, $package_name);
98 return defined &{$symbol};
99}
100## _hasFunction()
101
102
[27421]103## @function _prettyPrint()
104#
105# Print a debugging message to STDERR constructed from the <rest> based upon
106# the type.
107# @param type - If 0, output the start of a function with a listing of its
108# parameters. If 1, output the result of a function. 2 is
109# used for function errors. Default to simply printing what-
110# ever else is in <rest>
111#
[27384]112sub _prettyPrint
113{
114 my $type = shift(@_);
115 if (!defined $type || $type > 2)
116 {
117 $type = -1;
118 }
119 my ($package, $filename, $line, $function) = caller(1);
120 my $message;
121 # Start of a function
122 if (0 == $type)
123 {
124 $message = $package . '::' . $function . '(';
125 my $argument = shift(@_);
126 my $first = 1;
127 while (defined $argument)
128 {
129 if (!$first)
130 {
131 $message .= ', ';
132 }
133 else
134 {
135 $first = 0;
136 }
137 if ($argument =~ /\D/)
138 {
139 $message .= '"' . $argument . '"';
140 }
141 else
142 {
143 $message .= $argument;
144 }
145 $argument = shift(@_);
146 }
147 $message .= ')';
148 }
149 # Result of a function
150 elsif (1 == $type)
151 {
152 $message = $package . '::' . $function . '() => ';
153 my $result = shift(@_);
154 if ($result =~ /\D/)
155 {
156 $message .= '"' . $result . '"';
157 }
158 else
159 {
160 $message .= $result;
161 }
162 }
163 elsif (2 == $type)
164 {
165 my $error = shift(@_);
166 $message = 'Error in ' . $package . '::' . $function . '()! ' . $error;
167 }
168 # Else we leave the message as it is
169 else
170 {
171 $message = join("\n", @_);
172 }
173 print STDERR "[" . time() . "] " . $message . "\n";
174}
[27421]175## _prettyPrint()
[27384]176
177# /** @function _determineDriver()
178# * Given a file path determine the appropriate protocol. For now anything
179# * other than a full path beginning with an explicit protocol will default
180# * to using 'local' file functions.
181# * @return 'local'
182# */
183sub _determineDriver
184{
185 my $path = shift(@_);
186 &_prettyPrint(0, $path) unless (!$debug);
187 # Determine the appropriate driver from the protocol
188 my $driver = 'LocalFS';
189 # - this is were I'll eventually have the ability to configure
190 # what driver handles what protocol, hopefully from the collect.cfg
191 my $colon_index = index($path, ':');
192 if ($colon_index > -1)
193 {
194 my $protocol = substr($path, 0, $colon_index);
195 # check the perl module exists
[28653]196 eval 'require "FileUtils/' . $protocol . '.pm"';
197 #eval
198 #{
199 # require 'FileUtils/' . $protocol . '.pm';
200 #};
[27384]201 if ($@)
202 {
203 print STDERR 'Warning! FileUtils::_determineDriver() driver not found (defaulting to local filesystem):' . $protocol . "\n" . $@ . "\n";
204 }
205 else
206 {
207 $driver = $protocol;
208 }
209 }
210 &_prettyPrint(1, $driver) unless (!$debug);
211 return $driver;
212}
213# /** _determineDriver()
214
215# /** @function _loadDriver($class, ...)
216# * Runtime class loading for use in FileUtils to load various protocol
217# * drivers, possibly configured in the collect.cfg, at runtime.
218# * @param $class - The class name (including any path) to load
219# * @param <rest> - any function aliases you want exported
220# */
221sub _loadDriver
222{
223 my $class = shift(@_);
224 &_prettyPrint(0, $class) unless (!$debug);
225 # Convert the Perl Module-like name into a file path
226 (my $file = "$class.pm") =~ s|::|/|g;
227 # - ensure we haven't already loaded this class
228 unless( $INC{$file} )
229 {
230 require $file;
231 }
232 # - this is the magic that actually instantiates the class (rubberstamp?)
233 # - we pass @_ to action any function aliases exports requested
234 eval
235 {
236 $class->import(@_);
237 };
238 # - by now the driver file should have been loaded
239 my $result = defined $INC{$file};
240 &_prettyPrint(1, $result) unless (!$debug);
241 return $result;
242}
243# /** _loadDriver($class, ...) **/
244
245################################################################################
246
247
248## @function printError()
249#
250sub printError
251{
252 my ($message, $fatal) = @_;
253 my ($package, $filename, $line, $function) = caller(1);
254 if (defined $!)
255 {
256 $message .= ' (' . $! . ')';
257 }
258 if (defined $fatal && $fatal)
259 {
260 die('Fatal Error! ' . $package . '::' . $function . '() - ' . $message ."\n");
261 }
262 else
263 {
264 print STDERR 'Error! ' . $package . '::' . $function . '() - ' . $message ."\n";
265 }
266}
267## printError()
268
269
270## @function printWarning
271#
272sub printWarning
273{
274 my ($message) = @_;
275 my ($package, $filename, $line, $function) = caller(1);
276 print STDERR 'Warning! ' . $package . '::' . $function . '() - ' . $message . "\n";
277}
278## printWarning()
279
280################################################################################
281######################## Legacy function name mappings ########################
282################################################################################
283# Note: there are lots of functions involving files/directories/paths etc found
284# in utils.pm that are not represented here. My intention was to just have those
285# functions that need to be dynamic based on filesystem, or need some rejigging
286# to be filesystem aware. This is an argument, I guess, for moving some of the
287# other functions here so that they are nicely encapsulated - but the question
288# is what to do with functions like filename_within_directory_url_format() which
289# is more URL based than file based... dunno.
290################################################################################
291
292sub cachedir {return synchronizeDirectory(@_);}
293sub cp {return copyFiles(@_);}
294sub cp_r {print "implement cp_r()";}
295sub cp_r_nosvn {print "implement cp_r_nosvn()";}
296sub cp_r_toplevel {print "implement cp_r_toplevel()";}
297sub differentfiles {return &differentFiles(@_);}
298sub dir_exists {return &directoryExists(@_);}
299sub file_exists {return &fileExists(@_);}
300sub file_lastmodified {return &modificationTime(@_);}
301sub file_readdir {return readDirectory(@_);}
302sub file_size {return &fileSize(@_);}
303sub filename_cat {return filenameConcatenate(@_);}
304sub filename_is_absolute {return &isFilenameAbsolute();};
305sub filtered_rm_r {print "implement filtered_rm_r()";}
306sub hard_link {print "implement hard_link()";}
307sub is_dir_empty {return &isDirectoryEmpty();}
308sub mk_all_dir {return &makeAllDirectories(@_);}
309sub mk_dir {return &makeDirectory(@_);}
310sub mv {return &moveFiles(@_);}
311sub mv_dir_contents {print "implement mv_dir_contents()";}
312sub rm {print "implement rm()";}
313sub rm_debug {print "implement rm_debug()";}
314sub rm_r {print "implement rm_r()";}
315sub soft_link {print "implement soft_link()";}
316
317################################################################################
318########## Common functions ##########
319################################################################################
320# Note: these are the file-based functions that are not dynamic in themselves,
321# but that need significant changes to support multiple possible filesystems.
322################################################################################
323
324
325## @function differentFiles
326# (previous util.pm version used -e, -d, and 'stat', none of which support
327# * filesystems such as hadoop)
328# */
329sub differentFiles
330{
331 my ($file1, $file2, $verbosity) = @_;
332 if (!defined $verbosity)
333 {
334 $verbosity = 1
335 }
336
337 # remove trailing slashes
338 $file1 =~ s/\/+$//;
339 $file2 =~ s/\/+$//;
340
341 # chop off the last part of the path as the file/dir name
342 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
343 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
344
345 # - cheapest first; test the two filename strings are the same
346 if ($file1name ne $file2name)
347 {
348 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
349 return 1;
350 }
351
352 if (!&pathExists($file1) || !&pathExists($file2))
353 {
354 print STDERR "one or other file doesn't exist\n" if ($verbosity >= 2);
355 return -1;
356 }
357
358 if (&directoryExists($file1))
359 {
360 if (!&directoryExists($file2))
361 {
362 print STDERR "one file is a directory\n" if ($verbosity >= 2);
363 return 1;
364 }
365 return 0;
366 }
367
368 # both must be regular files
369 unless (&fileExists($file1) && &fileExists($file2))
370 {
371 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
372 return 1;
373 }
374
375 # the size of the files must be the same
376 if (&fileSize($file1) != &fileSize($file2))
377 {
378 print STDERR "different sized files\n" if ($verbosity >= 2);
379 return 1;
380 }
381
382 # the second file cannot be older than the first
383 if (&modificationTime($file1) > &modificationTime($file2))
384 {
385 print STDERR "file is older\n" if ($verbosity >= 2);
386 return 1;
387 }
388
389 return 0;
390}
391# /** differentFiles() **/
392
393
394## @function fileGetContents()
395#
396sub fileGetContents
397{
398 my ($path) = @_;
399 my $content;
400 my $driver = &FileUtils::_determineDriver($path);
401 my $filesize = &FileUtils::_callFunction($driver, 'fileSize', $path);
402 my $fh;
403 &FileUtils::_callFunction($driver, 'openFileHandle', $path, '<', \$fh);
404 sysread($fh, $content, $filesize);
405 &FileUtils::_callFunction($driver, 'closeFileHandle', \$fh);
406 return $content;
407}
408## fileGetContents()
409
410
411## @function filePutContents()
412#
413sub filePutContents
414{
[27421]415 my $path = shift(@_);
416 my $str = shift(@_);
[27384]417 my $driver = &FileUtils::_determineDriver($path);
418 my $fh;
419 &FileUtils::_callFunction($driver, 'openFileHandle', $path, '>', \$fh);
420 print $fh $str;
421 &FileUtils::_callFunction($driver, 'closeFileHandle', \$fh);
422 return 1;
423}
424## filePutContents(path, str)
425
426
[27481]427## @function makeAllDirectories()
428#
429# in case anyone cares - I did some testing (using perls Benchmark module)
430# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
431# slightly faster (surprisingly) - Stefan.
432#
433sub makeAllDirectories
434{
435 my ($raw_dir) = @_;
436 # use / for the directory separator, remove duplicate and
437 # trailing slashes
[27491]438 $raw_dir = &sanitizePath($raw_dir);
[27481]439 # ensure the directory doesn't already exist
440 if (&directoryExists($raw_dir))
441 {
442 return 0;
443 }
[27491]444 if ($raw_dir =~ /^(.+?:\/\/)?(.*)/)
[27481]445 {
446 my $dirsofar = '';
447 if (defined $1)
448 {
449 $dirsofar = $1;
450 }
451 my $dir = $2;
452 my $first = 1;
453 foreach my $dirname (split ("/", $dir))
454 {
455 $dirsofar .= "/" unless $first;
456 $first = 0;
457 $dirsofar .= $dirname;
[30352]458 next if $dirname =~ /^(|[a-z]+:)$/i;
459 # we can't create some directories (drivers specific)
460 if (&isSpecialDirectory($dirsofar)) {
461 next;
462 }
[27491]463 if (!&directoryExists($dirsofar))
[27481]464 {
465 my $mkdir_ok = &makeDirectory($dirsofar);
466 if (!$mkdir_ok)
467 {
468 &FileUtils::printError('Could not create directory: ' . $dirsofar);
469 return 0;
470 }
471 }
472 }
473 }
474 return (&directoryExists($raw_dir));
475}
476## makeAllDirectories()
477
478
[27384]479## @function sanitizePath()
480#
481sub sanitizePath
482{
483 my ($path) = @_;
484 # fortunately filename concatenate will perform all the double slash removal,
485 # end slash removal we need, and in a protocol aware fashion
486 return &filenameConcatenate($path);
487}
488## sanitizePath()
489
490
491################################################################################
492
493
494## @function canRead()
495#
496sub canRead
497{
[27421]498 my $path = shift(@_);
[27384]499 my $driver = &FileUtils::_determineDriver($path);
[27421]500 return &FileUtils::_callFunction($driver, 'canRead', $path, @_);
[27384]501}
502## canRead()
503
504
505## @function closeFileHandle()
506#
507sub closeFileHandle
508{
509 my $path = shift(@_);
510 my $driver = &FileUtils::_determineDriver($path);
511 return &FileUtils::_callFunction($driver, 'closeFileHandle', @_);
512}
513## closeFileHandle()
514
515# /**
516# */
517sub copyFiles
518{
519 return &transferFiles(@_, 'COPY');
520}
521# /** copyFiles() **/
522
523# /**
524# */
525sub directoryExists
526{
527 my $path = shift(@_);
528 my $driver = &FileUtils::_determineDriver($path);
529 return &FileUtils::_callFunction($driver, 'fileTest', $path, '-d');
530}
531# /** directoryExists($path) **/
532
533# /** @function file_exists($path)
534# * Determine if the given file path exists on the target filesystem
535# * @param path - the path to the file to test
536# * @return true if the file exists, false otherwise
537sub fileExists
538{
539 my $path = shift(@_);
540 my $driver = &FileUtils::_determineDriver($path);
541 my $result = &FileUtils::_callFunction($driver, 'fileTest', $path, '-f');
542 return $result;
543}
544# /** fileExists(path) **/
545
546# /** @function filenameConcatenate(<rest>)
547# */
548sub filenameConcatenate
549{
550 my $first_path_part = shift(@_);
551 my $path = '';
552 if (defined $first_path_part)
553 {
554 my $driver = &FileUtils::_determineDriver($first_path_part);
555 $path = &FileUtils::_callFunction($driver, 'filenameConcatenate', $first_path_part, @_);
556 }
557 return $path;
558}
559# /** filenameConcatenate(<rest>) **/
560
561# /**
562# */
563sub fileSize
564{
565 my $path = shift(@_);
566 my $driver = &_determineDriver($path);
567 return &_callFunction($driver, 'fileSize', $path);
568}
569# /** fileSize() **/
570
[27421]571## @function hardLink()
572#
[27384]573sub hardLink
574{
575 my $src_file = shift(@_);
576 my $dst_file = shift(@_);
577 my $src_driver = &FileUtils::_determineDriver($src_file);
578 my $dst_driver = &FileUtils::_determineDriver($dst_file);
579 # you can only symbolic link within the same file system - always
[29243]580 if ($src_driver eq 'LocalFS' && $src_driver eq $dst_driver && !$linking_disabled)
[27384]581 {
582 &FileUtils::_callFunction($src_driver, 'linkFile', 'HARD', $src_file, $dst_file);
583 }
584 # substitute a copy
585 else
586 {
[30287]587 if (!$done_link_warning)
588 {
589 if ($src_driver ne 'LocalFS' || $dst_driver ne 'LocalFS')
590 {
591 &printWarning('Cannot symbolic hardlink between non-local file systems - copying all files instead');
592 }
593 else
594 {
595 &printWarning('Symbolic hardlinking disabled - copying all files instead');
596 }
597 $done_link_warning = 1;
598 }
599 &transferFiles($src_file, $dst_file, 'COPY');
[27384]600 }
601}
[27421]602## hardLink()
[27384]603
[27421]604
[27384]605## @function isFilenameAbolsute()
606#
607# Determine if the given path is an absolute path (as compared to relative)
608#
609sub isFilenameAbsolute
610{
611 my $path = shift(@_);
612 my $driver = &FileUtils::_determineDriver($path);
613 return &FileUtils::_callFunction($driver, 'isFilenameAbsolute', $path, '-l');
614}
615## isFilenameAbsolute()
616
[27421]617
[27526]618## @function isHDFS()
619#
620sub isHDFS
621{
622 my $path = shift(@_);
623 my $driver = &FileUtils::_determineDriver($path);
[27531]624 my $result = &FileUtils::_callFunction($driver, 'isHDFS');
625 ###rint STDERR "[DEBUG] FileUtils::isHDFS(" . $path . ") => " . $result . "\n";
626 return $result;
[27526]627}
628## isHDFS()
629
[30352]630
631## @function isSpecialDirectory()
632#
633sub isSpecialDirectory
634{
635 my $path = shift(@_);
636 my $driver = &FileUtils::_determineDriver($path);
637 my $result = 0; # not special
638 if (&FileUtils::_hasFunction($driver, 'isSpecialDirectory'))
639 {
640 $result = &FileUtils::_callFunction($driver, 'isSpecialDirectory', $path);
641 }
642 return $result;
643}
644## isSpecialDirectory()
645
646
[27384]647## @function isSymbolicLink()
648#
649# Determine if the given path is a symbolic link
650#
651sub isSymbolicLink
652{
653 my $path = shift(@_);
654 my $driver = &FileUtils::_determineDriver($path);
655 return &FileUtils::_callFunction($driver, 'fileTest', $path, '-l');
656}
657## isSymbolicLink()
658
659
660# /**
661# */
662sub makeDirectory
663{
664 my $path = shift(@_);
665 my $driver = &FileUtils::_determineDriver($path);
666 # check if the directory already exists - in which case our job is done :)
667 my $result = &FileUtils::_callFunction($driver, 'fileTest', $path, '-d');
668 # not yet - better try and create it then
669 if (!$result)
670 {
671 $result = &FileUtils::_callFunction($driver, 'makeDirectory', $path);
672 }
673 return $result;
674}
675# /** makeDirectory(path) **/
676
677# /**
678# */
679sub modificationTime
680{
681 my $path = shift(@_);
682 my $driver = &_determineDriver($path);
683 return &_callFunction($driver, 'modificationTime', $path);
684}
685# /** modificationTime() **/
686
687# /**
688# */
689sub moveFiles
690{
691 return &transferFiles(@_, 'MOVE');
692}
693# /** moveFiles() **/
694
695# /**
696# */
697sub openFileHandle
698{
699 my $path = shift(@_);
700 # I'll set mode to read by default, as that is less destructive to precious
701 # files on your system...
702 my $mode = shift(@_) || '<';
703 # the all important determining of the driver by protocol
704 my $driver = &FileUtils::_determineDriver($path);
705 # the function call will return true on success, with the reference to the
706 # file handle hopefully populated with a lovely file descriptor
707 return &FileUtils::_callFunction($driver, 'openFileHandle', $path, $mode, @_);
708}
709# /** openFileHandle($file_handle_ref, $path, $mode) **/
710
711## @function pathExists()
712#
713# Determine if a certain path exists on the file system - regardless of whether
714# it is a file or a directory (the equivalent of -e)
715#
716sub pathExists
717{
718 my $path = shift(@_);
719 my $driver = &FileUtils::_determineDriver($path);
720 return &FileUtils::_callFunction($driver, 'fileTest', $path, '-e');
721}
722## pathExists()
723
724
725## @function readDirectory()
726#
727# Provide a function to return the files within a directory that is aware
728# of protocols other than file://
729# @param $dirname the full path to the directory
730#
731sub readDirectory
732{
733 my $path = shift(@_);
734 my $driver = &FileUtils::_determineDriver($path);
735 return &FileUtils::_callFunction($driver, 'readDirectory', $path);
736}
737## readDirectory()
738
739
740## @function removeFiles()
741#
742# Removes files (but not directories)
743# @param files - An array of filepaths to remove
744#
745sub removeFiles
746{
747 my (@files) = @_;
748 my $num_removed = 0;
749 # Remove the files
750 foreach my $path (@files)
751 {
752 my $driver = &FileUtils::_determineDriver($path);
753 if (&FileUtils::_callFunction($driver, 'removeFiles', $path))
754 {
755 $num_removed++;
756 }
757 }
758 # Check to make sure all of them were removed
759 if ($num_removed != scalar(@files))
760 {
761 &printError('Not all files were removed');
762 $num_removed = 0;
763 }
764 return $num_removed;
765}
766## removeFile(files)
767
768
769## @function removeFilesFiltered()
770#
771sub removeFilesFiltered
772{
773 my $maybe_paths = shift(@_);
774 my @paths = (ref $maybe_paths eq "ARRAY") ? @$maybe_paths : ($maybe_paths);
775 my $num_removed = 0;
776 foreach my $path (@paths)
777 {
778 my $driver = &FileUtils::_determineDriver($path);
779 $num_removed += &FileUtils::_callFunction($driver, 'removeFilesFiltered', $path, @_);
780 }
781 return $num_removed;
782}
783## removeFilesFiltered()
784
785
786## @function removeFilesRecursive()
787#
788# The equivalent of "rm -rf" with all the dangers therein
789#
790sub removeFilesRecursive
791{
792 my $maybe_paths = shift(@_);
793 my @paths = (ref $maybe_paths eq "ARRAY") ? @$maybe_paths : ($maybe_paths);
794 my $num_removed = 0;
795 foreach my $path (@paths)
796 {
797 my $driver = &FileUtils::_determineDriver($path);
798 $num_removed += &FileUtils::_callFunction($driver, 'removeFilesRecursive', $path);
799 }
800 return $num_removed;
801}
802## removeFilesRecursive()
803
804
805## @function softLink()
806#
807sub softLink
808{
809 my $src_file = shift(@_);
810 my $dst_file = shift(@_);
811 my $src_driver = &FileUtils::_determineDriver($src_file);
812 my $dst_driver = &FileUtils::_determineDriver($dst_file);
813 # you can only symbolic link within the same file system - always
[29243]814 if ($src_driver eq 'LocalFS' && $src_driver eq $dst_driver && !$linking_disabled)
[27384]815 {
816 &FileUtils::_callFunction($src_driver, 'linkFile', 'SOFT', $src_file, $dst_file, @_);
817 }
818 # substitute a copy
819 elsif ($src_driver ne 'LocalFS')
820 {
[27531]821 if (!$done_link_warning)
822 {
823 &printWarning('Cannot symbolic link on non-local file systems - copying all files instead');
824 $done_link_warning = 1;
825 }
[27384]826 &transferFiles($src_file, $dst_file, 'COPY');
827 }
828 else
829 {
[27531]830 if (!$done_link_warning)
831 {
832 &printWarning('Cannot symbolic link between file systems - copying all files instead');
833 $done_link_warning = 1;
834 }
[27384]835 &transferFiles($src_file, $dst_file, 'COPY');
836 }
837}
838## softLink()
839
840
841## @function supportsSymbolicLink()
842#
843sub supportsSymbolicLink
844{
845 my $path = shift(@_);
846 my $driver = &FileUtils::_determineDriver($path);
847 &FileUtils::_callFunction($driver, 'supportsSymbolicLink');
848}
849## supportsSymbolicLink()
850
851
852## @function synchronizeDirectory()
853#
854sub synchronizeDirectory
855{
856 my $fromdir = shift(@_);
857 my $driver = &FileUtils::_determineDriver($fromdir);
858 &FileUtils::_callFunction($driver, 'synchronizeDirectory', $fromdir, @_);
859}
860## synchronizeDirectory()
861
862
863## @function transferFiles()
864# @param paths - one or more source paths
865# @param dst_path - the destination path
866# @param mode - copy or move
867#
868sub transferFiles
869{
870 my $transfer_mode = pop(@_);
871 my $dst_path = pop(@_);
872 my (@src_paths) = @_;
873 &_prettyPrint(0, @src_paths, $dst_path, $transfer_mode) unless (!$debug);
874 my $result = 0;
875 my $dst_driver = &_determineDriver($dst_path);
876 if (scalar (@src_paths) == 0)
877 {
878 &printError('No destination directory given');
879 }
880 elsif ((scalar (@src_paths) > 1) && (!&directoryExists($dst_path)))
881 {
882 &printError('If multiple source files are given the destination must be a directory');
883 }
884 else
885 {
886 foreach my $src_path (@src_paths)
887 {
888 my $src_driver = &_determineDriver($src_path);
889 if ($src_driver eq 'LocalFS')
890 {
891 # Local to local
892 if ($dst_driver eq 'LocalFS')
893 {
894 $result += &_callFunction($src_driver, 'transferFile', $transfer_mode, $src_path, $dst_path);
895 }
896 # Local to X
897 else
898 {
899 $result += &_callFunction($dst_driver, 'transferFileFromLocal', $transfer_mode, $src_path, $dst_path);
900 }
901 }
902 # X to Local
903 elsif ($dst_driver eq 'LocalFS')
904 {
905 $result += &_callFunction($src_driver, 'transferFileToLocal', $transfer_mode, $src_path, $dst_path);
906 }
907 # X to X
908 elsif ($src_driver eq $dst_driver)
909 {
910 $result += &_callFunction($src_driver, 'transferFile', $transfer_mode, $src_path, $dst_path);
911 }
912 # X to Y... not supported
913 else
914 {
915 &printError('transfer between two non-local file systems not supported');
916 }
917 }
918 $result = (scalar(@src_paths) == $result);
919 }
920 return $result;
921}
922## transferFiles()
923
9241;
Note: See TracBrowser for help on using the repository browser.