root/gsdl/trunk/perllib/util.pm @ 17714

Revision 17714, 25.6 KB (checked in by ak19, 12 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
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 browser.