source: main/trunk/greenstone2/perllib/util.pm@ 29810

Last change on this file since 29810 was 29810, checked in by ak19, 9 years ago

trying to connect filenames got in perl to filenames in the metadata file. For windows, there are 2 apis to teh filenames. ansi codepage, and unicode. perl only uses the ansi version. If the unicode filename can't be converted to ansi then you get teh garbled M33~1 type filename. We do GetLongPathName to get the real filename which is returned in unicode. so now, if the short name is the same as teh long name, then we assume its in ansi, and decode using locale, otherwise, assume its in unicode and don't need to decode. this seems to work on windows for the files I have. ned to do a bit more testing, then go back to mac and linux and make sure I haven't mucked them up.
  • Property svn:keywords set to Author Date Id Revision
File size: 60.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 strict;
29use FileUtils;
30
31use Encode;
32use Unicode::Normalize 'normalize';
33
34use File::Copy;
35use File::Basename;
36# Config for getting the perlpath in the recommended way, though it uses paths that are
37# hard-coded into the Config file that's generated upon configuring and compiling perl.
38# $^X works better in some cases to return the path to perl used to launch the script,
39# but if launched with plain "perl" (no full-path), that will be just what it returns.
40use Config;
41# New module for file related utility functions - intended as a
42# placeholder for an extension that allows a variety of different
43# filesystems (FTP, HTTP, SAMBA, WEBDav, HDFS etc)
44use FileUtils;
45
46if ($ENV{'GSDLOS'} =~ /^windows$/i) {
47 require Win32; # for working out Windows Long Filenames from Win 8.3 short filenames
48}
49
50# removes files (but not directories)
51sub rm {
52 warnings::warnif("deprecated", "util::rm() is deprecated, using FileUtils::removeFiles() instead");
53 return &FileUtils::removeFiles(@_);
54}
55
56# recursive removal
57sub filtered_rm_r {
58 warnings::warnif("deprecated", "util::filtered_rm_r() is deprecated, using FileUtils::removeFilesFiltered() instead");
59 return &FileUtils::removeFilesFiltered(@_);
60}
61
62# recursive removal
63sub rm_r {
64 warnings::warnif("deprecated", "util::rm_r() is deprecated, using FileUtils::removeFilesRecursive() instead");
65 return &FileUtils::removeFilesRecursive(@_);
66}
67
68# moves a file or a group of files
69sub mv {
70 warnings::warnif("deprecated", "util::mv() is deprecated, using FileUtils::moveFiles() instead");
71 return &FileUtils::moveFiles(@_);
72}
73
74# Move the contents of source directory into target directory
75# (as opposed to merely replacing target dir with the src dir)
76# This can overwrite any files with duplicate names in the target
77# but other files and folders in the target will continue to exist
78sub mv_dir_contents {
79 warnings::warnif("deprecated", "util::mv_dir_contents() is deprecated, using FileUtils::moveDirectoryContents() instead");
80 return &FileUtils::moveDirectoryContents(@_);
81}
82
83# copies a file or a group of files
84sub cp {
85 warnings::warnif("deprecated", "util::cp() is deprecated, using FileUtils::copyFiles() instead");
86 return &FileUtils::copyFiles(@_);
87}
88
89# recursively copies a file or group of files
90# syntax: cp_r (sourcefiles, destination directory)
91# destination must be a directory - to copy one file to
92# another use cp instead
93sub cp_r {
94 warnings::warnif("deprecated", "util::cp_r() is deprecated, using FileUtils::copyFilesrecursive() instead");
95 return &FileUtils::copyFilesRecursive(@_);
96}
97
98# recursively copies a file or group of files
99# syntax: cp_r (sourcefiles, destination directory)
100# destination must be a directory - to copy one file to
101# another use cp instead
102sub cp_r_nosvn {
103 warnings::warnif("deprecated", "util::cp_r_nosvn() is deprecated, using FileUtils::copyFilesRecursiveNoSVN() instead");
104 return &FileUtils::copyFilesRecursiveNoSVN(@_);
105}
106
107# copies a directory and its contents, excluding subdirectories, into a new directory
108sub cp_r_toplevel {
109 warnings::warnif("deprecated", "util::cp_r_toplevel() is deprecated, using FileUtils::recursiveCopyTopLevel() instead");
110 return &FileUtils::recursiveCopyTopLevel(@_);
111}
112
113sub mk_dir {
114 warnings::warnif("deprecated", "util::mk_dir() is deprecated, using FileUtils::makeDirectory() instead");
115 return &FileUtils::makeDirectory(@_);
116}
117
118# in case anyone cares - I did some testing (using perls Benchmark module)
119# on this subroutine against File::Path::mkpath (). mk_all_dir() is apparently
120# slightly faster (surprisingly) - Stefan.
121sub mk_all_dir {
122 warnings::warnif("deprecated", "util::mk_all_dir() is deprecated, using FileUtils::makeAllDirectories() instead");
123 return &FileUtils::makeAllDirectories(@_);
124}
125
126# make hard link to file if supported by OS, otherwise copy the file
127sub hard_link {
128 warnings::warnif("deprecated", "util::hard_link() is deprecated, using FileUtils::hardLink() instead");
129 return &FileUtils::hardLink(@_);
130}
131
132# make soft link to file if supported by OS, otherwise copy file
133sub soft_link {
134 warnings::warnif("deprecated", "util::soft_link() is deprecated, using FileUtils::softLink() instead");
135 return &FileUtils::softLink(@_);
136}
137
138# Primarily for filenames generated by processing
139# content of HTML files (which are mapped to UTF-8 internally)
140#
141# To turn this into an octet string that really exists on the file
142# system:
143# 1. don't need to do anything special for Unix-based systems
144# (as underlying file system is byte-code)
145# 2. need to map to short DOS filenames for Windows
146
147sub utf8_to_real_filename
148{
149 my ($utf8_filename) = @_;
150
151 my $real_filename;
152
153 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) {
154 require Win32;
155
156 print STDERR "***** utf8 filename = $utf8_filename\n\n\n";
157
158 my $unicode_filename = decode("utf8",$utf8_filename);
159 $real_filename = Win32::GetShortPathName($unicode_filename);
160 }
161 else {
162 $real_filename = $utf8_filename;
163 }
164
165 return $real_filename;
166}
167
168sub raw_filename_to_unicode
169{
170 my ($directory, $raw_file, $filename_encoding ) = @_;
171
172 my $unicode_filename = $raw_file;
173 print STDERR "&&&&&&&&&&&&&& raw file = $unicode_filename ".&unicode::debug_unicode_string($unicode_filename)."\n";
174 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) {
175 print STDERR "windows, upgrading...\n";
176 $unicode_filename = &util::get_dirsep_tail(&util::upgrade_if_dos_filename(&FileUtils::filenameConcatenate($directory, $raw_file), 0));
177
178
179 if ($unicode_filename eq $raw_file) {
180 print STDERR "long = original\n";
181 $unicode_filename = &Encode::decode(locale_fs => $unicode_filename);
182 } else {
183 print STDERR "long not equal original\n";
184 #$unicode_filename = &Encode::decode("UTF-16le" => $unicode_filename);
185 }
186
187 } else {
188 print STDERR "not windows, not upgrading. decoding in utf8\n";
189 $unicode_filename = &Encode::decode("utf-8", $unicode_filename);
190
191
192 }
193 #
194 #$unicode_filename = &Encode::decode("ascii", $unicode_filename);
195 #$unicode_filename = &Encode::decode(locale_fs => $unicode_filename);
196 print STDERR "after decoding = $unicode_filename ".&unicode::debug_unicode_string($unicode_filename)."\n";
197 #Does the filenaem have url encoded chars in it?
198 if (&unicode::is_url_encoded($unicode_filename)) {
199 $unicode_filename = &unicode::url_decode($unicode_filename);
200 }
201 print STDERR "after url decoding: $unicode_filename\n";
202 # Normalise the filename to canonical composition - on mac, filenames use decopmposed form for accented chars
203 if ($ENV{'GSDLOS'} =~ m/^darwin$/i) {
204 $unicode_filename = normalize('C', $unicode_filename); # Composed form 'C'
205 }
206 return $unicode_filename;
207
208}
209sub fd_exists {
210 warnings::warnif("deprecated", "util::fd_exists() is deprecated, using FileUtils::fileTest() instead");
211 return &FileUtils::fileTest(@_);
212}
213
214sub file_exists {
215 warnings::warnif("deprecated", "util::file_exists() is deprecated, using FileUtils::fileExists() instead");
216 return &FileUtils::fileExists(@_);
217}
218
219sub dir_exists {
220 warnings::warnif("deprecated", "util::dir_exists() is deprecated, using FileUtils::directoryExists() instead");
221 return &FileUtils::directoryExists(@_);
222}
223
224# updates a copy of a directory in some other part of the filesystem
225# verbosity settings are: 0=low, 1=normal, 2=high
226# both $fromdir and $todir should be absolute paths
227sub cachedir {
228 warnings::warnif("deprecated", "util::cachedir() is deprecated, using FileUtils::synchronizeDirectories() instead");
229 return &FileUtils::synchronizeDirectories(@_);
230}
231
232# this function returns -1 if either file is not found
233# assumes that $file1 and $file2 are absolute file names or
234# in the current directory
235# $file2 is allowed to be newer than $file1
236sub differentfiles {
237 warnings::warnif("deprecated", "util::differentfiles() is deprecated, using FileUtils::differentFiles() instead");
238 return &FileUtils::differentFiles(@_);
239}
240
241
242sub get_tmp_filename
243{
244 my $file_ext = shift(@_) || undef;
245
246 my $opt_dot_file_ext = "";
247 if (defined $file_ext) {
248 if ($file_ext !~ m/\./) {
249 # no dot, so needs one added in at start
250 $opt_dot_file_ext = ".$file_ext"
251 }
252 else {
253 # allow for "extensions" such as _metadata.txt to be handled
254 # gracefully
255 $opt_dot_file_ext = $file_ext;
256 }
257 }
258
259 my $tmpdir = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "tmp");
260 &FileUtils::makeAllDirectories ($tmpdir) unless -e $tmpdir;
261
262 my $count = 1000;
263 my $rand = int(rand $count);
264 my $full_tmp_filename = &FileUtils::filenameConcatenate($tmpdir, "F$rand$opt_dot_file_ext");
265
266 while (-e $full_tmp_filename) {
267 $rand = int(rand $count);
268 $full_tmp_filename = &FileUtils::filenameConcatenate($tmpdir, "F$rand$opt_dot_file_ext");
269 $count++;
270 }
271
272 return $full_tmp_filename;
273}
274
275# These 2 are "static" variables used by the get_timestamped_tmp_folder() subroutine below and
276# belong with that function. They help ensure the timestamped tmp folders generated are unique.
277my $previous_timestamp = undef;
278my $previous_timestamp_f = 0; # frequency
279
280sub get_timestamped_tmp_folder
281{
282
283 my $tmp_dirname;
284 if(defined $ENV{'GSDLCOLLECTDIR'}) {
285 $tmp_dirname = $ENV{'GSDLCOLLECTDIR'};
286 } elsif(defined $ENV{'GSDLHOME'}) {
287 $tmp_dirname = $ENV{'GSDLHOME'};
288 } else {
289 return undef;
290 }
291
292 $tmp_dirname = &FileUtils::filenameConcatenate($tmp_dirname, "tmp");
293 &FileUtils::makeDirectory($tmp_dirname) if (!-e $tmp_dirname);
294
295 # add the timestamp into the path otherwise we can run into problems
296 # if documents have the same name
297 my $timestamp = time;
298
299 if (!defined $previous_timestamp || ($timestamp > $previous_timestamp)) {
300 $previous_timestamp_f = 0;
301 $previous_timestamp = $timestamp;
302 } else {
303 $previous_timestamp_f++;
304 }
305
306 my $time_tmp_dirname = &FileUtils::filenameConcatenate($tmp_dirname, $timestamp);
307 $tmp_dirname = $time_tmp_dirname;
308 my $i = $previous_timestamp_f;
309
310 if($previous_timestamp_f > 0) {
311 $tmp_dirname = $time_tmp_dirname."_".$i;
312 $i++;
313 }
314 while (-e $tmp_dirname) {
315 $tmp_dirname = $time_tmp_dirname."_".$i;
316 $i++;
317 }
318 &FileUtils::makeDirectory($tmp_dirname);
319
320 return $tmp_dirname;
321}
322
323sub get_timestamped_tmp_filename_in_collection
324{
325
326 my ($input_filename, $output_ext) = @_;
327 # derive tmp filename from input filename
328 my ($tailname, $dirname, $suffix)
329 = &File::Basename::fileparse($input_filename, "\\.[^\\.]+\$");
330
331 # softlink to collection tmp dir
332 my $tmp_dirname = &util::get_timestamped_tmp_folder();
333 $tmp_dirname = $dirname unless defined $tmp_dirname;
334
335 # following two steps copied from ConvertBinaryFile
336 # do we need them?? can't use them as is, as they use plugin methods.
337
338 #$tailname = $self->SUPER::filepath_to_utf8($tailname) unless &unicode::check_is_utf8($tailname);
339
340 # URLEncode this since htmls with images where the html filename is utf8 don't seem
341 # to work on Windows (IE or Firefox), as browsers are looking for filesystem-encoded
342 # files on the filesystem.
343 #$tailname = &util::rename_file($tailname, $self->{'file_rename_method'}, "without_suffix");
344 if (defined $output_ext) {
345 $output_ext = ".$output_ext"; # add the dot
346 } else {
347 $output_ext = $suffix;
348 }
349 $output_ext= lc($output_ext);
350 my $tmp_filename = &FileUtils::filenameConcatenate($tmp_dirname, "$tailname$output_ext");
351
352 return $tmp_filename;
353}
354
355sub get_toplevel_tmp_dir
356{
357 return &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "tmp");
358}
359
360
361sub get_collectlevel_tmp_dir
362{
363 my $tmp_dirname = &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'}, "tmp");
364 &FileUtils::makeDirectory($tmp_dirname) if (!-e $tmp_dirname);
365
366 return $tmp_dirname;
367}
368
369
370sub filename_to_regex {
371 my $filename = shift (@_);
372
373 # need to make single backslashes double so that regex works
374 $filename =~ s/\\/\\\\/g; # if ($ENV{'GSDLOS'} =~ /^windows$/i);
375
376 # note that the first part of a substitution is a regex, so RE chars need to be escaped,
377 # the second part of a substitution is not a regex, so for e.g. full-stop can be specified literally
378 $filename =~ s/\./\\./g; # in case there are extensions/other full stops, escape them
379 $filename =~ s@\(@\\(@g; # escape brackets
380 $filename =~ s@\)@\\)@g; # escape brackets
381 $filename =~ s@\[@\\[@g; # escape brackets
382 $filename =~ s@\]@\\]@g; # escape brackets
383
384 return $filename;
385}
386
387sub unregex_filename {
388 my $filename = shift (@_);
389
390 # need to put doubled backslashes for regex back to single
391 $filename =~ s/\\\./\./g; # remove RE syntax for .
392 $filename =~ s@\\\(@(@g; # remove RE syntax for ( => "\(" turns into "("
393 $filename =~ s@\\\)@)@g; # remove RE syntax for ) => "\)" turns into ")"
394 $filename =~ s@\\\[@[@g; # remove RE syntax for [ => "\[" turns into "["
395 $filename =~ s@\\\]@]@g; # remove RE syntax for ] => "\]" turns into "]"
396
397 # \\ goes to \
398 # This is the last step in reverse mirroring the order of steps in filename_to_regex()
399 $filename =~ s/\\\\/\\/g; # remove RE syntax for \
400 return $filename;
401}
402
403sub filename_cat {
404 # I've disabled this warning for now, as every Greenstone perl
405 # script seems to make use of this function and so you drown in a
406 # sea of deprecated warnings [jmt12]
407# warnings::warnif("deprecated", "util::filename_cat() is deprecated, using FileUtils::filenameConcatenate() instead");
408 return &FileUtils::filenameConcatenate(@_);
409}
410
411
412sub _pathname_cat {
413 my $join_char = shift(@_);
414 my $first_path = shift(@_);
415 my (@pathnames) = @_;
416
417 # If first_path is not null or empty, then add it back into the list
418 if (defined $first_path && $first_path =~ /\S/) {
419 unshift(@pathnames, $first_path);
420 }
421
422 my $pathname = join($join_char, @pathnames);
423
424 # remove duplicate slashes
425 if ($join_char eq ";") {
426 $pathname =~ s/[\\\/]+/\\/g;
427 if ($^O eq "cygwin") {
428 # Once we've collapsed muliple (potentialy > 2) slashes
429 # For cygwin, actually want things double-backslahed
430 $pathname =~ s/\\/\\\\/g;
431 }
432
433 } else {
434 $pathname =~ s/[\/]+/\//g;
435 # DB: want a pathname abc\de.html to remain like this
436 }
437
438 return $pathname;
439}
440
441
442sub pathname_cat {
443 my (@pathnames) = @_;
444
445 my $join_char;
446 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) {
447 $join_char = ";";
448 } else {
449 $join_char = ":";
450 }
451 return _pathname_cat($join_char,@pathnames);
452}
453
454
455sub javapathname_cat {
456 my (@pathnames) = @_;
457
458 my $join_char;
459
460 # Unlike pathname_cat() above, not interested if running in a Cygwin environment
461 # This is because the java we run is actually a native Windows executable
462
463 if (($ENV{'GSDLOS'} =~ /^windows$/i)) {
464 $join_char = ";";
465 } else {
466 $join_char = ":";
467 }
468 return _pathname_cat($join_char,@pathnames);
469}
470
471
472sub makeFilenameJavaCygwinCompatible
473{
474 my ($java_filename) = @_;
475
476 if ($^O eq "cygwin") {
477 # To be used with a Java program, but under Cygwin
478 # Because the java binary that is native to Windows, need to
479 # convert the Cygwin paths (i.e. Unix style) to be Windows
480 # compatible
481
482 $java_filename = `cygpath -wp "$java_filename"`;
483 chomp($java_filename);
484 $java_filename =~ s%\\%\\\\%g;
485 }
486
487 return $java_filename;
488}
489
490sub tidy_up_oid {
491 my ($OID) = @_;
492 if ($OID =~ /[\.\/\\]/) {
493 print STDERR "Warning, identifier $OID contains periods or slashes(.\\\/), replacing them with _\n";
494 $OID =~ s/[\.\\\/]/_/g; #remove any periods
495 }
496 if ($OID =~ /^\s.*\s$/) {
497 print STDERR "Warning, identifier $OID starts or ends with whitespace. Removing it\n";
498 # remove starting and trailing whitespace
499 $OID =~ s/^\s+//;
500 $OID =~ s/\s+$//;
501 }
502 if ($OID =~ /^[\d]*$/) {
503 print STDERR "Warning, identifier $OID contains only digits. Prepending 'D'.\n";
504 $OID = "D" . $OID;
505 }
506
507 return $OID;
508}
509
510sub envvar_prepend {
511 my ($var,$val) = @_;
512
513 # 64 bit linux can't handle ";" as path separator, so make sure to set this to the right one for the OS
514## my $pathsep = (defined $ENV{'GSDLOS'} && $ENV{'GSDLOS'} !~ m/windows/) ? ":" : ";";
515
516 # Rewritten above to make ":" the default (Windows is the special
517 # case, anything else 'unusual' such as Solaris etc is Unix)
518 my $pathsep = (defined $ENV{'GSDLOS'} && (($ENV{'GSDLOS'} =~ m/windows/) && ($^O ne "cygwin"))) ? ";" : ":";
519
520 # do not prepend any value/path that's already in the environment variable
521
522 my $escaped_val = &filename_to_regex($val); # escape any backslashes and brackets for upcoming regex
523 if (!defined($ENV{$var})) {
524 $ENV{$var} = "$val";
525 }
526 elsif($ENV{$var} !~ m/$escaped_val/) {
527 $ENV{$var} = "$val".$pathsep.$ENV{$var};
528 }
529}
530
531sub envvar_append {
532 my ($var,$val) = @_;
533
534 # 64 bit linux can't handle ";" as path separator, so make sure to set this to the right one for the OS
535 my $pathsep = (defined $ENV{'GSDLOS'} && $ENV{'GSDLOS'} !~ m/windows/) ? ":" : ";";
536
537 # do not append any value/path that's already in the environment variable
538
539 my $escaped_val = &filename_to_regex($val); # escape any backslashes and brackets for upcoming regex
540 if (!defined($ENV{$var})) {
541 $ENV{$var} = "$val";
542 }
543 elsif($ENV{$var} !~ m/$escaped_val/) {
544 $ENV{$var} = $ENV{$var}.$pathsep."$val";
545 }
546}
547
548
549
550# splits a filename into a prefix and a tail extension using the tail_re, or
551# if that fails, splits on the file_extension . (dot)
552sub get_prefix_and_tail_by_regex {
553
554 my ($filename,$tail_re) = @_;
555
556 my ($file_prefix,$file_ext) = ($filename =~ m/^(.*?)($tail_re)$/);
557 if ((!defined $file_prefix) || (!defined $file_ext)) {
558 ($file_prefix,$file_ext) = ($filename =~ m/^(.*)(\..*?)$/);
559 }
560
561 return ($file_prefix,$file_ext);
562}
563
564# get full path and file only path from a base_dir (which may be empty) and
565# file (which may contain directories)
566sub get_full_filenames {
567 my ($base_dir, $file) = @_;
568
569# my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(0);
570# my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);
571# print STDERR "** Calling method: $lcfilename:$cline $cpackage->$csubr\n";
572
573
574 my $filename_full_path = $file;
575 # add on directory if present
576 $filename_full_path = &FileUtils::filenameConcatenate($base_dir, $file) if $base_dir =~ /\S/;
577
578 my $filename_no_path = $file;
579
580 # remove directory if present
581 $filename_no_path =~ s/^.*[\/\\]//;
582 return ($filename_full_path, $filename_no_path);
583}
584
585# returns the path of a file without the filename -- ie. the directory the file is in
586sub filename_head {
587 my $filename = shift(@_);
588
589 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) {
590 $filename =~ s/[^\\\\]*$//;
591 }
592 else {
593 $filename =~ s/[^\\\/]*$//;
594 }
595
596 return $filename;
597}
598
599
600
601# returns 1 if filename1 and filename2 point to the same
602# file or directory
603sub filenames_equal {
604 my ($filename1, $filename2) = @_;
605
606 # use filename_cat to clean up trailing slashes and
607 # multiple slashes
608 $filename1 = &FileUtils::filenameConcatenate($filename1);
609 $filename2 = &FileUtils::filenameConcatenate($filename2);
610
611 # filenames not case sensitive on windows
612 if ($ENV{'GSDLOS'} =~ /^windows$/i) {
613 $filename1 =~ tr/[A-Z]/[a-z]/;
614 $filename2 =~ tr/[A-Z]/[a-z]/;
615 }
616 return 1 if $filename1 eq $filename2;
617 return 0;
618}
619
620# If filename is relative to within_dir, returns the relative path of filename to that directory
621# with slashes in the filename returned as they were in the original (absolute) filename.
622sub filename_within_directory
623{
624 my ($filename,$within_dir) = @_;
625
626 if ($within_dir !~ m/[\/\\]$/) {
627 my $dirsep = &util::get_dirsep();
628 $within_dir .= $dirsep;
629 }
630
631 $within_dir = &filename_to_regex($within_dir); # escape DOS style file separator and brackets
632 if ($filename =~ m/^$within_dir(.*)$/) {
633 $filename = $1;
634 }
635
636 return $filename;
637}
638
639# If filename is relative to within_dir, returns the relative path of filename to that directory in URL format.
640# Filename and within_dir can be any type of slashes, but will be compared as URLs (i.e. unix-style slashes).
641# The subpath returned will also be a URL type filename.
642sub filename_within_directory_url_format
643{
644 my ($filename,$within_dir) = @_;
645
646 # convert parameters only to / slashes if Windows
647
648 my $filename_urlformat = &filepath_to_url_format($filename);
649 my $within_dir_urlformat = &filepath_to_url_format($within_dir);
650
651 #if ($within_dir_urlformat !~ m/\/$/) {
652 # make sure directory ends with a slash
653 #$within_dir_urlformat .= "/";
654 #}
655
656 my $within_dir_urlformat_re = &filename_to_regex($within_dir_urlformat); # escape any special RE characters, such as brackets
657
658 #print STDERR "@@@@@ $filename_urlformat =~ $within_dir_urlformat_re\n";
659
660 # dir prefix may or may not end with a slash (this is discarded when extracting the sub-filepath)
661 if ($filename_urlformat =~ m/^$within_dir_urlformat_re(?:\/)*(.*)$/) {
662 $filename_urlformat = $1;
663 }
664
665 return $filename_urlformat;
666}
667
668# Convert parameter to use / slashes if Windows (if on Linux leave any \ as is,
669# since on Linux it doesn't represent a file separator but an escape char).
670sub filepath_to_url_format
671{
672 my ($filepath) = @_;
673 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) {
674 # Only need to worry about Windows, as Unix style directories already in url-format
675 # Convert Windows style \ => /
676 $filepath =~ s@\\@/@g;
677 }
678 return $filepath;
679}
680
681# regex filepaths on windows may include \\ as path separator. Convert \\ to /
682sub filepath_regex_to_url_format
683{
684 my ($filepath) = @_;
685 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) {
686 # Only need to worry about Windows, as Unix style directories already in url-format
687 # Convert Windows style \\ => /
688 $filepath =~ s@\\\\@/@g;
689 }
690 return $filepath;
691
692}
693
694# Like File::Basename::fileparse, but expects filepath in url format (ie only / slash for dirsep)
695# and ignores trailing /
696# returns (file, dirs) dirs will be empty if no subdirs
697sub url_fileparse
698{
699 my ($filepath) = @_;
700 # remove trailing /
701 $filepath =~ s@/$@@;
702 if ($filepath !~ m@/@) {
703 return ($filepath, "");
704 }
705 my ($dirs, $file) = $filepath =~ m@(.+/)([^/]+)@;
706 return ($file, $dirs);
707
708}
709
710
711sub filename_within_collection
712{
713 my ($filename) = @_;
714
715 my $collect_dir = $ENV{'GSDLCOLLECTDIR'};
716
717 if (defined $collect_dir) {
718
719 # if from within GSDLCOLLECTDIR, then remove directory prefix
720 # so source_filename is realative to it. This is done to aid
721 # portability, i.e. the collection can be moved to somewhere
722 # else on the file system and the archives directory will still
723 # work. This is needed, for example in the applet version of
724 # GLI where GSDLHOME/collect on the server will be different to
725 # the collect directory of the remove user. Of course,
726 # GSDLCOLLECTDIR subsequently needs to be put back on to turn
727 # it back into a full pathname.
728
729 $filename = filename_within_directory($filename,$collect_dir);
730 }
731
732 return $filename;
733}
734
735sub prettyprint_file
736{
737 my ($base_dir,$file,$gli) = @_;
738
739 my $filename_full_path = &FileUtils::filenameConcatenate($base_dir,$file);
740
741 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) {
742 require Win32;
743
744 # For some reason base_dir in the form c:/a/b/c
745 # This leads to confusion later on, so turn it back into
746 # the more usual Windows form
747 $base_dir =~ s/\//\\/g;
748 my $long_base_dir = Win32::GetLongPathName($base_dir);
749 my $long_full_path = Win32::GetLongPathName($filename_full_path);
750
751 $file = filename_within_directory($long_full_path,$long_base_dir);
752 $file = encode("utf8",$file) if ($gli);
753 }
754
755 return $file;
756}
757
758
759sub upgrade_if_dos_filename
760{
761 my ($filename_full_path,$and_encode) = @_;
762
763 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) {
764 # Ensure any DOS-like filename, such as test~1.txt, has been upgraded
765 # to its long (Windows) version
766 my $long_filename = Win32::GetLongPathName($filename_full_path);
767 if (defined $long_filename) {
768
769print STDERR "long anme = $long_filename\n";
770
771 $filename_full_path = $long_filename;
772 }
773 # Make sure initial drive letter is lower-case (to fit in with rest of Greenstone)
774 $filename_full_path =~ s/^(.):/\u$1:/;
775
776 if ((defined $and_encode) && ($and_encode)) {
777 $filename_full_path = encode("utf8",$filename_full_path);
778 }
779 }
780
781 return $filename_full_path;
782}
783
784
785sub downgrade_if_dos_filename
786{
787 my ($filename_full_path) = @_;
788
789 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) {
790 require Win32;
791
792 # Ensure the given long Windows filename is in a form that can
793 # be opened by Perl => convert it to a short DOS-like filename
794
795 my $short_filename = Win32::GetShortPathName($filename_full_path);
796 if (defined $short_filename) {
797 $filename_full_path = $short_filename;
798 }
799 # Make sure initial drive letter is lower-case (to fit in
800 # with rest of Greenstone)
801 $filename_full_path =~ s/^(.):/\u$1:/;
802 }
803
804 return $filename_full_path;
805}
806
807sub block_filename
808{
809 my ($block_hash,$filename) = @_;
810
811 if (($ENV{'GSDLOS'} =~ m/^windows$/) && ($^O ne "cygwin")) {
812
813 # lower case the entire thing, eg for cover.jpg when its actually cover.JPG
814 my $lower_filename = lc($filename);
815 $block_hash->{'file_blocks'}->{$lower_filename} = 1;
816# my $lower_drive = $filename;
817# $lower_drive =~ s/^([A-Z]):/\l$1:/i;
818
819# my $upper_drive = $filename;
820# $upper_drive =~ s/^([A-Z]):/\u$1:/i;
821#
822# $block_hash->{'file_blocks'}->{$lower_drive} = 1;
823# $block_hash->{'file_blocks'}->{$upper_drive} = 1;
824 }
825 else {
826 $block_hash->{'file_blocks'}->{$filename} = 1;
827 }
828}
829
830
831sub filename_is_absolute
832{
833 warnings::warnif("deprecated", "util::filename_is_absolute() is deprecated, using FileUtils::isFilenameAbsolute() instead");
834 return &FileUtils::isFilenameAbsolute(@_);
835}
836
837
838## @method make_absolute()
839#
840# Ensure the given file path is absolute in respect to the given base path.
841#
842# @param $base_dir A string denoting the base path the given dir must be
843# absolute to.
844# @param $dir The directory to be made absolute as a string. Note that the
845# dir may already be absolute, in which case it will remain
846# unchanged.
847# @return The now absolute form of the directory as a string.
848#
849# @author John Thompson, DL Consulting Ltd.
850# @copy 2006 DL Consulting Ltd.
851#
852#used in buildcol.pl, doesn't work for all cases --kjdon
853sub make_absolute {
854
855 my ($base_dir, $dir) = @_;
856### print STDERR "dir = $dir\n";
857 $dir =~ s/[\\\/]+/\//g;
858 $dir = $base_dir . "/$dir" unless ($dir =~ m|^(\w:)?/|);
859 $dir =~ s|^/tmp_mnt||;
860 1 while($dir =~ s|/[^/]*/\.\./|/|g);
861 $dir =~ s|/[.][.]?/|/|g;
862 $dir =~ tr|/|/|s;
863### print STDERR "dir = $dir\n";
864
865 return $dir;
866}
867## make_absolute() ##
868
869sub get_dirsep {
870
871 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) {
872 return "\\";
873 } else {
874 return "\/";
875 }
876}
877
878sub get_os_dirsep {
879
880 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) {
881 return "\\\\";
882 } else {
883 return "\\\/";
884 }
885}
886
887sub get_re_dirsep {
888
889 return "\\\\|\\\/";
890}
891
892
893sub get_dirsep_tail {
894 my ($filename) = @_;
895
896 # returns last part of directory or filename
897 # On unix e.g. a/b.d => b.d
898 # a/b/c => c
899
900 my $dirsep = get_re_dirsep();
901 my @dirs = split (/$dirsep/, $filename);
902 my $tail = pop @dirs;
903
904 # - caused problems under windows
905 #my ($tail) = ($filename =~ m/^(?:.*?$dirsep)?(.*?)$/);
906
907 return $tail;
908}
909
910
911# if this is running on windows we want binaries to end in
912# .exe, otherwise they don't have to end in any extension
913sub get_os_exe {
914 return ".exe" if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin"));
915 return "";
916}
917
918
919# test to see whether this is a big or little endian machine
920sub is_little_endian
921{
922 # To determine the name of the operating system, the variable $^O is a cheap alternative to pulling it out of the Config module;
923 # 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
924 # Otherwise, it's little endian
925
926 #return 0 if $^O =~ /^darwin$/i;
927 #return 0 if $ENV{'GSDLOS'} =~ /^darwin$/i;
928
929 # Going back to stating exactly whether the machine is little endian
930 # or big endian, without any special case for Macs. Since for rata it comes
931 # back with little endian and for shuttle with bigendian.
932 return (ord(substr(pack("s",1), 0, 1)) == 1);
933}
934
935
936# will return the collection name if successful, "" otherwise
937sub use_collection {
938 my ($collection, $collectdir) = @_;
939
940 if (!defined $collectdir || $collectdir eq "") {
941 $collectdir = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "collect");
942 }
943
944 if (!defined $ENV{'GREENSTONEHOME'}) { # for GS3, would have been defined in use_site_collection, to GSDL3HOME
945 $ENV{'GREENSTONEHOME'} = $ENV{'GSDLHOME'};
946 }
947
948 # get and check the collection
949 if (!defined($collection) || $collection eq "") {
950 if (defined $ENV{'GSDLCOLLECTION'}) {
951 $collection = $ENV{'GSDLCOLLECTION'};
952 } else {
953 print STDOUT "No collection specified\n";
954 return "";
955 }
956 }
957
958 if ($collection eq "modelcol") {
959 print STDOUT "You can't use modelcol.\n";
960 return "";
961 }
962
963 # make sure the environment variables GSDLCOLLECTION and GSDLCOLLECTDIR
964 # are defined
965 $ENV{'GSDLCOLLECTION'} = $collection;
966 $ENV{'GSDLCOLLECTHOME'} = $collectdir;
967 $ENV{'GSDLCOLLECTDIR'} = &FileUtils::filenameConcatenate($collectdir, $collection);
968
969 # make sure this collection exists
970 if (!-e $ENV{'GSDLCOLLECTDIR'}) {
971 print STDOUT "Invalid collection ($collection).\n";
972 return "";
973 }
974
975 # everything is ready to go
976 return $collection;
977}
978
979sub get_current_collection_name {
980 return $ENV{'GSDLCOLLECTION'};
981}
982
983
984# will return the collection name if successful, "" otherwise.
985# Like use_collection (above) but for greenstone 3 (taking account of site level)
986
987sub use_site_collection {
988 my ($site, $collection, $collectdir) = @_;
989
990 if (!defined $collectdir || $collectdir eq "") {
991 die "GSDL3HOME not set.\n" unless defined $ENV{'GSDL3HOME'};
992 $collectdir = &FileUtils::filenameConcatenate($ENV{'GSDL3HOME'}, "sites", $site, "collect");
993 }
994
995 if (defined $ENV{'GSDL3HOME'}) {
996 $ENV{'GREENSTONEHOME'} = $ENV{'GSDL3HOME'};
997 $ENV{'SITEHOME'} = &FileUtils::filenameConcatenate($ENV{'GREENSTONEHOME'}, "sites", $site);
998 } elsif (defined $ENV{'GSDL3SRCHOME'}) {
999 $ENV{'GREENSTONEHOME'} = &FileUtils::filenameConcatenate($ENV{'GSDL3SRCHOME'}, "web");
1000 $ENV{'SITEHOME'} = &FileUtils::filenameConcatenate($ENV{'GREENSTONEHOME'}, "sites", $site);
1001 } else {
1002 print STDERR "*** util::use_site_collection(). Warning: Neither GSDL3HOME nor GSDL3SRCHOME set.\n";
1003 }
1004
1005 # collectdir explicitly set by this point (using $site variable if required).
1006 # Can call "old" gsdl2 use_collection now.
1007
1008 return use_collection($collection,$collectdir);
1009}
1010
1011
1012
1013sub locate_config_file
1014{
1015 my ($file) = @_;
1016
1017 my $locations = locate_config_files($file);
1018
1019 return shift @$locations; # returns undef if 'locations' is empty
1020}
1021
1022
1023sub locate_config_files
1024{
1025 my ($file) = @_;
1026
1027 my @locations = ();
1028
1029 if (-e $file) {
1030 # Clearly specified (most likely full filename)
1031 # No need to hunt in 'etc' directories, return value unchanged
1032 push(@locations,$file);
1033 }
1034 else {
1035 # Check for collection specific one before looking in global GSDL 'etc'
1036 if (defined $ENV{'GSDLCOLLECTDIR'} && $ENV{'GSDLCOLLECTDIR'} ne "") {
1037 my $test_collect_etc_filename
1038 = &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'},"etc", $file);
1039
1040 if (-e $test_collect_etc_filename) {
1041 push(@locations,$test_collect_etc_filename);
1042 }
1043 }
1044 my $test_main_etc_filename
1045 = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"etc", $file);
1046 if (-e $test_main_etc_filename) {
1047 push(@locations,$test_main_etc_filename);
1048 }
1049 }
1050
1051 return \@locations;
1052}
1053
1054
1055sub hyperlink_text
1056{
1057 my ($text) = @_;
1058
1059 $text =~ s/(http:\/\/[^\s]+)/<a href=\"$1\">$1<\/a>/mg;
1060 $text =~ s/(^|\s+)(www\.(\w|\.)+)/<a href=\"http:\/\/$2\">$2<\/a>/mg;
1061
1062 return $text;
1063}
1064
1065
1066# A method to check if a directory is empty (note that an empty directory still has non-zero size!!!)
1067# Code is from http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831
1068sub is_dir_empty {
1069 warnings::warnif("deprecated", "util::is_dir_empty() is deprecated, using FileUtils::isDirectoryEmpty() instead");
1070 return &FileUtils::isDirectoryEmpty(@_);
1071}
1072
1073# Returns the given filename converted using either URL encoding or base64
1074# encoding, as specified by $rename_method. If the given filename has no suffix
1075# (if it is just the tailname), then $no_suffix should be some defined value.
1076# rename_method can be url, none, base64
1077sub rename_file {
1078 my ($filename, $rename_method, $no_suffix) = @_;
1079
1080 if(!$filename) { # undefined or empty string
1081 return $filename;
1082 }
1083
1084 if (!$rename_method) {
1085 print STDERR "WARNING: no file renaming method specified. Defaulting to using URL encoding...\n";
1086 # Debugging information
1087 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
1088 # print STDERR "Called from method: $cfilename:$cline $cpackage->$csubr\n";
1089 $rename_method = "url";
1090 } elsif($rename_method eq "none") {
1091 return $filename; # would have already been renamed
1092 }
1093
1094 # No longer replace spaces with underscores, since underscores mess with incremental rebuild
1095 ### Replace spaces with underscore. Do this first else it can go wrong below when getting tailname
1096 ###$filename =~ s/ /_/g;
1097
1098 my ($tailname,$dirname,$suffix);
1099 if($no_suffix) { # given a tailname, no suffix
1100 ($tailname,$dirname) = File::Basename::fileparse($filename);
1101 }
1102 else {
1103 ($tailname,$dirname,$suffix) = File::Basename::fileparse($filename, "\\.(?:[^\\.]+?)\$");
1104 }
1105 if (!$suffix) {
1106 $suffix = "";
1107 }
1108 # This breaks GLI matching extracted metadata to files in Enrich panel, as
1109 # original is eg .JPG while gsdlsourcefilename ends up .jpg
1110 # Not sure why it was done in first place...
1111 #else {
1112 #$suffix = lc($suffix);
1113 #}
1114
1115 if ($rename_method eq "url") {
1116 $tailname = &unicode::url_encode($tailname);
1117 }
1118 elsif ($rename_method eq "base64") {
1119 $tailname = &unicode::base64_encode($tailname);
1120 $tailname =~ s/\s*//sg; # for some reason it adds spaces not just at end but also in middle
1121 }
1122
1123 $filename = "$tailname$suffix";
1124 $filename = "$dirname$filename" if ($dirname ne "./" && $dirname ne ".\\");
1125
1126 return $filename;
1127}
1128
1129
1130# BACKWARDS COMPATIBILITY: Just in case there are old .ldb/.bdb files
1131sub rename_ldb_or_bdb_file {
1132 my ($filename_no_ext) = @_;
1133
1134 my $new_filename = "$filename_no_ext.gdb";
1135 return if (-f $new_filename); # if the file has the right extension, don't need to do anything
1136 # try ldb
1137 my $old_filename = "$filename_no_ext.ldb";
1138
1139 if (-f $old_filename) {
1140 print STDERR "Renaming $old_filename to $new_filename\n";
1141 rename ($old_filename, $new_filename)
1142 || print STDERR "Rename failed: $!\n";
1143 return;
1144 }
1145 # try bdb
1146 $old_filename = "$filename_no_ext.bdb";
1147 if (-f $old_filename) {
1148 print STDERR "Renaming $old_filename to $new_filename\n";
1149 rename ($old_filename, $new_filename)
1150 || print STDERR "Rename failed: $!\n";
1151 return;
1152 }
1153}
1154
1155sub os_dir() {
1156
1157 my $gsdlarch = "";
1158 if(defined $ENV{'GSDLARCH'}) {
1159 $gsdlarch = $ENV{'GSDLARCH'};
1160 }
1161 return $ENV{'GSDLOS'}.$gsdlarch;
1162}
1163
1164# returns 1 if this (GS server) is a GS3 installation, returns 0 if it's GS2.
1165sub is_gs3() {
1166 if($ENV{'GSDL3SRCHOME'}) {
1167 return 1;
1168 } else {
1169 return 0;
1170 }
1171}
1172
1173# Returns the greenstone URL prefix extracted from the appropriate GS2/GS3 config file.
1174# By default, /greenstone3 for GS3 or /greenstone for GS2.
1175sub get_greenstone_url_prefix() {
1176 # if already set on a previous occasion, just return that
1177 # (Don't want to keep repeating this: cost of re-opening and scanning files.)
1178 return $ENV{'GREENSTONE_URL_PREFIX'} if($ENV{'GREENSTONE_URL_PREFIX'});
1179
1180 my ($configfile, $urlprefix, $defaultUrlprefix);
1181 my @propertynames = ();
1182
1183 if($ENV{'GSDL3SRCHOME'}) {
1184 $defaultUrlprefix = "/greenstone3";
1185 $configfile = &FileUtils::filenameConcatenate($ENV{'GSDL3SRCHOME'}, "packages", "tomcat", "conf", "Catalina", "localhost", "greenstone3.xml");
1186 push(@propertynames, qw/path\s*\=/);
1187 } else {
1188 $defaultUrlprefix = "/greenstone";
1189 $configfile = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "cgi-bin", &os_dir(), "gsdlsite.cfg");
1190 push(@propertynames, (qw/\nhttpprefix/, qw/\ngwcgi/)); # inspect one property then the other
1191 }
1192
1193 $urlprefix = &extract_propvalue_from_file($configfile, \@propertynames);
1194
1195 if(!$urlprefix) { # no values found for URL prefix, use default values
1196 $urlprefix = $defaultUrlprefix;
1197 } else {
1198 #gwcgi can contain more than the wanted prefix, we split on / to get the first "directory" level
1199 $urlprefix =~ s/^\///; # remove the starting slash
1200 my @dirs = split(/(\\|\/)/, $urlprefix);
1201 $urlprefix = shift(@dirs);
1202
1203 if($urlprefix !~ m/^\//) { # in all cases: ensure the required forward slash is at the front
1204 $urlprefix = "/$urlprefix";
1205 }
1206 }
1207
1208 # set for the future
1209 $ENV{'GREENSTONE_URL_PREFIX'} = $urlprefix;
1210# print STDERR "*** in get_greenstone_url_prefix(): $urlprefix\n\n";
1211 return $urlprefix;
1212}
1213
1214
1215
1216#
1217# The following comaes from activate.pl
1218#
1219# Designed to work with a server included with GS.
1220# - For GS3, we ask ant for the library URL.
1221# - For GS2, we derive the URL from the llssite.cfg file.
1222
1223sub get_full_greenstone_url_prefix
1224{
1225 # if already set on a previous occasion, just return that
1226 # (Don't want to keep repeating this: cost of re-opening and scanning files.)
1227 return $ENV{'GREENSTONE_URL_PREFIX'} if($ENV{'GREENSTONE_URL_PREFIX'});
1228
1229 my $gs_mode = ($ENV{'GSDL3SRCHOME'}) ? "gs3" : "gs2";
1230
1231 my $url = undef;
1232
1233 if($gs_mode eq "gs2") {
1234 my $llssite_cfg = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, "llssite.cfg");
1235
1236 if(-f $llssite_cfg) {
1237 # check llssite.cfg for line with url property
1238 # for server.exe also need to use portnumber and enterlib properties
1239
1240 # Read in the entire contents of the file in one hit
1241 if (!open (FIN, $llssite_cfg)) {
1242 print STDERR "util::get_library_URL() failed to open $llssite_cfg ($!)\n";
1243 return undef;
1244 }
1245
1246 my $contents;
1247 sysread(FIN, $contents, -s FIN);
1248 close(FIN);
1249
1250 my @lines = split(/[\n\r]+/, $contents); # split on carriage-returns and/or linefeeds
1251 my $enterlib = "";
1252 my $portnumber = ""; # will remain empty (implicit port 80) unless it's specifically been assigned
1253
1254 foreach my $line (@lines) {
1255 if($line =~ m/^url=(.*)$/) {
1256 $url = $1;
1257 } elsif($line =~ m/^enterlib=(.*)$/) {
1258 $enterlib = $1;
1259 } elsif($line =~ m/^portnumber=(.*)$/) {
1260 $portnumber = $1;
1261 }
1262 }
1263
1264 if(!$url) {
1265 return undef;
1266 }
1267 elsif($url eq "URL_pending") { # library is not running
1268 # do not process url=URL_pending in the file, since for server.exe
1269 # this just means the Enter Library button hasn't been pressed yet
1270 $url = undef;
1271 }
1272 else {
1273 # In the case of server.exe, need to do extra work to get the proper URL
1274 # But first, need to know whether we're indeed dealing with server.exe:
1275
1276 # compare the URL's domain to the full URL
1277 # E.g. for http://localhost:8383/greenstone3/cgi-bin, the domain is localhost:8383
1278 my $uri = URI->new( $url );
1279 my $host = $uri->host;
1280 #print STDERR "@@@@@ host: $host\n";
1281 if($url =~ m/http:\/\/$host(\/)?$/) {
1282 #if($url !~ m/http:\/\/$host:$portnumber(\/)?/ || $url =~ m/http:\/\/$host(\/)?$/) {
1283 # (if the URL does not contain the portnumber, OR if the port is implicitly 80 and)
1284 # If the domain with http:// prefix is completely the same as the URL, assume server.exe
1285 # then the actual URL is the result of suffixing the port and enterlib properties in llssite.cfg
1286 $url = $url.":".$portnumber.$enterlib;
1287 } # else, apache web server
1288
1289 }
1290 }
1291 } elsif($gs_mode eq "gs3") {
1292 # Either check build.properties for tomcat.server, tomcat.port and app.name (and default servlet name).
1293 # app.name is stored in app.path by build.xml. Need to move app.name in build.properties from build.xml
1294
1295 # Or, run the new target get-default-servlet-url
1296 # the output can look like:
1297 #
1298 # Buildfile: build.xml
1299 # [echo] os.name: Windows Vista
1300 #
1301 # get-default-servlet-url:
1302 # [echo] http://localhost:8383/greenstone3/library
1303 # BUILD SUCCESSFUL
1304 # Total time: 0 seconds
1305
1306 #my $output = qx/ant get-default-servlet-url/; # backtick operator, to get STDOUT (else 2>&1)
1307 # - see http://stackoverflow.com/questions/799968/whats-the-difference-between-perls-backticks-system-and-exec
1308
1309 # The get-default-servlet-url ant target can be run from anywhere by specifying the
1310 # location of GS3's ant build.xml buildfile. Activate.pl can be run from anywhere for GS3
1311 # GSDL3SRCHOME will be set for GS3 by gs3-setup.sh, a step that would have been necessary
1312 # to run the activate.pl script in the first place
1313
1314 my $full_build_xml = &FileUtils::javaFilenameConcatenate($ENV{'GSDL3SRCHOME'},"build.xml");
1315
1316 my $perl_command = "ant -buildfile \"$full_build_xml\" get-default-servlet-url";
1317
1318 if (open(PIN, "$perl_command |")) {
1319 while (defined (my $perl_output_line = <PIN>)) {
1320
1321 if($perl_output_line =~ m@http:\/\/(\S*)@) { # grab all the non-whitespace chars
1322 $url="http://".$1;
1323 }
1324 }
1325 close(PIN);
1326 } else {
1327 print STDERR "util::get_library_URL() failed to run $perl_command to work out library URL for $gs_mode\n";
1328 }
1329 }
1330
1331 # either the url is still undef or it is now set
1332 #print STDERR "\n@@@@@ final URL:|$url|\n" if $url;
1333 #print STDERR "\n@@@@@ URL still undef\n" if !$url;
1334
1335 $ENV{'FULL_GREENSTONE_URL_PREFIX'} = $url;
1336
1337 return $url;
1338}
1339
1340
1341# Given a config file (xml or java properties file) and a list/array of regular expressions
1342# that represent property names to match on, this function will return the value for the 1st
1343# matching property name. If the return value is undefined, no matching property was found.
1344sub extract_propvalue_from_file() {
1345 my ($configfile, $propertynames) = @_;
1346
1347 my $value;
1348 unless(open(FIN, "<$configfile")) {
1349 print STDERR "extract_propvalue_from_file(): Unable to open $configfile. $!\n";
1350 return $value; # not initialised
1351 }
1352
1353 # Read the entire file at once, as one single line, then close it
1354 my $filecontents;
1355 {
1356 local $/ = undef;
1357 $filecontents = <FIN>;
1358 }
1359 close(FIN);
1360
1361 foreach my $regex (@$propertynames) {
1362 ($value) = $filecontents=~ m/$regex\s*(\S*)/s; # read value of the property given by regex up to the 1st space
1363 if($value) {
1364 $value =~ s/^\"//; # remove any startquotes
1365 $value =~ s/\".*$//; # remove the 1st endquotes (if any) followed by any xml
1366 last; # found value for a matching property, break from loop
1367 }
1368 }
1369
1370 return $value;
1371}
1372
1373# Subroutine that sources setup.bash, given GSDLHOME and GSDLOS and
1374# given that perllib is in @INC in order to invoke this subroutine.
1375# Call as follows -- after setting up INC to include perllib and
1376# after setting up GSDLHOME and GSDLOS:
1377#
1378# require util;
1379# &util::setup_greenstone_env($ENV{'GSDLHOME'}, $ENV{'GSDLOS'});
1380#
1381sub setup_greenstone_env() {
1382 my ($GSDLHOME, $GSDLOS) = @_;
1383
1384 #my %env_map = ();
1385 # Get the localised ENV settings of running a localised source setup.bash
1386 # and put it into the ENV here. Need to clear GSDLHOME before running setup
1387 #my $perl_command = "(cd $GSDLHOME; export GSDLHOME=; . ./setup.bash > /dev/null; env)";
1388 my $perl_command = "(cd $GSDLHOME; /bin/bash -c \"export GSDLHOME=; source setup.bash > /dev/null; env\")";
1389 if (($GSDLOS =~ m/windows/i) && ($^O ne "cygwin")) {
1390 #$perl_command = "cmd /C \"cd $GSDLHOME&& set GSDLHOME=&& setup.bat > nul&& set\"";
1391 $perl_command = "(cd $GSDLHOME&& set GSDLHOME=&& setup.bat > nul&& set)";
1392 }
1393 if (!open(PIN, "$perl_command |")) {
1394 print STDERR ("Unable to execute command: $perl_command. $!\n");
1395 }
1396
1397 my $lastkey;
1398 while (defined (my $perl_output_line = <PIN>)) {
1399 my($key,$value) = ($perl_output_line =~ m/^([^=]*)[=](.*)$/);
1400 if(defined $key) {
1401 #$env_map{$key}=$value;
1402 $ENV{$key}=$value;
1403 $lastkey = $key;
1404 } elsif($lastkey && $perl_output_line !~ m/^\s*$/) {
1405 # there was no equals sign in $perl_output_line, so this
1406 # $perl_output_line may be a spillover from the previous
1407 $ENV{$lastkey} = $ENV{$lastkey}."\n".$perl_output_line;
1408 }
1409 }
1410 close (PIN);
1411
1412 # If any keys in $ENV don't occur in Greenstone's localised env
1413 # (stored in $env_map), delete those entries from $ENV
1414 #foreach $key (keys %ENV) {
1415 # if(!defined $env_map{$key}) {
1416 # print STDOUT "**** DELETING ENV KEY: $key\tVALUE: $ENV{$key}\n";
1417 # delete $ENV{$key}; # del $ENV(key, value) pair
1418 # }
1419 #}
1420 #undef %env_map;
1421}
1422
1423sub get_perl_exec() {
1424 my $perl_exec = $^X; # may return just "perl"
1425
1426 if($ENV{'PERLPATH'}) {
1427 # OR: # $perl_exec = &FileUtils::filenameConcatenate($ENV{'PERLPATH'},"perl");
1428 if (($ENV{'GSDLOS'} =~ m/windows/) && ($^O ne "cygwin")) {
1429 $perl_exec = "$ENV{'PERLPATH'}\\Perl.exe";
1430 } else {
1431 $perl_exec = "$ENV{'PERLPATH'}/perl";
1432 }
1433 } else { # no PERLPATH, use Config{perlpath} else $^X: special variables
1434 # containing the full path to the current perl executable we're using
1435 $perl_exec = $Config{perlpath}; # configured path for perl
1436 if (!-e $perl_exec) { # may not point to location on this machine
1437 $perl_exec = $^X; # may return just "perl"
1438 if($perl_exec =~ m/^perl/i) { # warn if just perl or Perl.exe
1439 print STDERR "**** WARNING: Perl exec found contains no path: $perl_exec";
1440 }
1441 }
1442 }
1443
1444 return $perl_exec;
1445}
1446
1447# returns the path to the java command in the JRE included with GS (if any),
1448# quoted to safeguard any spaces in this path, otherwise a simple java
1449# command is returned which assumes and will try for a system java.
1450sub get_java_command {
1451 my $java = "java";
1452 if(defined $ENV{'GSDLHOME'}) { # should be, as this script would be launched from the cmd line
1453 # after running setup.bat or from GLI which also runs setup.bat
1454 my $java_bin = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"packages","jre","bin");
1455 if(-d $java_bin) {
1456 $java = &FileUtils::filenameConcatenate($java_bin,"java");
1457 $java = "\"".$java."\""; # quoted to preserve spaces in path
1458 }
1459 }
1460 return $java;
1461}
1462
1463
1464# Given the qualified collection name (colgroup/collection),
1465# returns the collection and colgroup parts
1466sub get_collection_parts {
1467 # http://perldoc.perl.org/File/Basename.html
1468 # my($filename, $directories, $suffix) = fileparse($path);
1469 # "$directories contains everything up to and including the last directory separator in the $path
1470 # including the volume (if applicable). The remainder of the $path is the $filename."
1471 #my ($collection, $colgroup) = &File::Basename::fileparse($qualified_collection);
1472
1473 my $qualified_collection = shift(@_);
1474
1475 # Since activate.pl can be launched from the command-line, including by a user,
1476 # best not to assume colgroup uses URL-style slashes as would be the case with GLI
1477 # Also allow for the accidental inclusion of multiple slashes
1478 my ($colgroup, $collection) = split(/[\/\\]+/, $qualified_collection); #split('/', $qualified_collection);
1479
1480 if(!defined $collection) {
1481 $collection = $colgroup;
1482 $colgroup = "";
1483 }
1484 return ($collection, $colgroup);
1485}
1486
1487# work out the "collectdir/collection" location
1488sub resolve_collection_dir {
1489 my ($collect_dir, $qualified_collection, $site) = @_; #, $gs_mode
1490
1491 if (defined $ENV{'GSDLCOLLECTDIR'}) { # a predefined collection dir exists
1492 return $ENV{'GSDLCOLLECTDIR'};
1493 }
1494
1495 my ($colgroup, $collection) = &util::get_collection_parts($qualified_collection);
1496
1497 if (!defined $collect_dir || !$collect_dir) { # if undefined or empty string
1498 $collect_dir = &util::get_working_collect_dir($site);
1499 }
1500
1501 return &FileUtils::filenameConcatenate($collect_dir,$colgroup,$collection);
1502}
1503
1504# work out the full path to "collect" of this greenstone 2/3 installation
1505sub get_working_collect_dir {
1506 my ($site) = @_;
1507
1508 if (defined $ENV{'GSDLCOLLECTHOME'}) { # a predefined collect dir exists
1509 return $ENV{'GSDLCOLLECTHOME'};
1510 }
1511
1512 if (defined $site && $site) { # site non-empty, so get default collect dir for GS3
1513
1514 if (defined $ENV{'GSDL3HOME'}) {
1515 return &FileUtils::filenameConcatenate($ENV{'GSDL3HOME'},"sites",$site,"collect"); # web folder
1516 }
1517 elsif (defined $ENV{'GSDL3SRCHOME'}) {
1518 return &FileUtils::filenameConcatenate($ENV{'GSDL3SRCHOME'},"web","sites",$site,"collect");
1519 }
1520 }
1521
1522 elsif (defined $ENV{'SITEHOME'}) {
1523 return &FileUtils::filenameConcatenate($ENV{'SITEHOME'},"collect");
1524 }
1525
1526 else { # get default collect dir for GS2
1527 return &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"collect");
1528 }
1529}
1530
1531sub is_abs_path_any_os {
1532 my ($path) = @_;
1533
1534 # We can have filenames in our DBs that were produced on other OS, so this method exists
1535 # to help identify absolute paths in such cases.
1536
1537 return 1 if($path =~ m@^/@); # full paths begin with forward slash on linux/mac
1538 return 1 if($path =~ m@^([a-zA-Z]\:|\\)@); # full paths begin with drive letter colon for Win or \ for volume, http://stackoverflow.com/questions/13011013/get-only-volume-name-from-filepath
1539
1540 return 0;
1541}
1542
1543
1544# This subroutine is for improving portability of Greenstone collections from one OS to another,
1545# to be used to convert absolute paths going into db files into paths with placeholders instead.
1546# This sub works with util::get_common_gs_paths and takes a path to a greenstone file and, if it's
1547# an absolute path, then it will replace the longest matching greenstone-path prefix of the given
1548# path with a placeholder to match.
1549# The Greenstone-path prefixes that can be matched are the following common Greenstone paths:
1550# the path to the current (specific) collection, the path to the general GS collect directory,
1551# the path to the site directory if GS3, else the path to the GSDLHOME/GSDL3HOME folder.
1552# The longest matching prefix will be replaced with the equivalent placeholder:
1553# @THISCOLLECTPATH@, else @COLLECTHOME@, else @SITEHOME@, else @GSDLHOME@.
1554sub abspath_to_placeholders {
1555 my $path = shift(@_); # path to convert from absolute to one with placeholders
1556 my $opt_long_or_short_winfilenames = shift(@_) || "short"; # whether we want to force use of long file names even on windows, default uses short
1557
1558 return $path unless is_abs_path_any_os($path); # path is relative
1559
1560 if ($opt_long_or_short_winfilenames eq "long") {
1561 $path = &util::upgrade_if_dos_filename($path); # will only do something on windows
1562 }
1563
1564 # now we know we're dealing with absolute paths and have to replace gs prefixes with placeholders
1565 my @gs_paths = ($ENV{'GSDLCOLLECTDIR'}, $ENV{'GSDLCOLLECTHOME'}, $ENV{'SITEHOME'}, $ENV{'GREENSTONEHOME'}); # list in this order: from longest to shortest path
1566
1567 my %placeholder_map = ($ENV{'GREENSTONEHOME'} => '@GSDLHOME@', # can't use double-quotes around at-sign, else perl tries to evaluate it as referring to an array
1568 $ENV{'GSDLCOLLECTHOME'} => '@COLLECTHOME@',
1569 $ENV{'GSDLCOLLECTDIR'} => '@THISCOLLECTPATH@'
1570 );
1571 $placeholder_map{$ENV{'SITEHOME'}} = '@SITEHOME@' if defined $ENV{'SITEHOME'};
1572
1573 $path = &util::_abspath_to_placeholders($path, \@gs_paths, \%placeholder_map);
1574
1575 if ($ENV{'GSDLOS'} =~ /^windows$/i && $opt_long_or_short_winfilenames eq "short") {
1576 # for windows need to look for matches on short file names too
1577 # matched paths are again to be replaced with the usual placeholders
1578
1579 my $gsdlcollectdir = &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTDIR'});
1580 my $gsdlcollecthome = &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTHOME'});
1581 my $sitehome = (defined $ENV{'SITEHOME'}) ? &util::downgrade_if_dos_filename($ENV{'SITEHOME'}) : undef;
1582 my $greenstonehome = &util::downgrade_if_dos_filename($ENV{'GREENSTONEHOME'});
1583
1584 @gs_paths = ($gsdlcollectdir, $gsdlcollecthome, $sitehome, $greenstonehome); # order matters
1585
1586 %placeholder_map = ($greenstonehome => '@GSDLHOME@', # can't use double-quotes around at-sign, else perl tries to evaluate it as referring to an array
1587 $gsdlcollecthome => '@COLLECTHOME@',
1588 $gsdlcollectdir => '@THISCOLLECTPATH@'
1589 );
1590 $placeholder_map{$sitehome} = '@SITEHOME@' if defined $sitehome;
1591
1592 $path = &util::_abspath_to_placeholders($path, \@gs_paths, \%placeholder_map);
1593 }
1594
1595 return $path;
1596}
1597
1598sub _abspath_to_placeholders {
1599 my ($path, $gs_paths_ref, $placeholder_map_ref) = @_;
1600
1601 # The sequence of elements in @gs_paths matters
1602 # Need to loop starting from the *longest* matching path (the path to the specific collection)
1603 # to the shortest matching path (the path to gsdlhome/gsdl3home folder):
1604
1605 foreach my $gs_path (@$gs_paths_ref) {
1606 next if(!defined $gs_path); # site undefined for GS2
1607
1608 my $re_path = &util::filename_to_regex($gs_path); # escape for regex
1609
1610 if($path =~ m/^$re_path/i) { # case sensitive or not for OS?
1611
1612 my $placeholder = $placeholder_map_ref->{$gs_path}; # get the placeholder to replace the matched path with
1613
1614 $path =~ s/^$re_path/$placeholder/; #case sensitive or not?
1615 #$path =~ s/^[\\\/]//; # remove gs_path's trailing separator left behind at the start of the path
1616 # lowercase file extension, This is needed when shortfilenames are used, as case affects alphetical ordering, which affects diffcol
1617 $path =~ s/\.([A-Z]+)$/".".lc($1)/e;
1618 last; # done
1619 }
1620 }
1621
1622 return $path;
1623}
1624
1625# Function that does the reverse of the util::abspath_to_placeholders subroutine
1626# Once again, call this with the values returned from util::get_common_gs_paths
1627sub placeholders_to_abspath {
1628 my $path = shift(@_); # path that can contain placeholders to convert to resolved absolute path
1629 my $opt_long_or_short_winfilenames = shift(@_) || "short"; # whether we want to force use of long file names even on windows, default uses short
1630
1631 return $path if($path !~ m/@/); # path contains no placeholders
1632
1633 # replace placeholders with gs prefixes
1634 my @placeholders = ('@THISCOLLECTPATH@', '@COLLECTHOME@', '@SITEHOME@', '@GSDLHOME@'); # order of paths not crucial in this case,
1635 # but listed here from longest to shortest once placeholders are have been resolved
1636
1637 # can't use double-quotes around at-sign, else perl tries to evaluate it as referring to an array
1638 my %placeholder_to_gspath_map;
1639 if ($ENV{'GSDLOS'} =~ /^windows$/i && $opt_long_or_short_winfilenames eq "short") {
1640 # always replace placeholders with short file names of the absolute paths on windows?
1641 %placeholder_to_gspath_map = ('@GSDLHOME@' => &util::downgrade_if_dos_filename($ENV{'GREENSTONEHOME'}),
1642 '@COLLECTHOME@' => &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTHOME'}),
1643 '@THISCOLLECTPATH@' => &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTDIR'})
1644 );
1645 $placeholder_to_gspath_map{'@SITEHOME@'} = &util::downgrade_if_dos_filename($ENV{'SITEHOME'}) if defined $ENV{'SITEHOME'};
1646 } else {
1647 %placeholder_to_gspath_map = ('@GSDLHOME@' => $ENV{'GREENSTONEHOME'},
1648 '@SITEHOME@' => $ENV{'SITEHOME'}, # can be undef
1649 '@COLLECTHOME@' => $ENV{'GSDLCOLLECTHOME'},
1650 '@THISCOLLECTPATH@' => $ENV{'GSDLCOLLECTDIR'}
1651 ); # $placeholder_to_gspath_map{'@SITEHOME@'} = $ENV{'SITEHOME'} if defined $ENV{'SITEHOME'};
1652 }
1653
1654 foreach my $placeholder (@placeholders) {
1655 my $gs_path = $placeholder_to_gspath_map{$placeholder};
1656
1657 next if(!defined $gs_path); # sitehome for GS2 is undefined
1658
1659 if($path =~ m/^$placeholder/) {
1660 $path =~ s/^$placeholder/$gs_path/;
1661 last; # done
1662 }
1663 }
1664
1665 return $path;
1666}
1667
1668# Used by pdfpstoimg.pl and PDFBoxConverter to create a .item file from
1669# a directory containing sequentially numbered images.
1670sub create_itemfile
1671{
1672 my ($output_dir, $convert_basename, $convert_to) = @_;
1673 my $page_num = "";
1674
1675 opendir(DIR, $output_dir) || die "can't opendir $output_dir: $!";
1676 my @dir_files = grep {-f "$output_dir/$_"} readdir(DIR);
1677 closedir DIR;
1678
1679 # Sort files in the directory by page_num
1680 sub page_number {
1681 my ($dir) = @_;
1682 my ($pagenum) =($dir =~ m/^.*?[-\.]?(\d+)(\.(jpg|gif|png))?$/i);
1683# my ($pagenum) =($dir =~ m/(\d+)(\.(jpg|gif|png))?$/i); # this works but is not as safe/strict about input filepatterns as the above
1684
1685 $pagenum = 1 unless defined $pagenum;
1686 return $pagenum;
1687 }
1688
1689 # sort the files in the directory in the order of page_num rather than lexically.
1690 @dir_files = sort { page_number($a) <=> page_number($b) } @dir_files;
1691
1692 # work out if the numbering of the now sorted image files starts at 0 or not
1693 # by checking the number of the first _image_ file (skipping item files)
1694 my $starts_at_0 = 0;
1695 my $firstfile = ($dir_files[0] !~ /\.item$/i) ? $dir_files[0] : $dir_files[1];
1696 if(page_number($firstfile) == 0) { # 00 will evaluate to 0 too in this condition
1697 $starts_at_0 = 1;
1698 }
1699
1700 my $item_file = &FileUtils::filenameConcatenate($output_dir, $convert_basename.".item");
1701 my $item_fh;
1702 &FileUtils::openFileHandle($item_file, 'w', \$item_fh);
1703 print $item_fh "<PagedDocument>\n";
1704
1705 foreach my $file (@dir_files){
1706 if ($file !~ /\.item/i){
1707 $page_num = page_number($file);
1708 $page_num++ if $starts_at_0; # image numbers start at 0, so add 1
1709 print $item_fh " <Page pagenum=\"$page_num\" imgfile=\"$file\" txtfile=\"\"/>\n";
1710 }
1711 }
1712
1713 print $item_fh "</PagedDocument>\n";
1714 &FileUtils::closeFileHandle($item_file, \$item_fh);
1715 return $item_file;
1716}
1717
1718# Sets the gnomelib_env. Based on the logic in wvware.pl which can perhaps be replaced with a call to this function in future
1719sub set_gnomelib_env
1720{
1721 ## SET THE ENVIRONMENT AS DONE IN SETUP.BASH/BAT OF GNOME-LIB
1722 # Though this is only needed for darwin Lion at this point (and android, though that is untested)
1723
1724 my $libext = "so";
1725 if ($ENV{'GSDLOS'} =~ m/^windows$/i) {
1726 return;
1727 } elsif ($ENV{'GSDLOS'} =~ m/^darwin$/i) {
1728 $libext = "dylib";
1729 }
1730
1731 if (!defined $ENV{'GEXTGNOME'}) {
1732 ##print STDERR "@@@ Setting GEXTGNOME env\n";
1733
1734 my $gnome_dir = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"ext","gnome-lib-minimal");
1735
1736 if(! -d $gnome_dir) {
1737 $gnome_dir = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"ext","gnome-lib");
1738
1739 if(! -d $gnome_dir) {
1740 $gnome_dir = "";
1741 }
1742 }
1743
1744 # now set other the related env vars,
1745 # IF we've found the gnome-lib dir installed in the ext folder
1746
1747 if ($gnome_dir ne "" && -f &FileUtils::filenameConcatenate($gnome_dir, $ENV{'GSDLOS'}, "lib", "libiconv.$libext")) {
1748 $ENV{'GEXTGNOME'} = $gnome_dir;
1749 $ENV{'GEXTGNOME_INSTALLED'}=&FileUtils::filenameConcatenate($ENV{'GEXTGNOME'}, $ENV{'GSDLOS'});
1750
1751 my $gnomelib_bin = &FileUtils::filenameConcatenate($ENV{'GEXTGNOME_INSTALLED'}, "bin");
1752 if(-d $gnomelib_bin) { # no bin subfolder in GS binary's cutdown gnome-lib-minimal folder
1753 &util::envvar_prepend("PATH", $gnomelib_bin);
1754 }
1755
1756 # util's prepend will create LD/DYLD_LIB_PATH if it doesn't exist yet
1757 my $gextlib = &FileUtils::filenameConcatenate($ENV{'GEXTGNOME_INSTALLED'}, "lib");
1758
1759 if($ENV{'GSDLOS'} eq "linux") {
1760 &util::envvar_prepend("LD_LIBRARY_PATH", $gextlib);
1761 }
1762 elsif ($ENV{'GSDLOS'} eq "darwin") {
1763 #&util::envvar_prepend("DYLD_LIBRARY_PATH", $gextlib);
1764 &util::envvar_prepend("DYLD_FALLBACK_LIBRARY_PATH", $gextlib);
1765 }
1766 }
1767
1768 # Above largely mimics the setup.bash of the gnome-lib-minimal.
1769 # Not doing the devel-srcpack that gnome-lib-minimal's setup.bash used to set
1770 # Not exporting GSDLEXTS variable either
1771 }
1772
1773# print STDERR "@@@@@ GEXTGNOME: ".$ENV{'GEXTGNOME'}."\n\tINSTALL".$ENV{'GEXTGNOME_INSTALLED'}."\n";
1774# print STDERR "\tPATH".$ENV{'PATH'}."\n";
1775# print STDERR "\tLD_LIB_PATH".$ENV{'LD_LIBRARY_PATH'}."\n" if $ENV{'LD_LIBRARY_PATH};
1776# print STDERR "\tDYLD_FALLBACK_LIB_PATH".$ENV{'DYLD_FALLBACK_LIBRARY_PATH'}."\n" if $ENV{'DYLD_FALLBACK_LIBRARY_PATH};
1777
1778 # if no GEXTGNOME, maybe users didn't need gnome-lib to run gnomelib/libiconv dependent binaries like hashfile, suffix, wget
1779 # (wvware is launched in a gnomelib env from its own script, but could possibly go through this script in future)
1780}
1781
1782
1783
1784## @function augmentINC()
1785#
1786# Prepend a path (if it exists) onto INC but only if it isn't already in INC
1787# @param $new_path The path to add
1788# @author jmt12
1789#
1790sub augmentINC
1791{
1792 my ($new_path) = @_;
1793 my $did_add_path = 0;
1794 # might need to be replaced with FileUtils::directoryExists() call eventually
1795 if (-d $new_path)
1796 {
1797 my $did_find_path = 0;
1798 foreach my $existing_path (@INC)
1799 {
1800 if ($existing_path eq $new_path)
1801 {
1802 $did_find_path = 1;
1803 last;
1804 }
1805 }
1806 if (!$did_find_path)
1807 {
1808 unshift(@INC, $new_path);
1809 $did_add_path = 1;
1810 }
1811 }
1812 return $did_add_path;
1813}
1814## augmentINC()
1815
1816
18171;
Note: See TracBrowser for help on using the repository browser.