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

Revision 16969, 24.2 KB (checked in by kjdon, 12 years ago)

check that GSDLCOLLECTDIR is defined before using it in locate_config_files. Sometimes (eg when exploding) we are not in the context of a collection

  • 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
596
597sub filename_cat {
598    my $first_file = shift(@_);
599    my (@filenames) = @_;
600
601#   Useful for debugging
602#     -- might make sense to call caller(0) rather than (1)??
603#   my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
604#   print STDERR "Calling method; $cfilename:$cline $cpackage->$csubr\n";
605
606    # Check for empty first filename
607    if ($first_file =~ /\S/) {
608    unshift(@filenames, $first_file);
609    }
610
611    my $filename = join("/", @filenames);
612
613    # remove duplicate slashes and remove the last slash
614    if ($ENV{'GSDLOS'} =~ /^windows$/i) {
615    $filename =~ s/[\\\/]+/\\/g;
616    } else {
617    $filename =~ s/[\/]+/\//g;
618    # DB: want a filename abc\de.html to remain like this
619    }
620    $filename =~ s/[\\\/]$//;
621
622    return $filename;
623}
624
625
626sub envvar_prepend {
627    my ($var,$val) = @_;
628
629    # do not prepend any value/path that's already in the environment variable
630    if ($ENV{'GSDLOS'} =~ /^windows$/i)
631    {
632    my $escaped_val = $val;
633    $escaped_val =~ s/\\/\\\\/g; # escape any Windows backslashes for upcoming regex
634    if($ENV{$var} !~ m/$escaped_val/) {
635        $ENV{$var} = "$val;".$ENV{$var};
636    }
637    }
638    else {
639    if($ENV{$var} !~ m/$val/) {
640        $ENV{$var} = "$val:".$ENV{$var};
641    }
642    }
643}
644
645sub envvar_append {
646    my ($var,$val) = @_;
647
648    # do not append any value/path that's already in the environment variable
649    if ($ENV{'GSDLOS'} =~ /^windows$/i)
650    {
651    my $escaped_val = $val;
652    $escaped_val =~ s/\\/\\\\/g; # escape any Windows backslashes for upcoming regex
653    if($ENV{$var} !~ m/$escaped_val/) {
654        $ENV{$var} .= ";$val";
655    }
656    }
657    else {
658    if($ENV{$var} !~ m/$val/) {
659        $ENV{$var} .= ":$val";
660    }
661    }   
662}
663
664
665# splits a filename into a prefix and a tail extension using the tail_re, or
666# if that fails, splits on the file_extension . (dot)
667sub get_prefix_and_tail_by_regex {
668
669    my ($filename,$tail_re) = @_;
670   
671    my ($file_prefix,$file_ext) = ($filename =~ m/^(.*?)($tail_re)$/);
672    if ((!defined $file_prefix) || (!defined $file_ext)) {
673    ($file_prefix,$file_ext) = ($filename =~ m/^(.*)(\..*?)$/);
674    }
675
676    return ($file_prefix,$file_ext);
677}
678
679# get full path and file only path from a base_dir (which may be empty) and
680# file (which may contain directories)
681sub get_full_filenames {
682    my ($base_dir, $file) = @_;
683   
684    my $filename_full_path = $file;
685    # add on directory if present
686    $filename_full_path = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\S/;
687   
688    my $filename_no_path = $file;
689
690    # remove directory if present
691    $filename_no_path =~ s/^.*[\/\\]//;
692    return ($filename_full_path, $filename_no_path);
693}
694
695# returns the path of a file without the filename -- ie. the directory the file is in
696sub filename_head {
697    my $filename = shift(@_);
698
699    if ($ENV{'GSDLOS'} =~ /^windows$/i) {
700    $filename =~ s/[^\\\\]*$//;
701    }
702    else {
703    $filename =~ s/[^\\\/]*$//;
704    }
705
706    return $filename;
707}
708
709
710# returns 1 if filename1 and filename2 point to the same
711# file or directory
712sub filenames_equal {
713    my ($filename1, $filename2) = @_;
714
715    # use filename_cat to clean up trailing slashes and
716    # multiple slashes
717    $filename1 = filename_cat ($filename1);
718    $filename2 = filename_cat ($filename2);
719
720    # filenames not case sensitive on windows
721    if ($ENV{'GSDLOS'} =~ /^windows$/i) {
722    $filename1 =~ tr/[A-Z]/[a-z]/;
723    $filename2 =~ tr/[A-Z]/[a-z]/;
724    }
725    return 1 if $filename1 eq $filename2;
726    return 0;
727}
728
729sub filename_within_collection
730{
731    my ($filename) = @_;
732
733    my $collect_dir = $ENV{'GSDLCOLLECTDIR'};
734   
735    if (defined $collect_dir) {
736    my $dirsep = &util::get_dirsep();
737    if ($collect_dir !~ m/$dirsep$/) {
738        $collect_dir .= $dirsep;
739    }
740   
741    $collect_dir =~ s/\\/\\\\/g; # escape DOS style file separator
742   
743    # if from within GSDLCOLLECTDIR, then remove directory prefix
744    # so source_filename is realative to it.  This is done to aid
745    # portability, i.e. the collection can be moved to somewhere
746    # else on the file system and the archives directory will still
747    # work.  This is needed, for example in the applet version of
748    # GLI where GSDLHOME/collect on the server will be different to
749    # the collect directory of the remove user.  Of course,
750    # GSDLCOLLECTDIR subsequently needs to be put back on to turn
751    # it back into a full pathname.
752   
753    if ($filename =~ /^$collect_dir(.*)$/) {
754        $filename = $1;
755    }
756    }
757   
758    return $filename;
759}
760
761
762sub get_dirsep {
763
764    if ($ENV{'GSDLOS'} =~ /^windows$/i) {
765    return "\\";
766    } else {
767    return "\/";
768    }
769}
770
771sub get_os_dirsep {
772
773    if ($ENV{'GSDLOS'} =~ /^windows$/i) {
774    return "\\\\";
775    } else {
776    return "\\\/";
777    }
778}
779
780sub get_re_dirsep {
781
782    return "\\\\|\\\/";
783}
784
785
786sub get_dirsep_tail {
787    my ($filename) = @_;
788   
789    # returns last part of directory or filename
790    # On unix e.g. a/b.d => b.d
791    #              a/b/c => c
792
793    my $dirsep = get_re_dirsep();
794    my @dirs = split (/$dirsep/, $filename);
795    my $tail = pop @dirs;
796
797    # - caused problems under windows
798    #my ($tail) = ($filename =~ m/^(?:.*?$dirsep)?(.*?)$/);
799
800    return $tail;
801}
802
803
804# if this is running on windows we want binaries to end in
805# .exe, otherwise they don't have to end in any extension
806sub get_os_exe {
807    return ".exe" if $ENV{'GSDLOS'} =~ /^windows$/i;
808    return "";
809}
810
811
812# test to see whether this is a big or little endian machine
813sub is_little_endian
814{
815    # To determine the name of the operating system, the variable $^O is a cheap alternative to pulling it out of the Config module;
816    # 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
817    # Otherwise, it's little endian
818
819    #return 0 if $^O =~ /^darwin$/i;
820    return 0 if $ENV{'GSDLOS'} =~ /^darwin$/i;
821    return (ord(substr(pack("s",1), 0, 1)) == 1);
822}
823
824
825# will return the collection name if successful, "" otherwise
826sub use_collection {
827    my ($collection, $collectdir) = @_;
828
829    if (!defined $collectdir || $collectdir eq "") {
830    $collectdir = &filename_cat ($ENV{'GSDLHOME'}, "collect");
831    }
832
833    # get and check the collection
834    if (!defined($collection) || $collection eq "") {
835    if (defined $ENV{'GSDLCOLLECTION'}) {
836        $collection = $ENV{'GSDLCOLLECTION'};
837    } else {
838        print STDOUT "No collection specified\n";
839        return "";
840    }
841    }
842   
843    if ($collection eq "modelcol") {
844    print STDOUT "You can't use modelcol.\n";
845    return "";
846    }
847
848    # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
849    # are defined
850    $ENV{'GSDLCOLLECTION'} = $collection unless defined $ENV{'GSDLCOLLECTION'};
851    $ENV{'GSDLCOLLECTDIR'} = &filename_cat ($collectdir, $collection);
852
853    # make sure this collection exists
854    if (!-e $ENV{'GSDLCOLLECTDIR'}) {
855    print STDOUT "Invalid collection ($collection).\n";
856    return "";
857    }
858
859    # everything is ready to go
860    return $collection;
861}
862
863
864
865
866# will return the collection name if successful, "" otherwise. 
867# Like use_collection (above) but for greenstone 3 (taking account of site level)
868
869sub use_site_collection {
870    my ($site, $collection, $collectdir) = @_;
871
872    if (!defined $collectdir || $collectdir eq "") {
873    die "GSDL3HOME not set.\n" unless defined $ENV{'GSDL3HOME'};
874    $collectdir = &filename_cat ($ENV{'GSDL3HOME'}, "sites", $site, "collect");
875    }
876
877    # collectdir explicitly set by this point (using $site variable if required).
878    # Can call "old" gsdl2 use_collection now.
879
880    return use_collection($collection,$collectdir);
881}
882
883
884
885sub locate_config_file
886{
887    my ($file) = @_;
888
889    my $locations = locate_config_files($file);
890
891    return shift @$locations; # returns undef if 'locations' is empty
892}
893
894
895sub locate_config_files
896{
897    my ($file) = @_;
898
899    my @locations = ();
900
901    if (-e $file) {
902    # Clearly specified (most likely full filename)
903    # No need to hunt in 'etc' directories, return value unchanged
904    push(@locations,$file);
905    }
906    else {
907    # Check for collection specific one before looking in global GSDL 'etc'
908    if (defined $ENV{'GSDLCOLLECTDIR'} && $ENV{'GSDLCOLLECTDIR'} ne "") {
909        my $test_collect_etc_filename
910        = &util::filename_cat($ENV{'GSDLCOLLECTDIR'},"etc", $file);
911       
912        if (-e $test_collect_etc_filename) {
913        push(@locations,$test_collect_etc_filename);
914        }
915    }
916    my $test_main_etc_filename
917        = &util::filename_cat($ENV{'GSDLHOME'},"etc", $file);
918    if (-e $test_main_etc_filename) {
919        push(@locations,$test_main_etc_filename);
920    }
921    }
922
923    return \@locations;
924}
925
926
927sub hyperlink_text
928{
929    my ($text) = @_;
930   
931    $text =~ s/(http:\/\/[^\s]+)/<a href=\"$1\">$1<\/a>/mg;
932    $text =~ s/(^|\s+)(www\.(\w|\.)+)/<a href=\"http:\/\/$2\">$2<\/a>/mg;
933
934    return $text;
935}
936
937
938# A method to check if a directory is empty (note that an empty directory still has non-zero size!!!)
939# Code is from http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
940sub is_dir_empty
941{
942    my ($path) = @_;
943    opendir DIR, $path;
944    while(my $entry = readdir DIR) {
945        next if($entry =~ /^\.\.?$/);
946        closedir DIR;
947        return 0;
948    }
949    closedir DIR;
950    return 1;
951}
952
9531;
Note: See TracBrowser for help on using the browser.