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

Revision 18341, 27.2 KB (checked in by ak19, 10 years ago)

Moved use of MIME::base64 encoding method to unicode.pm

  • 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
996# Returns the given filename converted using either URL encoding or base64
997# encoding, as specified by $rename_method. If the given filename has no suffix
998# (if it is just the tailname), then $no_suffix should be some defined value.
999sub rename_file {
1000    my ($filename, $rename_method, $no_suffix)  = @_;
1001
1002    if(!$filename) { # undefined or empty string
1003    return $filename;
1004    }
1005
1006    # Replace spaces with underscore.
1007    # Do this first else it can go wrong below when getting tailname
1008    $filename =~ s/ /_/g;
1009
1010    # Should we do this????
1011    # DM safing would have replaced underscores with character entity &#095;
1012    $filename =~ s/&\#095;/_/g;
1013
1014    my ($tailname,$dirname,$suffix);
1015    if($no_suffix) { # given a tailname, no suffix
1016    $suffix = "";
1017    ($tailname,$dirname) = File::Basename::fileparse($filename);
1018    }
1019    else {
1020    ($tailname,$dirname,$suffix) = File::Basename::fileparse($filename, "\\.(?:[^\\.]+?)\$");
1021    }
1022
1023    if (!$rename_method) {
1024    print STDERR "WARNING: no file renaming method specified. Defaulting to using URL encoding...\n";
1025    # Debugging information
1026    my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
1027    print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
1028    }
1029
1030    if (!$rename_method || $rename_method eq "url") {
1031    $tailname = &unicode::url_encode($tailname);
1032    }
1033    elsif ($rename_method eq "base64") {
1034    $tailname = &unicode::base64_encode($tailname);
1035    $tailname =~ s/\s*//sg;      # for some reason it adds spaces not just at end but also in middle
1036    }
1037
1038    $filename = "$tailname$suffix";
1039    $filename = "$dirname$filename" if ($dirname ne "./" && $dirname ne ".\\");
1040
1041    return $filename;
1042}
1043
10441;
Note: See TracBrowser for help on using the browser.