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

Last change on this file since 17714 was 17714, checked in by ak19, 15 years ago

No longer defaults to big endian for all Macintosh machines regardless of what endian they are. It has now gone back to returning exactly whatever endian the machine is.
  • Property svn:keywords set to Author Date Id Revision
File size: 25.6 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) = @_;
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 print STDERR "util::hard_link: unable to create hard link. ";
389 print STDERR " Attempting to copy file: $src -> $dest\n";
390 &File::Copy::copy ($src, $dest);
391 }
392 return 0;
393}
394
395# make soft link to file if supported by OS, otherwise copy file
396sub soft_link {
397 my ($src, $dest, $ensure_paths_absolute) = @_;
398
399 # remove trailing slashes from source and destination files
400 $src =~ s/[\\\/]+$//;
401 $dest =~ s/[\\\/]+$//;
402
403 # Ensure file paths are absolute IF requested to do so
404 # Soft_linking didn't work for relative paths
405 if(defined $ensure_paths_absolute && $ensure_paths_absolute) {
406 # We need to ensure that the src file is the absolute path
407 # See http://perldoc.perl.org/File/Spec.html
408 if(!File::Spec->file_name_is_absolute( $src )) { # it's relative
409 $src = File::Spec->rel2abs($src); # make absolute
410 }
411 # Might as well ensure that the destination file's absolute path is used
412 if(!File::Spec->file_name_is_absolute( $dest )) {
413 $dest = File::Spec->rel2abs($dest); # make absolute
414 }
415 }
416
417 # a few sanity checks
418 if (!-e $src) {
419 print STDERR "util::soft_link source file $src does not exist\n";
420 return 0;
421 }
422
423 my $dest_dir = &File::Basename::dirname($dest);
424 mk_all_dir($dest_dir) if (!-e $dest_dir);
425
426 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
427 # symlink not supported on windows
428 &File::Copy::copy ($src, $dest);
429
430 } elsif (!eval {symlink($src, $dest)}) {
431 print STDERR "util::soft_link: unable to create soft link.\n";
432 return 0;
433 }
434
435 return 1;
436}
437
438
439
440
441# updates a copy of a directory in some other part of the filesystem
442# verbosity settings are: 0=low, 1=normal, 2=high
443# both $fromdir and $todir should be absolute paths
444sub cachedir {
445 my ($fromdir, $todir, $verbosity) = @_;
446 $verbosity = 1 unless defined $verbosity;
447
448 # use / for the directory separator, remove duplicate and
449 # trailing slashes
450 $fromdir=~s/[\\\/]+/\//g;
451 $fromdir=~s/[\\\/]+$//;
452 $todir=~s/[\\\/]+/\//g;
453 $todir=~s/[\\\/]+$//;
454
455 &mk_all_dir ($todir);
456
457 # get the directories in ascending order
458 if (!opendir (FROMDIR, $fromdir)) {
459 print STDERR "util::cachedir could not read directory $fromdir\n";
460 return;
461 }
462 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
463 closedir (FROMDIR);
464
465 if (!opendir (TODIR, $todir)) {
466 print STDERR "util::cacedir could not read directory $todir\n";
467 return;
468 }
469 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
470 closedir (TODIR);
471
472 my $fromi = 0;
473 my $toi = 0;
474
475 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) {
476# print "fromi: $fromi toi: $toi\n";
477
478 # see if we should delete a file/directory
479 # this should happen if the file/directory
480 # is not in the from list or if its a different
481 # size, or has an older timestamp
482 if ($toi < scalar(@todir)) {
483 if (($fromi >= scalar(@fromdir)) ||
484 ($todir[$toi] lt $fromdir[$fromi] ||
485 ($todir[$toi] eq $fromdir[$fromi] &&
486 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
487 $verbosity)))) {
488
489 # the files are different
490 &rm_r("$todir/$todir[$toi]");
491 splice(@todir, $toi, 1); # $toi stays the same
492
493 } elsif ($todir[$toi] eq $fromdir[$fromi]) {
494 # the files are the same
495 # if it is a directory, check its contents
496 if (-d "$todir/$todir[$toi]") {
497 &cachedir ("$fromdir/$fromdir[$fromi]",
498 "$todir/$todir[$toi]", $verbosity);
499 }
500
501 $toi++;
502 $fromi++;
503 next;
504 }
505 }
506
507 # see if we should insert a file/directory
508 # we should insert a file/directory if there
509 # is no tofiles left or if the tofile does not exist
510 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
511 $todir[$toi] gt $fromdir[$fromi])) {
512 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
513 splice (@todir, $toi, 0, $fromdir[$fromi]);
514
515 $toi++;
516 $fromi++;
517 }
518 }
519}
520
521# this function returns -1 if either file is not found
522# assumes that $file1 and $file2 are absolute file names or
523# in the current directory
524# $file2 is allowed to be newer than $file1
525sub differentfiles {
526 my ($file1, $file2, $verbosity) = @_;
527 $verbosity = 1 unless defined $verbosity;
528
529 $file1 =~ s/\/+$//;
530 $file2 =~ s/\/+$//;
531
532 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
533 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
534
535 return -1 unless (-e $file1 && -e $file2);
536 if ($file1name ne $file2name) {
537 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
538 return 1;
539 }
540
541 my @file1stat = stat ($file1);
542 my @file2stat = stat ($file2);
543
544 if (-d $file1) {
545 if (! -d $file2) {
546 print STDERR "one file is a directory\n" if ($verbosity >= 2);
547 return 1;
548 }
549 return 0;
550 }
551
552 # both must be regular files
553 unless (-f $file1 && -f $file2) {
554 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
555 return 1;
556 }
557
558 # the size of the files must be the same
559 if ($file1stat[7] != $file2stat[7]) {
560 print STDERR "different sized files\n" if ($verbosity >= 2);
561 return 1;
562 }
563
564 # the second file cannot be older than the first
565 if ($file1stat[9] > $file2stat[9]) {
566 print STDERR "file is older\n" if ($verbosity >= 2);
567 return 1;
568 }
569
570 return 0;
571}
572
573
574sub get_tmp_filename
575{
576 my $file_ext = shift(@_) || undef;
577
578 my $opt_dot_file_ext = (defined $file_ext) ? ".$file_ext" : "";
579
580 my $tmpdir = filename_cat($ENV{'GSDLHOME'}, "tmp");
581 &mk_all_dir ($tmpdir) unless -e $tmpdir;
582
583 my $count = 1000;
584 my $rand = int(rand $count);
585 my $full_tmp_filename = &filename_cat($tmpdir, "F$rand$opt_dot_file_ext");
586
587 while (-e $full_tmp_filename) {
588 $rand = int(rand $count);
589 $full_tmp_filename = &filename_cat($tmpdir, "F$rand$opt_dot_file_ext");
590 $count++;
591 }
592
593 return $full_tmp_filename;
594}
595
596sub filename_to_regex {
597 my $filename = shift (@_);
598
599 # need to put single backslash back to double so that regex works
600 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
601 $filename =~ s/\\/\\\\/g;
602 }
603 return $filename;
604}
605
606sub filename_cat {
607 my $first_file = shift(@_);
608 my (@filenames) = @_;
609
610# Useful for debugging
611# -- might make sense to call caller(0) rather than (1)??
612# my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
613# print STDERR "Calling method; $cfilename:$cline $cpackage->$csubr\n";
614
615 # Check for empty first filename
616 if ($first_file =~ /\S/) {
617 unshift(@filenames, $first_file);
618 }
619
620 my $filename = join("/", @filenames);
621
622 # remove duplicate slashes and remove the last slash
623 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
624 $filename =~ s/[\\\/]+/\\/g;
625 } else {
626 $filename =~ s/[\/]+/\//g;
627 # DB: want a filename abc\de.html to remain like this
628 }
629 $filename =~ s/[\\\/]$//;
630
631 return $filename;
632}
633
634
635sub envvar_prepend {
636 my ($var,$val) = @_;
637
638 # do not prepend any value/path that's already in the environment variable
639 if ($ENV{'GSDLOS'} =~ /^windows$/i)
640 {
641 my $escaped_val = $val;
642 $escaped_val =~ s/\\/\\\\/g; # escape any Windows backslashes for upcoming regex
643 if($ENV{$var} !~ m/$escaped_val/) {
644 $ENV{$var} = "$val;".$ENV{$var};
645 }
646 }
647 else {
648 if($ENV{$var} !~ m/$val/) {
649 $ENV{$var} = "$val:".$ENV{$var};
650 }
651 }
652}
653
654sub envvar_append {
655 my ($var,$val) = @_;
656
657 # do not append any value/path that's already in the environment variable
658 if ($ENV{'GSDLOS'} =~ /^windows$/i)
659 {
660 my $escaped_val = $val;
661 $escaped_val =~ s/\\/\\\\/g; # escape any Windows backslashes for upcoming regex
662 if($ENV{$var} !~ m/$escaped_val/) {
663 $ENV{$var} .= ";$val";
664 }
665 }
666 else {
667 if($ENV{$var} !~ m/$val/) {
668 $ENV{$var} .= ":$val";
669 }
670 }
671}
672
673
674# splits a filename into a prefix and a tail extension using the tail_re, or
675# if that fails, splits on the file_extension . (dot)
676sub get_prefix_and_tail_by_regex {
677
678 my ($filename,$tail_re) = @_;
679
680 my ($file_prefix,$file_ext) = ($filename =~ m/^(.*?)($tail_re)$/);
681 if ((!defined $file_prefix) || (!defined $file_ext)) {
682 ($file_prefix,$file_ext) = ($filename =~ m/^(.*)(\..*?)$/);
683 }
684
685 return ($file_prefix,$file_ext);
686}
687
688# get full path and file only path from a base_dir (which may be empty) and
689# file (which may contain directories)
690sub get_full_filenames {
691 my ($base_dir, $file) = @_;
692
693 my $filename_full_path = $file;
694 # add on directory if present
695 $filename_full_path = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\S/;
696
697 my $filename_no_path = $file;
698
699 # remove directory if present
700 $filename_no_path =~ s/^.*[\/\\]//;
701 return ($filename_full_path, $filename_no_path);
702}
703
704# returns the path of a file without the filename -- ie. the directory the file is in
705sub filename_head {
706 my $filename = shift(@_);
707
708 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
709 $filename =~ s/[^\\\\]*$//;
710 }
711 else {
712 $filename =~ s/[^\\\/]*$//;
713 }
714
715 return $filename;
716}
717
718
719# returns 1 if filename1 and filename2 point to the same
720# file or directory
721sub filenames_equal {
722 my ($filename1, $filename2) = @_;
723
724 # use filename_cat to clean up trailing slashes and
725 # multiple slashes
726 $filename1 = filename_cat ($filename1);
727 $filename2 = filename_cat ($filename2);
728
729 # filenames not case sensitive on windows
730 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
731 $filename1 =~ tr/[A-Z]/[a-z]/;
732 $filename2 =~ tr/[A-Z]/[a-z]/;
733 }
734 return 1 if $filename1 eq $filename2;
735 return 0;
736}
737
738sub filename_within_collection
739{
740 my ($filename) = @_;
741
742 my $collect_dir = $ENV{'GSDLCOLLECTDIR'};
743
744 if (defined $collect_dir) {
745 my $dirsep = &util::get_dirsep();
746 if ($collect_dir !~ m/$dirsep$/) {
747 $collect_dir .= $dirsep;
748 }
749
750 $collect_dir =~ s/\\/\\\\/g; # escape DOS style file separator
751
752 # if from within GSDLCOLLECTDIR, then remove directory prefix
753 # so source_filename is realative to it. This is done to aid
754 # portability, i.e. the collection can be moved to somewhere
755 # else on the file system and the archives directory will still
756 # work. This is needed, for example in the applet version of
757 # GLI where GSDLHOME/collect on the server will be different to
758 # the collect directory of the remove user. Of course,
759 # GSDLCOLLECTDIR subsequently needs to be put back on to turn
760 # it back into a full pathname.
761
762 if ($filename =~ /^$collect_dir(.*)$/) {
763 $filename = $1;
764 }
765 }
766
767 return $filename;
768}
769
770## @method make_absolute()
771#
772# Ensure the given file path is absolute in respect to the given base path.
773#
774# @param $base_dir A string denoting the base path the given dir must be
775# absolute to.
776# @param $dir The directory to be made absolute as a string. Note that the
777# dir may already be absolute, in which case it will remain
778# unchanged.
779# @return The now absolute form of the directory as a string.
780#
781# @author John Thompson, DL Consulting Ltd.
782# @copy 2006 DL Consulting Ltd.
783#
784#used in buildcol.pl, doesn't work for all cases --kjdon
785sub make_absolute {
786
787 my ($base_dir, $dir) = @_;
788 print STDERR "dir = $dir\n";
789 $dir =~ s/[\\\/]+/\//g;
790 $dir = $base_dir . "/$dir" unless ($dir =~ m|^(\w:)?/|);
791 $dir =~ s|^/tmp_mnt||;
792 1 while($dir =~ s|/[^/]*/\.\./|/|g);
793 $dir =~ s|/[.][.]?/|/|g;
794 $dir =~ tr|/|/|s;
795 print STDERR "dir = $dir\n";
796
797 return $dir;
798}
799## make_absolute() ##
800
801sub get_dirsep {
802
803 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
804 return "\\";
805 } else {
806 return "\/";
807 }
808}
809
810sub get_os_dirsep {
811
812 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
813 return "\\\\";
814 } else {
815 return "\\\/";
816 }
817}
818
819sub get_re_dirsep {
820
821 return "\\\\|\\\/";
822}
823
824
825sub get_dirsep_tail {
826 my ($filename) = @_;
827
828 # returns last part of directory or filename
829 # On unix e.g. a/b.d => b.d
830 # a/b/c => c
831
832 my $dirsep = get_re_dirsep();
833 my @dirs = split (/$dirsep/, $filename);
834 my $tail = pop @dirs;
835
836 # - caused problems under windows
837 #my ($tail) = ($filename =~ m/^(?:.*?$dirsep)?(.*?)$/);
838
839 return $tail;
840}
841
842
843# if this is running on windows we want binaries to end in
844# .exe, otherwise they don't have to end in any extension
845sub get_os_exe {
846 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
847 return "";
848}
849
850
851# test to see whether this is a big or little endian machine
852sub is_little_endian
853{
854 # To determine the name of the operating system, the variable $^O is a cheap alternative to pulling it out of the Config module;
855 # 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
856 # Otherwise, it's little endian
857
858 #return 0 if $^O =~ /^darwin$/i;
859 #return 0 if $ENV{'GSDLOS'} =~ /^darwin$/i;
860
861 # Going back to stating exactly whether the machine is little endian
862 # or big endian, without any special case for Macs. Since for rata it comes
863 # back with little endian and for shuttle with bigendian.
864 return (ord(substr(pack("s",1), 0, 1)) == 1);
865}
866
867
868# will return the collection name if successful, "" otherwise
869sub use_collection {
870 my ($collection, $collectdir) = @_;
871
872 if (!defined $collectdir || $collectdir eq "") {
873 $collectdir = &filename_cat ($ENV{'GSDLHOME'}, "collect");
874 }
875
876 # get and check the collection
877 if (!defined($collection) || $collection eq "") {
878 if (defined $ENV{'GSDLCOLLECTION'}) {
879 $collection = $ENV{'GSDLCOLLECTION'};
880 } else {
881 print STDOUT "No collection specified\n";
882 return "";
883 }
884 }
885
886 if ($collection eq "modelcol") {
887 print STDOUT "You can't use modelcol.\n";
888 return "";
889 }
890
891 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
892 # are defined
893 $ENV{'GSDLCOLLECTION'} = $collection;
894 $ENV{'GSDLCOLLECTDIR'} = &filename_cat ($collectdir, $collection);
895
896 # make sure this collection exists
897 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
898 print STDOUT "Invalid collection ($collection).\n";
899 return "";
900 }
901
902 # everything is ready to go
903 return $collection;
904}
905
906
907
908
909# will return the collection name if successful, "" otherwise.
910# Like use_collection (above) but for greenstone 3 (taking account of site level)
911
912sub use_site_collection {
913 my ($site, $collection, $collectdir) = @_;
914
915 if (!defined $collectdir || $collectdir eq "") {
916 die "GSDL3HOME not set.\n" unless defined $ENV{'GSDL3HOME'};
917 $collectdir = &filename_cat ($ENV{'GSDL3HOME'}, "sites", $site, "collect");
918 }
919
920 # collectdir explicitly set by this point (using $site variable if required).
921 # Can call "old" gsdl2 use_collection now.
922
923 return use_collection($collection,$collectdir);
924}
925
926
927
928sub locate_config_file
929{
930 my ($file) = @_;
931
932 my $locations = locate_config_files($file);
933
934 return shift @$locations; # returns undef if 'locations' is empty
935}
936
937
938sub locate_config_files
939{
940 my ($file) = @_;
941
942 my @locations = ();
943
944 if (-e $file) {
945 # Clearly specified (most likely full filename)
946 # No need to hunt in 'etc' directories, return value unchanged
947 push(@locations,$file);
948 }
949 else {
950 # Check for collection specific one before looking in global GSDL 'etc'
951 if (defined $ENV{'GSDLCOLLECTDIR'} && $ENV{'GSDLCOLLECTDIR'} ne "") {
952 my $test_collect_etc_filename
953 = &util::filename_cat($ENV{'GSDLCOLLECTDIR'},"etc", $file);
954
955 if (-e $test_collect_etc_filename) {
956 push(@locations,$test_collect_etc_filename);
957 }
958 }
959 my $test_main_etc_filename
960 = &util::filename_cat($ENV{'GSDLHOME'},"etc", $file);
961 if (-e $test_main_etc_filename) {
962 push(@locations,$test_main_etc_filename);
963 }
964 }
965
966 return \@locations;
967}
968
969
970sub hyperlink_text
971{
972 my ($text) = @_;
973
974 $text =~ s/(http:\/\/[^\s]+)/<a href=\"$1\">$1<\/a>/mg;
975 $text =~ s/(^|\s+)(www\.(\w|\.)+)/<a href=\"http:\/\/$2\">$2<\/a>/mg;
976
977 return $text;
978}
979
980
981# A method to check if a directory is empty (note that an empty directory still has non-zero size!!!)
982# Code is from http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
983sub is_dir_empty
984{
985 my ($path) = @_;
986 opendir DIR, $path;
987 while(my $entry = readdir DIR) {
988 next if($entry =~ /^\.\.?$/);
989 closedir DIR;
990 return 0;
991 }
992 closedir DIR;
993 return 1;
994}
995
9961;
Note: See TracBrowser for help on using the repository browser.