source: gsdl/trunk/perllib/util.pm@ 18463

Last change on this file since 18463 was 18463, checked in by davidb, 15 years ago

Warning about file copying in event that a hard link operation is not supported altered to only appear if verbosity > 2
  • Property svn:keywords set to Author Date Id Revision
File size: 27.5 KB
Line 
1###########################################################################
2#
3# util.pm -- various useful utilities
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26package util;
27
28use File::Copy;
29use File::Basename;
30
31use strict;
32
33
34# removes files (but not directories)
35sub rm {
36 my (@files) = @_;
37 my @filefiles = ();
38
39 # make sure the files we want to delete exist
40 # and are regular files
41 foreach my $file (@files) {
42 if (!-e $file) {
43 print STDERR "util::rm $file does not exist\n";
44 } elsif ((!-f $file) && (!-l $file)) {
45 print STDERR "util::rm $file is not a regular (or symbolic) file\n";
46 } else {
47 push (@filefiles, $file);
48 }
49 }
50
51 # remove the files
52 my $numremoved = unlink @filefiles;
53
54 # check to make sure all of them were removed
55 if ($numremoved != scalar(@filefiles)) {
56 print STDERR "util::rm Not all files were removed\n";
57 }
58}
59
60
61
62# recursive removal
63sub filtered_rm_r {
64 my ($files,$file_accept_re,$file_reject_re) = @_;
65
66 my @files_array = (ref $files eq "ARRAY") ? @$files : ($files);
67
68 # recursively remove the files
69 foreach my $file (@files_array) {
70 $file =~ s/[\/\\]+$//; # remove trailing slashes
71
72 if (!-e $file) {
73 print STDERR "util::filtered_rm_r $file does not exist\n";
74
75 } elsif ((-d $file) && (!-l $file)) { # don't recurse down symbolic link
76 # get the contents of this directory
77 if (!opendir (INDIR, $file)) {
78 print STDERR "util::filtered_rm_r could not open directory $file\n";
79 } else {
80 my @filedir = grep (!/^\.\.?$/, readdir (INDIR));
81 closedir (INDIR);
82
83 # remove all the files in this directory
84 map {$_="$file/$_";} @filedir;
85 &filtered_rm_r (\@filedir,$file_accept_re,$file_reject_re);
86
87 if (!defined $file_accept_re && !defined $file_reject_re) {
88 # remove this directory
89 if (!rmdir $file) {
90 print STDERR "util::filtered_rm_r couldn't remove directory $file\n";
91 }
92 }
93 }
94 } else {
95 next if (defined $file_reject_re && ($file =~ m/$file_reject_re/));
96
97 if ((!defined $file_accept_re) || ($file =~ m/$file_accept_re/)) {
98 # remove this file
99 &rm ($file);
100 }
101 }
102 }
103}
104
105
106# recursive removal
107sub rm_r {
108 my (@files) = @_;
109
110 # use the more general (but reterospectively written function
111 # filtered_rm_r function()
112
113 filtered_rm_r(\@files,undef,undef); # no accept or reject expressions
114}
115
116
117
118
119# moves a file or a group of files
120sub mv {
121 my $dest = pop (@_);
122 my (@srcfiles) = @_;
123
124 # remove trailing slashes from source and destination files
125 $dest =~ s/[\\\/]+$//;
126 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
127
128 # a few sanity checks
129 if (scalar (@srcfiles) == 0) {
130 print STDERR "util::mv no destination directory given\n";
131 return;
132 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) {
133 print STDERR "util::mv if multiple source files are given the ".
134 "destination must be a directory\n";
135 return;
136 }
137
138 # move the files
139 foreach my $file (@srcfiles) {
140 my $tempdest = $dest;
141 if (-d $tempdest) {
142 my ($filename) = $file =~ /([^\\\/]+)$/;
143 $tempdest .= "/$filename";
144 }
145 if (!-e $file) {
146 print STDERR "util::mv $file does not exist\n";
147 } else {
148 rename ($file, $tempdest);
149 }
150 }
151}
152
153
154# copies a file or a group of files
155sub cp {
156 my $dest = pop (@_);
157 my (@srcfiles) = @_;
158
159 # remove trailing slashes from source and destination files
160 $dest =~ s/[\\\/]+$//;
161 map {$_ =~ s/[\\\/]+$//;} @srcfiles;
162
163 # a few sanity checks
164 if (scalar (@srcfiles) == 0) {
165 print STDERR "util::cp no destination directory given\n";
166 return;
167 } elsif ((scalar (@srcfiles) > 1) && (!-d $dest)) {
168 print STDERR "util::cp if multiple source files are given the ".
169 "destination must be a directory\n";
170 return;
171 }
172
173 # copy the files
174 foreach my $file (@srcfiles) {
175 my $tempdest = $dest;
176 if (-d $tempdest) {
177 my ($filename) = $file =~ /([^\\\/]+)$/;
178 $tempdest .= "/$filename";
179 }
180 if (!-e $file) {
181 print STDERR "util::cp $file does not exist\n";
182 } elsif (!-f $file) {
183 print STDERR "util::cp $file is not a plain file\n";
184 } else {
185 &File::Copy::copy ($file, $tempdest);
186 }
187 }
188}
189
190
191
192# recursively copies a file or group of files
193# syntax: cp_r (sourcefiles, destination directory)
194# destination must be a directory - to copy one file to
195# another use cp instead
196sub cp_r {
197 my $dest = pop (@_);
198 my (@srcfiles) = @_;
199
200 # a few sanity checks
201 if (scalar (@srcfiles) == 0) {
202 print STDERR "util::cp_r no destination directory given\n";
203 return;
204 } elsif (-f $dest) {
205 print STDERR "util::cp_r destination must be a directory\n";
206 return;
207 }
208
209 # create destination directory if it doesn't exist already
210 if (! -d $dest) {
211 my $store_umask = umask(0002);
212 mkdir ($dest, 0777);
213 umask($store_umask);
214 }
215
216 # copy the files
217 foreach my $file (@srcfiles) {
218
219 if (!-e $file) {
220 print STDERR "util::cp_r $file does not exist\n";
221
222 } elsif (-d $file) {
223 # make the new directory
224 my ($filename) = $file =~ /([^\\\/]*)$/;
225 $dest = &util::filename_cat ($dest, $filename);
226 my $store_umask = umask(0002);
227 mkdir ($dest, 0777);
228 umask($store_umask);
229
230 # get the contents of this directory
231 if (!opendir (INDIR, $file)) {
232 print STDERR "util::cp_r could not open directory $file\n";
233 } else {
234 my @filedir = readdir (INDIR);
235 closedir (INDIR);
236 foreach my $f (@filedir) {
237 next if $f =~ /^\.\.?$/;
238 # copy all the files in this directory
239 my $ff = &util::filename_cat ($file, $f);
240 &cp_r ($ff, $dest);
241 }
242 }
243
244 } else {
245 &cp($file, $dest);
246 }
247 }
248}
249
250# copies a directory and its contents, excluding subdirectories, into a new directory
251sub cp_r_toplevel {
252 my $dest = pop (@_);
253 my (@srcfiles) = @_;
254
255 # a few sanity checks
256 if (scalar (@srcfiles) == 0) {
257 print STDERR "util::cp_r no destination directory given\n";
258 return;
259 } elsif (-f $dest) {
260 print STDERR "util::cp_r destination must be a directory\n";
261 return;
262 }
263
264 # create destination directory if it doesn't exist already
265 if (! -d $dest) {
266 my $store_umask = umask(0002);
267 mkdir ($dest, 0777);
268 umask($store_umask);
269 }
270
271 # copy the files
272 foreach my $file (@srcfiles) {
273
274 if (!-e $file) {
275 print STDERR "util::cp_r $file does not exist\n";
276
277 } elsif (-d $file) {
278 # make the new directory
279 my ($filename) = $file =~ /([^\\\/]*)$/;
280 $dest = &util::filename_cat ($dest, $filename);
281 my $store_umask = umask(0002);
282 mkdir ($dest, 0777);
283 umask($store_umask);
284
285 # get the contents of this directory
286 if (!opendir (INDIR, $file)) {
287 print STDERR "util::cp_r could not open directory $file\n";
288 } else {
289 my @filedir = readdir (INDIR);
290 closedir (INDIR);
291 foreach my $f (@filedir) {
292 next if $f =~ /^\.\.?$/;
293
294 # copy all the files in this directory, but not directories
295 my $ff = &util::filename_cat ($file, $f);
296 if (-f $ff) {
297 &cp($ff, $dest);
298 #&cp_r ($ff, $dest);
299 }
300 }
301 }
302
303 } else {
304 &cp($file, $dest);
305 }
306 }
307}
308
309sub mk_dir {
310 my ($dir) = @_;
311
312 my $store_umask = umask(0002);
313 my $mkdir_ok = mkdir ($dir, 0777);
314 umask($store_umask);
315
316 if (!$mkdir_ok)
317 {
318 print STDERR "util::mk_dir could not create directory $dir\n";
319 return;
320 }
321}
322
323# in case anyone cares - I did some testing (using perls Benchmark module)
324# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
325# slightly faster (surprisingly) - Stefan.
326sub mk_all_dir {
327 my ($dir) = @_;
328
329 # use / for the directory separator, remove duplicate and
330 # trailing slashes
331 $dir=~s/[\\\/]+/\//g;
332 $dir=~s/[\\\/]+$//;
333
334 # make sure the cache directory exists
335 my $dirsofar = "";
336 my $first = 1;
337 foreach my $dirname (split ("/", $dir)) {
338 $dirsofar .= "/" unless $first;
339 $first = 0;
340
341 $dirsofar .= $dirname;
342
343 next if $dirname =~ /^(|[a-z]:)$/i;
344 if (!-e $dirsofar)
345 {
346 my $store_umask = umask(0002);
347 my $mkdir_ok = mkdir ($dirsofar, 0777);
348 umask($store_umask);
349 if (!$mkdir_ok)
350 {
351 print STDERR "util::mk_all_dir could not create directory $dirsofar\n";
352 return;
353 }
354 }
355 }
356}
357
358# make hard link to file if supported by OS, otherwise copy the file
359sub hard_link {
360 my ($src, $dest, $verbosity) = @_;
361
362 # remove trailing slashes from source and destination files
363 $src =~ s/[\\\/]+$//;
364 $dest =~ s/[\\\/]+$//;
365
366 # a few sanity checks
367 if (-e $dest) {
368 # destination file already exists
369 return;
370 }
371 elsif (!-e $src) {
372 print STDERR "util::hard_link source file $src does not exist\n";
373 return 1;
374 }
375 elsif (-d $src) {
376 print STDERR "util::hard_link source $src is a directory\n";
377 return 1;
378 }
379
380 my $dest_dir = &File::Basename::dirname($dest);
381 mk_all_dir($dest_dir) if (!-e $dest_dir);
382
383 # link not supported on windows 9x
384 if (($ENV{'GSDLOS'} =~ /^windows$/i) && (Win32::FsType() !~ /^ntfs$/i)) {
385 &File::Copy::copy ($src, $dest);
386
387 } elsif (!link($src, $dest)) {
388 if ((!defined $verbosity) || ($verbosity>2)) {
389 print STDERR "util::hard_link: unable to create hard link. ";
390 print STDERR " Copying file: $src -> $dest\n";
391 }
392 &File::Copy::copy ($src, $dest);
393 }
394 return 0;
395}
396
397# make soft link to file if supported by OS, otherwise copy file
398sub soft_link {
399 my ($src, $dest, $ensure_paths_absolute) = @_;
400
401 # remove trailing slashes from source and destination files
402 $src =~ s/[\\\/]+$//;
403 $dest =~ s/[\\\/]+$//;
404
405 # Ensure file paths are absolute IF requested to do so
406 # Soft_linking didn't work for relative paths
407 if(defined $ensure_paths_absolute && $ensure_paths_absolute) {
408 # We need to ensure that the src file is the absolute path
409 # See http://perldoc.perl.org/File/Spec.html
410 if(!File::Spec->file_name_is_absolute( $src )) { # it's relative
411 $src = File::Spec->rel2abs($src); # make absolute
412 }
413 # Might as well ensure that the destination file's absolute path is used
414 if(!File::Spec->file_name_is_absolute( $dest )) {
415 $dest = File::Spec->rel2abs($dest); # make absolute
416 }
417 }
418
419 # a few sanity checks
420 if (!-e $src) {
421 print STDERR "util::soft_link source file $src does not exist\n";
422 return 0;
423 }
424
425 my $dest_dir = &File::Basename::dirname($dest);
426 mk_all_dir($dest_dir) if (!-e $dest_dir);
427
428 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
429 # symlink not supported on windows
430 &File::Copy::copy ($src, $dest);
431
432 } elsif (!eval {symlink($src, $dest)}) {
433 print STDERR "util::soft_link: unable to create soft link.\n";
434 return 0;
435 }
436
437 return 1;
438}
439
440
441
442
443# updates a copy of a directory in some other part of the filesystem
444# verbosity settings are: 0=low, 1=normal, 2=high
445# both $fromdir and $todir should be absolute paths
446sub cachedir {
447 my ($fromdir, $todir, $verbosity) = @_;
448 $verbosity = 1 unless defined $verbosity;
449
450 # use / for the directory separator, remove duplicate and
451 # trailing slashes
452 $fromdir=~s/[\\\/]+/\//g;
453 $fromdir=~s/[\\\/]+$//;
454 $todir=~s/[\\\/]+/\//g;
455 $todir=~s/[\\\/]+$//;
456
457 &mk_all_dir ($todir);
458
459 # get the directories in ascending order
460 if (!opendir (FROMDIR, $fromdir)) {
461 print STDERR "util::cachedir could not read directory $fromdir\n";
462 return;
463 }
464 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
465 closedir (FROMDIR);
466
467 if (!opendir (TODIR, $todir)) {
468 print STDERR "util::cacedir could not read directory $todir\n";
469 return;
470 }
471 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
472 closedir (TODIR);
473
474 my $fromi = 0;
475 my $toi = 0;
476
477 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) {
478# print "fromi: $fromi toi: $toi\n";
479
480 # see if we should delete a file/directory
481 # this should happen if the file/directory
482 # is not in the from list or if its a different
483 # size, or has an older timestamp
484 if ($toi < scalar(@todir)) {
485 if (($fromi >= scalar(@fromdir)) ||
486 ($todir[$toi] lt $fromdir[$fromi] ||
487 ($todir[$toi] eq $fromdir[$fromi] &&
488 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
489 $verbosity)))) {
490
491 # the files are different
492 &rm_r("$todir/$todir[$toi]");
493 splice(@todir, $toi, 1); # $toi stays the same
494
495 } elsif ($todir[$toi] eq $fromdir[$fromi]) {
496 # the files are the same
497 # if it is a directory, check its contents
498 if (-d "$todir/$todir[$toi]") {
499 &cachedir ("$fromdir/$fromdir[$fromi]",
500 "$todir/$todir[$toi]", $verbosity);
501 }
502
503 $toi++;
504 $fromi++;
505 next;
506 }
507 }
508
509 # see if we should insert a file/directory
510 # we should insert a file/directory if there
511 # is no tofiles left or if the tofile does not exist
512 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
513 $todir[$toi] gt $fromdir[$fromi])) {
514 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
515 splice (@todir, $toi, 0, $fromdir[$fromi]);
516
517 $toi++;
518 $fromi++;
519 }
520 }
521}
522
523# this function returns -1 if either file is not found
524# assumes that $file1 and $file2 are absolute file names or
525# in the current directory
526# $file2 is allowed to be newer than $file1
527sub differentfiles {
528 my ($file1, $file2, $verbosity) = @_;
529 $verbosity = 1 unless defined $verbosity;
530
531 $file1 =~ s/\/+$//;
532 $file2 =~ s/\/+$//;
533
534 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
535 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
536
537 return -1 unless (-e $file1 && -e $file2);
538 if ($file1name ne $file2name) {
539 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
540 return 1;
541 }
542
543 my @file1stat = stat ($file1);
544 my @file2stat = stat ($file2);
545
546 if (-d $file1) {
547 if (! -d $file2) {
548 print STDERR "one file is a directory\n" if ($verbosity >= 2);
549 return 1;
550 }
551 return 0;
552 }
553
554 # both must be regular files
555 unless (-f $file1 && -f $file2) {
556 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
557 return 1;
558 }
559
560 # the size of the files must be the same
561 if ($file1stat[7] != $file2stat[7]) {
562 print STDERR "different sized files\n" if ($verbosity >= 2);
563 return 1;
564 }
565
566 # the second file cannot be older than the first
567 if ($file1stat[9] > $file2stat[9]) {
568 print STDERR "file is older\n" if ($verbosity >= 2);
569 return 1;
570 }
571
572 return 0;
573}
574
575
576sub get_tmp_filename
577{
578 my $file_ext = shift(@_) || undef;
579
580 my $opt_dot_file_ext = (defined $file_ext) ? ".$file_ext" : "";
581
582 my $tmpdir = filename_cat($ENV{'GSDLHOME'}, "tmp");
583 &mk_all_dir ($tmpdir) unless -e $tmpdir;
584
585 my $count = 1000;
586 my $rand = int(rand $count);
587 my $full_tmp_filename = &filename_cat($tmpdir, "F$rand$opt_dot_file_ext");
588
589 while (-e $full_tmp_filename) {
590 $rand = int(rand $count);
591 $full_tmp_filename = &filename_cat($tmpdir, "F$rand$opt_dot_file_ext");
592 $count++;
593 }
594
595 return $full_tmp_filename;
596}
597
598sub filename_to_regex {
599 my $filename = shift (@_);
600
601 # need to put single backslash back to double so that regex works
602 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
603 $filename =~ s/\\/\\\\/g;
604 }
605 return $filename;
606}
607
608sub filename_cat {
609 my $first_file = shift(@_);
610 my (@filenames) = @_;
611
612# Useful for debugging
613# -- might make sense to call caller(0) rather than (1)??
614# my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
615# print STDERR "Calling method; $cfilename:$cline $cpackage->$csubr\n";
616
617 # Check for empty first filename
618 if ($first_file =~ /\S/) {
619 unshift(@filenames, $first_file);
620 }
621
622 my $filename = join("/", @filenames);
623
624 # remove duplicate slashes and remove the last slash
625 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
626 $filename =~ s/[\\\/]+/\\/g;
627 } else {
628 $filename =~ s/[\/]+/\//g;
629 # DB: want a filename abc\de.html to remain like this
630 }
631 $filename =~ s/[\\\/]$//;
632
633 return $filename;
634}
635
636
637sub envvar_prepend {
638 my ($var,$val) = @_;
639
640 # do not prepend any value/path that's already in the environment variable
641 if ($ENV{'GSDLOS'} =~ /^windows$/i)
642 {
643 my $escaped_val = $val;
644 $escaped_val =~ s/\\/\\\\/g; # escape any Windows backslashes for upcoming regex
645 if($ENV{$var} !~ m/$escaped_val/) {
646 $ENV{$var} = "$val;".$ENV{$var};
647 }
648 }
649 else {
650 if($ENV{$var} !~ m/$val/) {
651 $ENV{$var} = "$val:".$ENV{$var};
652 }
653 }
654}
655
656sub envvar_append {
657 my ($var,$val) = @_;
658
659 # do not append any value/path that's already in the environment variable
660 if ($ENV{'GSDLOS'} =~ /^windows$/i)
661 {
662 my $escaped_val = $val;
663 $escaped_val =~ s/\\/\\\\/g; # escape any Windows backslashes for upcoming regex
664 if($ENV{$var} !~ m/$escaped_val/) {
665 $ENV{$var} .= ";$val";
666 }
667 }
668 else {
669 if($ENV{$var} !~ m/$val/) {
670 $ENV{$var} .= ":$val";
671 }
672 }
673}
674
675
676# splits a filename into a prefix and a tail extension using the tail_re, or
677# if that fails, splits on the file_extension . (dot)
678sub get_prefix_and_tail_by_regex {
679
680 my ($filename,$tail_re) = @_;
681
682 my ($file_prefix,$file_ext) = ($filename =~ m/^(.*?)($tail_re)$/);
683 if ((!defined $file_prefix) || (!defined $file_ext)) {
684 ($file_prefix,$file_ext) = ($filename =~ m/^(.*)(\..*?)$/);
685 }
686
687 return ($file_prefix,$file_ext);
688}
689
690# get full path and file only path from a base_dir (which may be empty) and
691# file (which may contain directories)
692sub get_full_filenames {
693 my ($base_dir, $file) = @_;
694
695 my $filename_full_path = $file;
696 # add on directory if present
697 $filename_full_path = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\S/;
698
699 my $filename_no_path = $file;
700
701 # remove directory if present
702 $filename_no_path =~ s/^.*[\/\\]//;
703 return ($filename_full_path, $filename_no_path);
704}
705
706# returns the path of a file without the filename -- ie. the directory the file is in
707sub filename_head {
708 my $filename = shift(@_);
709
710 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
711 $filename =~ s/[^\\\\]*$//;
712 }
713 else {
714 $filename =~ s/[^\\\/]*$//;
715 }
716
717 return $filename;
718}
719
720
721# returns 1 if filename1 and filename2 point to the same
722# file or directory
723sub filenames_equal {
724 my ($filename1, $filename2) = @_;
725
726 # use filename_cat to clean up trailing slashes and
727 # multiple slashes
728 $filename1 = filename_cat ($filename1);
729 $filename2 = filename_cat ($filename2);
730
731 # filenames not case sensitive on windows
732 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
733 $filename1 =~ tr/[A-Z]/[a-z]/;
734 $filename2 =~ tr/[A-Z]/[a-z]/;
735 }
736 return 1 if $filename1 eq $filename2;
737 return 0;
738}
739
740sub filename_within_collection
741{
742 my ($filename) = @_;
743
744 my $collect_dir = $ENV{'GSDLCOLLECTDIR'};
745
746 if (defined $collect_dir) {
747 my $dirsep = &util::get_dirsep();
748 if ($collect_dir !~ m/$dirsep$/) {
749 $collect_dir .= $dirsep;
750 }
751
752 $collect_dir =~ s/\\/\\\\/g; # escape DOS style file separator
753
754 # if from within GSDLCOLLECTDIR, then remove directory prefix
755 # so source_filename is realative to it. This is done to aid
756 # portability, i.e. the collection can be moved to somewhere
757 # else on the file system and the archives directory will still
758 # work. This is needed, for example in the applet version of
759 # GLI where GSDLHOME/collect on the server will be different to
760 # the collect directory of the remove user. Of course,
761 # GSDLCOLLECTDIR subsequently needs to be put back on to turn
762 # it back into a full pathname.
763
764 if ($filename =~ /^$collect_dir(.*)$/) {
765 $filename = $1;
766 }
767 }
768
769 return $filename;
770}
771
772sub filename_is_absolute
773{
774 my ($filename) = @_;
775
776 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
777 return ($filename =~ m/^(\w:)?\\/);
778 }
779 else {
780 return ($filename =~ m/^\//);
781 }
782}
783
784
785## @method make_absolute()
786#
787# Ensure the given file path is absolute in respect to the given base path.
788#
789# @param $base_dir A string denoting the base path the given dir must be
790# absolute to.
791# @param $dir The directory to be made absolute as a string. Note that the
792# dir may already be absolute, in which case it will remain
793# unchanged.
794# @return The now absolute form of the directory as a string.
795#
796# @author John Thompson, DL Consulting Ltd.
797# @copy 2006 DL Consulting Ltd.
798#
799#used in buildcol.pl, doesn't work for all cases --kjdon
800sub make_absolute {
801
802 my ($base_dir, $dir) = @_;
803### print STDERR "dir = $dir\n";
804 $dir =~ s/[\\\/]+/\//g;
805 $dir = $base_dir . "/$dir" unless ($dir =~ m|^(\w:)?/|);
806 $dir =~ s|^/tmp_mnt||;
807 1 while($dir =~ s|/[^/]*/\.\./|/|g);
808 $dir =~ s|/[.][.]?/|/|g;
809 $dir =~ tr|/|/|s;
810### print STDERR "dir = $dir\n";
811
812 return $dir;
813}
814## make_absolute() ##
815
816sub get_dirsep {
817
818 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
819 return "\\";
820 } else {
821 return "\/";
822 }
823}
824
825sub get_os_dirsep {
826
827 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
828 return "\\\\";
829 } else {
830 return "\\\/";
831 }
832}
833
834sub get_re_dirsep {
835
836 return "\\\\|\\\/";
837}
838
839
840sub get_dirsep_tail {
841 my ($filename) = @_;
842
843 # returns last part of directory or filename
844 # On unix e.g. a/b.d => b.d
845 # a/b/c => c
846
847 my $dirsep = get_re_dirsep();
848 my @dirs = split (/$dirsep/, $filename);
849 my $tail = pop @dirs;
850
851 # - caused problems under windows
852 #my ($tail) = ($filename =~ m/^(?:.*?$dirsep)?(.*?)$/);
853
854 return $tail;
855}
856
857
858# if this is running on windows we want binaries to end in
859# .exe, otherwise they don't have to end in any extension
860sub get_os_exe {
861 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
862 return "";
863}
864
865
866# test to see whether this is a big or little endian machine
867sub is_little_endian
868{
869 # To determine the name of the operating system, the variable $^O is a cheap alternative to pulling it out of the Config module;
870 # If it is a Macintosh machine (i.e. the Darwin operating system), regardless if it's running on the IBM power-pc cpu or the x86 Intel-based chip with a power-pc emulator running on top of it, it's big-endian
871 # Otherwise, it's little endian
872
873 #return 0 if $^O =~ /^darwin$/i;
874 #return 0 if $ENV{'GSDLOS'} =~ /^darwin$/i;
875
876 # Going back to stating exactly whether the machine is little endian
877 # or big endian, without any special case for Macs. Since for rata it comes
878 # back with little endian and for shuttle with bigendian.
879 return (ord(substr(pack("s",1), 0, 1)) == 1);
880}
881
882
883# will return the collection name if successful, "" otherwise
884sub use_collection {
885 my ($collection, $collectdir) = @_;
886
887 if (!defined $collectdir || $collectdir eq "") {
888 $collectdir = &filename_cat ($ENV{'GSDLHOME'}, "collect");
889 }
890
891 # get and check the collection
892 if (!defined($collection) || $collection eq "") {
893 if (defined $ENV{'GSDLCOLLECTION'}) {
894 $collection = $ENV{'GSDLCOLLECTION'};
895 } else {
896 print STDOUT "No collection specified\n";
897 return "";
898 }
899 }
900
901 if ($collection eq "modelcol") {
902 print STDOUT "You can't use modelcol.\n";
903 return "";
904 }
905
906 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
907 # are defined
908 $ENV{'GSDLCOLLECTION'} = $collection;
909 $ENV{'GSDLCOLLECTDIR'} = &filename_cat ($collectdir, $collection);
910
911 # make sure this collection exists
912 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
913 print STDOUT "Invalid collection ($collection).\n";
914 return "";
915 }
916
917 # everything is ready to go
918 return $collection;
919}
920
921
922
923
924# will return the collection name if successful, "" otherwise.
925# Like use_collection (above) but for greenstone 3 (taking account of site level)
926
927sub use_site_collection {
928 my ($site, $collection, $collectdir) = @_;
929
930 if (!defined $collectdir || $collectdir eq "") {
931 die "GSDL3HOME not set.\n" unless defined $ENV{'GSDL3HOME'};
932 $collectdir = &filename_cat ($ENV{'GSDL3HOME'}, "sites", $site, "collect");
933 }
934
935 # collectdir explicitly set by this point (using $site variable if required).
936 # Can call "old" gsdl2 use_collection now.
937
938 return use_collection($collection,$collectdir);
939}
940
941
942
943sub locate_config_file
944{
945 my ($file) = @_;
946
947 my $locations = locate_config_files($file);
948
949 return shift @$locations; # returns undef if 'locations' is empty
950}
951
952
953sub locate_config_files
954{
955 my ($file) = @_;
956
957 my @locations = ();
958
959 if (-e $file) {
960 # Clearly specified (most likely full filename)
961 # No need to hunt in 'etc' directories, return value unchanged
962 push(@locations,$file);
963 }
964 else {
965 # Check for collection specific one before looking in global GSDL 'etc'
966 if (defined $ENV{'GSDLCOLLECTDIR'} && $ENV{'GSDLCOLLECTDIR'} ne "") {
967 my $test_collect_etc_filename
968 = &util::filename_cat($ENV{'GSDLCOLLECTDIR'},"etc", $file);
969
970 if (-e $test_collect_etc_filename) {
971 push(@locations,$test_collect_etc_filename);
972 }
973 }
974 my $test_main_etc_filename
975 = &util::filename_cat($ENV{'GSDLHOME'},"etc", $file);
976 if (-e $test_main_etc_filename) {
977 push(@locations,$test_main_etc_filename);
978 }
979 }
980
981 return \@locations;
982}
983
984
985sub hyperlink_text
986{
987 my ($text) = @_;
988
989 $text =~ s/(http:\/\/[^\s]+)/<a href=\"$1\">$1<\/a>/mg;
990 $text =~ s/(^|\s+)(www\.(\w|\.)+)/<a href=\"http:\/\/$2\">$2<\/a>/mg;
991
992 return $text;
993}
994
995
996# A method to check if a directory is empty (note that an empty directory still has non-zero size!!!)
997# Code is from http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
998sub is_dir_empty
999{
1000 my ($path) = @_;
1001 opendir DIR, $path;
1002 while(my $entry = readdir DIR) {
1003 next if($entry =~ /^\.\.?$/);
1004 closedir DIR;
1005 return 0;
1006 }
1007 closedir DIR;
1008 return 1;
1009}
1010
1011# Returns the given filename converted using either URL encoding or base64
1012# encoding, as specified by $rename_method. If the given filename has no suffix
1013# (if it is just the tailname), then $no_suffix should be some defined value.
1014sub rename_file {
1015 my ($filename, $rename_method, $no_suffix) = @_;
1016
1017 if(!$filename) { # undefined or empty string
1018 return $filename;
1019 }
1020
1021 # Replace spaces with underscore.
1022 # Do this first else it can go wrong below when getting tailname
1023 $filename =~ s/ /_/g;
1024
1025 my ($tailname,$dirname,$suffix);
1026 if($no_suffix) { # given a tailname, no suffix
1027 ($tailname,$dirname) = File::Basename::fileparse($filename);
1028 }
1029 else {
1030 ($tailname,$dirname,$suffix) = File::Basename::fileparse($filename, "\\.(?:[^\\.]+?)\$");
1031 }
1032 $suffix = "" if !$suffix;
1033
1034 if (!$rename_method) {
1035 print STDERR "WARNING: no file renaming method specified. Defaulting to using URL encoding...\n";
1036 # Debugging information
1037 my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
1038 print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
1039 } elsif($rename_method eq "none") {
1040 return $filename; # would have already been renamed
1041 }
1042
1043 if (!$rename_method || $rename_method eq "url") {
1044 $tailname = &unicode::url_encode($tailname);
1045 }
1046 elsif ($rename_method eq "base64") {
1047 $tailname = &unicode::base64_encode($tailname);
1048 $tailname =~ s/\s*//sg; # for some reason it adds spaces not just at end but also in middle
1049 }
1050
1051 $filename = "$tailname$suffix";
1052 $filename = "$dirname$filename" if ($dirname ne "./" && $dirname ne ".\\");
1053
1054 return $filename;
1055}
1056
10571;
Note: See TracBrowser for help on using the repository browser.