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

Last change on this file since 15088 was 15088, checked in by kjdon, 16 years ago

changed reg exp to use split and pop instead due to not working under windows
  • Property svn:keywords set to Author Date Id Revision
File size: 20.8 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) = @_;
398
399 # remove trailing slashes from source and destination files
400 $src =~ s/[\\\/]+$//;
401 $dest =~ s/[\\\/]+$//;
402
403 # a few sanity checks
404 if (!-e $src) {
405 print STDERR "util::soft_link source file $src does not exist\n";
406 return 0;
407 }
408
409 my $dest_dir = &File::Basename::dirname($dest);
410 mk_all_dir($dest_dir) if (!-e $dest_dir);
411
412 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
413 # symlink not supported on windows
414 &File::Copy::copy ($src, $dest);
415
416 } elsif (!eval {symlink($src, $dest)}) {
417 print STDERR "util::soft_link: unable to create soft link.\n";
418 return 0;
419 }
420
421 return 1;
422}
423
424
425
426
427# updates a copy of a directory in some other part of the filesystem
428# verbosity settings are: 0=low, 1=normal, 2=high
429# both $fromdir and $todir should be absolute paths
430sub cachedir {
431 my ($fromdir, $todir, $verbosity) = @_;
432 $verbosity = 1 unless defined $verbosity;
433
434 # use / for the directory separator, remove duplicate and
435 # trailing slashes
436 $fromdir=~s/[\\\/]+/\//g;
437 $fromdir=~s/[\\\/]+$//;
438 $todir=~s/[\\\/]+/\//g;
439 $todir=~s/[\\\/]+$//;
440
441 &mk_all_dir ($todir);
442
443 # get the directories in ascending order
444 if (!opendir (FROMDIR, $fromdir)) {
445 print STDERR "util::cachedir could not read directory $fromdir\n";
446 return;
447 }
448 my @fromdir = grep (!/^\.\.?$/, sort(readdir (FROMDIR)));
449 closedir (FROMDIR);
450
451 if (!opendir (TODIR, $todir)) {
452 print STDERR "util::cacedir could not read directory $todir\n";
453 return;
454 }
455 my @todir = grep (!/^\.\.?$/, sort(readdir (TODIR)));
456 closedir (TODIR);
457
458 my $fromi = 0;
459 my $toi = 0;
460
461 while ($fromi < scalar(@fromdir) || $toi < scalar(@todir)) {
462# print "fromi: $fromi toi: $toi\n";
463
464 # see if we should delete a file/directory
465 # this should happen if the file/directory
466 # is not in the from list or if its a different
467 # size, or has an older timestamp
468 if ($toi < scalar(@todir)) {
469 if (($fromi >= scalar(@fromdir)) ||
470 ($todir[$toi] lt $fromdir[$fromi] ||
471 ($todir[$toi] eq $fromdir[$fromi] &&
472 &differentfiles("$fromdir/$fromdir[$fromi]","$todir/$todir[$toi]",
473 $verbosity)))) {
474
475 # the files are different
476 &rm_r("$todir/$todir[$toi]");
477 splice(@todir, $toi, 1); # $toi stays the same
478
479 } elsif ($todir[$toi] eq $fromdir[$fromi]) {
480 # the files are the same
481 # if it is a directory, check its contents
482 if (-d "$todir/$todir[$toi]") {
483 &cachedir ("$fromdir/$fromdir[$fromi]",
484 "$todir/$todir[$toi]", $verbosity);
485 }
486
487 $toi++;
488 $fromi++;
489 next;
490 }
491 }
492
493 # see if we should insert a file/directory
494 # we should insert a file/directory if there
495 # is no tofiles left or if the tofile does not exist
496 if ($fromi < scalar(@fromdir) && ($toi >= scalar(@todir) ||
497 $todir[$toi] gt $fromdir[$fromi])) {
498 &cp_r ("$fromdir/$fromdir[$fromi]", "$todir/$fromdir[$fromi]");
499 splice (@todir, $toi, 0, $fromdir[$fromi]);
500
501 $toi++;
502 $fromi++;
503 }
504 }
505}
506
507# this function returns -1 if either file is not found
508# assumes that $file1 and $file2 are absolute file names or
509# in the current directory
510# $file2 is allowed to be newer than $file1
511sub differentfiles {
512 my ($file1, $file2, $verbosity) = @_;
513 $verbosity = 1 unless defined $verbosity;
514
515 $file1 =~ s/\/+$//;
516 $file2 =~ s/\/+$//;
517
518 my ($file1name) = $file1 =~ /\/([^\/]*)$/;
519 my ($file2name) = $file2 =~ /\/([^\/]*)$/;
520
521 return -1 unless (-e $file1 && -e $file2);
522 if ($file1name ne $file2name) {
523 print STDERR "filenames are not the same\n" if ($verbosity >= 2);
524 return 1;
525 }
526
527 my @file1stat = stat ($file1);
528 my @file2stat = stat ($file2);
529
530 if (-d $file1) {
531 if (! -d $file2) {
532 print STDERR "one file is a directory\n" if ($verbosity >= 2);
533 return 1;
534 }
535 return 0;
536 }
537
538 # both must be regular files
539 unless (-f $file1 && -f $file2) {
540 print STDERR "one file is not a regular file\n" if ($verbosity >= 2);
541 return 1;
542 }
543
544 # the size of the files must be the same
545 if ($file1stat[7] != $file2stat[7]) {
546 print STDERR "different sized files\n" if ($verbosity >= 2);
547 return 1;
548 }
549
550 # the second file cannot be older than the first
551 if ($file1stat[9] > $file2stat[9]) {
552 print STDERR "file is older\n" if ($verbosity >= 2);
553 return 1;
554 }
555
556 return 0;
557}
558
559
560sub get_tmp_filename {
561 my $tmpdir = filename_cat($ENV{'GSDLHOME'}, "tmp");
562 &mk_all_dir ($tmpdir) unless -e $tmpdir;
563
564 my $count = 1000;
565 my $rand = int(rand $count);
566 while (-e &filename_cat($tmpdir, "F$rand")) {
567 $rand = int(rand $count);
568 $count++;
569 }
570
571 return filename_cat($tmpdir, "F$rand");
572}
573
574
575sub filename_cat {
576 my $first_file = shift(@_);
577 my (@filenames) = @_;
578
579 # Check for empty first filename
580 if ($first_file =~ /\S/) {
581 unshift(@filenames, $first_file);
582 }
583
584 my $filename = join("/", @filenames);
585
586 # remove duplicate slashes and remove the last slash
587 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
588 $filename =~ s/[\\\/]+/\\/g;
589 } else {
590 $filename =~ s/[\/]+/\//g;
591 # DB: want a filename abc\de.html to remain like this
592 }
593 $filename =~ s/[\\\/]$//;
594
595 return $filename;
596}
597
598
599sub envvar_prepend {
600 my ($var,$val) = @_;
601
602 my $current_val = $ENV{$var};
603
604 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
605 $ENV{$var} .= "$val;$current_val";
606 }
607 else {
608 $ENV{$var} .= "$val:$current_val";
609 }
610}
611
612sub envvar_append {
613 my ($var,$val) = @_;
614
615 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
616 $ENV{$var} .= ";$val";
617 }
618 else {
619 $ENV{$var} .= ":$val";
620 }
621}
622
623
624# returns the path of a file without the filename -- ie. the directory the file is in
625sub filename_head {
626 my $filename = shift(@_);
627
628 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
629 $filename =~ s/[^\\\\]*$//;
630 }
631 else {
632 $filename =~ s/[^\\\/]*$//;
633 }
634
635 return $filename;
636}
637
638
639# returns 1 if filename1 and filename2 point to the same
640# file or directory
641sub filenames_equal {
642 my ($filename1, $filename2) = @_;
643
644 # use filename_cat to clean up trailing slashes and
645 # multiple slashes
646 $filename1 = filename_cat ($filename1);
647 $filename2 = filename_cat ($filename2);
648
649 # filenames not case sensitive on windows
650 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
651 $filename1 =~ tr/[A-Z]/[a-z]/;
652 $filename2 =~ tr/[A-Z]/[a-z]/;
653 }
654 return 1 if $filename1 eq $filename2;
655 return 0;
656}
657
658sub filename_within_collection
659{
660 my ($filename) = @_;
661
662 my $collect_dir = $ENV{'GSDLCOLLECTDIR'};
663
664 if (defined $collect_dir) {
665 my $dirsep = &util::get_dirsep();
666 if ($collect_dir !~ m/$dirsep$/) {
667 $collect_dir .= $dirsep;
668 }
669
670 $collect_dir =~ s/\\/\\\\/g; # escape DOS style file separator
671
672 if ($filename =~ /^$collect_dir(.*)$/) {
673 $filename = $1;
674 }
675 }
676
677 return $filename;
678}
679
680
681sub get_dirsep {
682
683 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
684 return "\\";
685 } else {
686 return "\/";
687 }
688}
689
690sub get_os_dirsep {
691
692 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
693 return "\\\\";
694 } else {
695 return "\\\/";
696 }
697}
698
699sub get_re_dirsep {
700
701 return "\\\\|\\\/";
702}
703
704
705sub get_dirsep_tail {
706 my ($filename) = @_;
707
708 # returns last part of directory or filename
709 # On unix e.g. a/b.d => b.d
710 # a/b/c => c
711
712 my $dirsep = get_re_dirsep();
713 my @dirs = split (/$dirsep/, $filename);
714 my $tail = pop @dirs;
715
716 # - caused problems under windows
717 #my ($tail) = ($filename =~ m/^(?:.*?$dirsep)?(.*?)$/);
718
719 return $tail;
720}
721
722
723# if this is running on windows we want binaries to end in
724# .exe, otherwise they don't have to end in any extension
725sub get_os_exe {
726 return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
727 return "";
728}
729
730
731# test to see whether this is a big or little endian machine
732sub is_little_endian {
733 # To determine the name of the operating system, the variable $^O is a cheap alternative to pulling it out of the Config module;
734 # What we do here is, if it is a Macintosh machine (i.e. the Darwin operating system), regardless it is running on the IBM power-pc cpu or it is the x86 Intel-based chip with a power-pc emulator running on top of it, it requires the big-endian data format in the gdbm database file, we make the file extension .bdb; otherwise it's .ldb extension.
735
736 #return 0 if $^O =~ /^darwin$/i;
737 return 0 if $ENV{'GSDLOS'} =~ /^darwin$/i;
738 return (ord(substr(pack("s",1), 0, 1)) == 1);
739}
740
741
742# will return the collection name if successful, "" otherwise
743sub use_collection {
744 my ($collection, $collectdir) = @_;
745
746 if (!defined $collectdir || $collectdir eq "") {
747 $collectdir = &filename_cat ($ENV{'GSDLHOME'}, "collect");
748 }
749
750 # get and check the collection
751 if (!defined($collection) || $collection eq "") {
752 if (defined $ENV{'GSDLCOLLECTION'}) {
753 $collection = $ENV{'GSDLCOLLECTION'};
754 } else {
755 print STDOUT "No collection specified\n";
756 return "";
757 }
758 }
759
760 if ($collection eq "modelcol") {
761 print STDOUT "You can't use modelcol.\n";
762 return "";
763 }
764
765 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
766 # are defined
767 $ENV{'GSDLCOLLECTION'} = $collection unless defined $ENV{'GSDLCOLLECTION'};
768 $ENV{'GSDLCOLLECTDIR'} = &filename_cat ($collectdir, $collection);
769
770 # make sure this collection exists
771 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
772 print STDOUT "Invalid collection ($collection).\n";
773 return "";
774 }
775
776 # everything is ready to go
777 return $collection;
778}
779
780
781
782
783# will return the collection name if successful, "" otherwise.
784# Like use_collection (above) but for greenstone 3 (taking account of site level)
785
786sub use_site_collection {
787 my ($site, $collection, $collectdir) = @_;
788
789 if (!defined $collectdir || $collectdir eq "") {
790 die "GSDL3HOME not set.\n" unless defined $ENV{'GSDL3HOME'};
791 $collectdir = &filename_cat ($ENV{'GSDL3HOME'}, "sites", $site, "collect");
792 }
793
794 # collectdir explicitly set by this point (using $site variable if required).
795 # Can call "old" gsdl2 use_collection now.
796
797 return use_collection($collection,$collectdir);
798}
799
800
801
802sub locate_config_file
803{
804 my ($file) = @_;
805
806 my $locations = locate_config_files($file);
807
808 return shift @$locations; # returns undef if 'locations' is empty
809}
810
811
812sub locate_config_files
813{
814 my ($file) = @_;
815
816 my @locations = ();
817
818 if (-e $file) {
819 # Clearly specified (most likely full filename)
820 # No need to hunt in 'etc' directories, return value unchanged
821 push(@locations,$file);
822 }
823 else {
824 # Check for collection specific one before looking in global GSDL 'etc'
825
826 my $test_collect_etc_filename
827 = &util::filename_cat($ENV{'GSDLCOLLECTDIR'},"etc", $file);
828
829 if (-e $test_collect_etc_filename) {
830 push(@locations,$test_collect_etc_filename);
831 }
832
833 my $test_main_etc_filename
834 = &util::filename_cat($ENV{'GSDLHOME'},"etc", $file);
835 if (-e $test_main_etc_filename) {
836 push(@locations,$test_main_etc_filename);
837 }
838 }
839
840 return \@locations;
841}
842
843
844sub hyperlink_text
845{
846 my ($text) = @_;
847
848 $text =~ s/(http:\/\/[^\s]+)/<a href=\"$1\">$1<\/a>/mg;
849 $text =~ s/(^|\s+)(www\.(\w|\.)+)/<a href=\"http:\/\/$2\">$2<\/a>/mg;
850
851 return $text;
852}
853
854
8551;
Note: See TracBrowser for help on using the repository browser.