- Timestamp:
- 2019-03-04T13:51:49+13:00 (5 years ago)
- File:
-
- 1 edited
-
main/trunk/greenstone2/perllib/util.pm (modified) (43 diffs)
Legend:
- Unmodified
- Added
- Removed
-
main/trunk/greenstone2/perllib/util.pm
r32845 r32847 51 51 # removes files (but not directories) 52 52 sub rm { 53 warnings::warnif("deprecated", "util::rm() is deprecated, using FileUtils::removeFiles() instead");54 return &FileUtils::removeFiles(@_);53 warnings::warnif("deprecated", "util::rm() is deprecated, using FileUtils::removeFiles() instead"); 54 return &FileUtils::removeFiles(@_); 55 55 } 56 56 57 57 # recursive removal 58 58 sub filtered_rm_r { 59 warnings::warnif("deprecated", "util::filtered_rm_r() is deprecated, using FileUtils::removeFilesFiltered() instead");60 return &FileUtils::removeFilesFiltered(@_);59 warnings::warnif("deprecated", "util::filtered_rm_r() is deprecated, using FileUtils::removeFilesFiltered() instead"); 60 return &FileUtils::removeFilesFiltered(@_); 61 61 } 62 62 63 63 # recursive removal 64 64 sub rm_r { 65 warnings::warnif("deprecated", "util::rm_r() is deprecated, using FileUtils::removeFilesRecursive() instead");66 return &FileUtils::removeFilesRecursive(@_);65 warnings::warnif("deprecated", "util::rm_r() is deprecated, using FileUtils::removeFilesRecursive() instead"); 66 return &FileUtils::removeFilesRecursive(@_); 67 67 } 68 68 69 69 # moves a file or a group of files 70 70 sub mv { 71 warnings::warnif("deprecated", "util::mv() is deprecated, using FileUtils::moveFiles() instead");72 return &FileUtils::moveFiles(@_);71 warnings::warnif("deprecated", "util::mv() is deprecated, using FileUtils::moveFiles() instead"); 72 return &FileUtils::moveFiles(@_); 73 73 } 74 74 … … 78 78 # but other files and folders in the target will continue to exist 79 79 sub mv_dir_contents { 80 warnings::warnif("deprecated", "util::mv_dir_contents() is deprecated, using FileUtils::moveDirectoryContents() instead");81 return &FileUtils::moveDirectoryContents(@_);80 warnings::warnif("deprecated", "util::mv_dir_contents() is deprecated, using FileUtils::moveDirectoryContents() instead"); 81 return &FileUtils::moveDirectoryContents(@_); 82 82 } 83 83 84 84 # copies a file or a group of files 85 85 sub cp { 86 warnings::warnif("deprecated", "util::cp() is deprecated, using FileUtils::copyFiles() instead");87 return &FileUtils::copyFiles(@_);86 warnings::warnif("deprecated", "util::cp() is deprecated, using FileUtils::copyFiles() instead"); 87 return &FileUtils::copyFiles(@_); 88 88 } 89 89 … … 93 93 # another use cp instead 94 94 sub cp_r { 95 warnings::warnif("deprecated", "util::cp_r() is deprecated, using FileUtils::copyFilesrecursive() instead");96 return &FileUtils::copyFilesRecursive(@_);95 warnings::warnif("deprecated", "util::cp_r() is deprecated, using FileUtils::copyFilesrecursive() instead"); 96 return &FileUtils::copyFilesRecursive(@_); 97 97 } 98 98 … … 102 102 # another use cp instead 103 103 sub cp_r_nosvn { 104 warnings::warnif("deprecated", "util::cp_r_nosvn() is deprecated, using FileUtils::copyFilesRecursiveNoSVN() instead");105 return &FileUtils::copyFilesRecursiveNoSVN(@_);104 warnings::warnif("deprecated", "util::cp_r_nosvn() is deprecated, using FileUtils::copyFilesRecursiveNoSVN() instead"); 105 return &FileUtils::copyFilesRecursiveNoSVN(@_); 106 106 } 107 107 108 108 # copies a directory and its contents, excluding subdirectories, into a new directory 109 109 sub cp_r_toplevel { 110 warnings::warnif("deprecated", "util::cp_r_toplevel() is deprecated, using FileUtils::recursiveCopyTopLevel() instead");111 return &FileUtils::recursiveCopyTopLevel(@_);110 warnings::warnif("deprecated", "util::cp_r_toplevel() is deprecated, using FileUtils::recursiveCopyTopLevel() instead"); 111 return &FileUtils::recursiveCopyTopLevel(@_); 112 112 } 113 113 114 114 sub mk_dir { 115 warnings::warnif("deprecated", "util::mk_dir() is deprecated, using FileUtils::makeDirectory() instead");116 return &FileUtils::makeDirectory(@_);115 warnings::warnif("deprecated", "util::mk_dir() is deprecated, using FileUtils::makeDirectory() instead"); 116 return &FileUtils::makeDirectory(@_); 117 117 } 118 118 … … 121 121 # slightly faster (surprisingly) - Stefan. 122 122 sub mk_all_dir { 123 warnings::warnif("deprecated", "util::mk_all_dir() is deprecated, using FileUtils::makeAllDirectories() instead");124 return &FileUtils::makeAllDirectories(@_);123 warnings::warnif("deprecated", "util::mk_all_dir() is deprecated, using FileUtils::makeAllDirectories() instead"); 124 return &FileUtils::makeAllDirectories(@_); 125 125 } 126 126 127 127 # make hard link to file if supported by OS, otherwise copy the file 128 128 sub hard_link { 129 warnings::warnif("deprecated", "util::hard_link() is deprecated, using FileUtils::hardLink() instead");130 return &FileUtils::hardLink(@_);129 warnings::warnif("deprecated", "util::hard_link() is deprecated, using FileUtils::hardLink() instead"); 130 return &FileUtils::hardLink(@_); 131 131 } 132 132 133 133 # make soft link to file if supported by OS, otherwise copy file 134 134 sub soft_link { 135 warnings::warnif("deprecated", "util::soft_link() is deprecated, using FileUtils::softLink() instead");136 return &FileUtils::softLink(@_);135 warnings::warnif("deprecated", "util::soft_link() is deprecated, using FileUtils::softLink() instead"); 136 return &FileUtils::softLink(@_); 137 137 } 138 138 … … 167 167 sub raw_filename_to_unicode 168 168 { 169 my ($directory, $raw_file, $filename_encoding ) = @_; 170 171 my $unicode_filename = $raw_file; 172 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) { 173 # Try turning a short version to the long version 174 # If there are "funny" characters in the file name, that can't be represented in the ANSI code, then we will have a short weird version, eg E74~1.txt 175 $unicode_filename = &util::get_dirsep_tail(&util::upgrade_if_dos_filename(&FileUtils::filenameConcatenate($directory, $raw_file), 0)); 169 my ($directory, $raw_file, $filename_encoding ) = @_; 170 171 my $unicode_filename = $raw_file; 172 if (($ENV{'GSDLOS'} =~ m/^windows$/i) && ($^O ne "cygwin")) { 173 # Try turning a short version to the long version 174 # If there are "funny" characters in the file name, that can't be represented in the ANSI code, then we will have a short weird version, eg E74~1.txt 175 $unicode_filename = &util::get_dirsep_tail(&util::upgrade_if_dos_filename(&FileUtils::filenameConcatenate($directory, $raw_file), 0)); 176 177 178 if ($unicode_filename eq $raw_file) { 179 # This means the original filename *was* able to be encoded in the local ANSI file encoding (eg windows_1252), so now we turn it back to perl's unicode 176 180 177 178 if ($unicode_filename eq $raw_file) { 179 # This means the original filename *was* able to be encoded in the local ANSI file encoding (eg windows_1252), so now we turn it back to perl's unicode 180 181 $unicode_filename = &Encode::decode(locale_fs => $unicode_filename); 182 } 183 # else This means we did have one of the funny filenames. the getLongPathName (used in upgrade_if_dos_filename) will return unicode, so we don't need to do anything more. 184 185 186 } else { 187 # we had a utf-8 string, turn it into perl internal unicode 188 $unicode_filename = &Encode::decode("utf-8", $unicode_filename); 189 190 191 } 192 #Does the filename have url encoded chars in it? 193 if (&unicode::is_url_encoded($unicode_filename)) { 194 $unicode_filename = &unicode::url_decode($unicode_filename); 195 } 196 197 # Normalise the filename to canonical composition - on mac, filenames use decopmposed form for accented chars 198 if ($ENV{'GSDLOS'} =~ m/^darwin$/i) { 199 $unicode_filename = normalize('C', $unicode_filename); # Composed form 'C' 200 } 201 return $unicode_filename; 181 $unicode_filename = &Encode::decode(locale_fs => $unicode_filename); 182 } 183 # else This means we did have one of the funny filenames. the getLongPathName (used in upgrade_if_dos_filename) will return unicode, so we don't need to do anything more. 184 185 186 } else { 187 # we had a utf-8 string, turn it into perl internal unicode 188 $unicode_filename = &Encode::decode("utf-8", $unicode_filename); 189 190 191 } 192 #Does the filename have url encoded chars in it? 193 if (&unicode::is_url_encoded($unicode_filename)) { 194 $unicode_filename = &unicode::url_decode($unicode_filename); 195 } 196 197 # Normalise the filename to canonical composition - on mac, filenames use decopmposed form for accented chars 198 if ($ENV{'GSDLOS'} =~ m/^darwin$/i) { 199 $unicode_filename = normalize('C', $unicode_filename); # Composed form 'C' 200 } 201 return $unicode_filename; 202 202 203 203 } 204 204 sub fd_exists { 205 warnings::warnif("deprecated", "util::fd_exists() is deprecated, using FileUtils::fileTest() instead");206 return &FileUtils::fileTest(@_);205 warnings::warnif("deprecated", "util::fd_exists() is deprecated, using FileUtils::fileTest() instead"); 206 return &FileUtils::fileTest(@_); 207 207 } 208 208 209 209 sub file_exists { 210 warnings::warnif("deprecated", "util::file_exists() is deprecated, using FileUtils::fileExists() instead");211 return &FileUtils::fileExists(@_);210 warnings::warnif("deprecated", "util::file_exists() is deprecated, using FileUtils::fileExists() instead"); 211 return &FileUtils::fileExists(@_); 212 212 } 213 213 214 214 sub dir_exists { 215 warnings::warnif("deprecated", "util::dir_exists() is deprecated, using FileUtils::directoryExists() instead");216 return &FileUtils::directoryExists(@_);215 warnings::warnif("deprecated", "util::dir_exists() is deprecated, using FileUtils::directoryExists() instead"); 216 return &FileUtils::directoryExists(@_); 217 217 } 218 218 … … 221 221 # both $fromdir and $todir should be absolute paths 222 222 sub cachedir { 223 warnings::warnif("deprecated", "util::cachedir() is deprecated, using FileUtils::synchronizeDirectories() instead");224 return &FileUtils::synchronizeDirectories(@_);223 warnings::warnif("deprecated", "util::cachedir() is deprecated, using FileUtils::synchronizeDirectories() instead"); 224 return &FileUtils::synchronizeDirectories(@_); 225 225 } 226 226 … … 230 230 # $file2 is allowed to be newer than $file1 231 231 sub differentfiles { 232 warnings::warnif("deprecated", "util::differentfiles() is deprecated, using FileUtils::differentFiles() instead");233 return &FileUtils::differentFiles(@_);232 warnings::warnif("deprecated", "util::differentfiles() is deprecated, using FileUtils::differentFiles() instead"); 233 return &FileUtils::differentFiles(@_); 234 234 } 235 235 … … 239 239 sub determine_tmp_dir 240 240 { 241 242 243 244 245 246 247 241 my $try_collect_dir = shift(@_) || 0; 242 243 my $tmp_dirname; 244 if(defined $ENV{'GS_TMP_OUTPUT_DIR'}) { 245 $tmp_dirname = $ENV{'GS_TMP_OUTPUT_DIR'}; 246 } elsif($try_collect_dir && defined $ENV{'GSDLCOLLECTDIR'}) { 247 $tmp_dirname = $ENV{'GSDLCOLLECTDIR'}; 248 248 } elsif(defined $ENV{'GSDLHOME'}) { 249 249 $tmp_dirname = $ENV{'GSDLHOME'}; 250 250 } else { 251 252 } 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 251 return undef; 252 } 253 254 if(!defined $ENV{'GS_TMP_OUTPUT_DIR'}) { 255 # test the tmp_dirname folder is writable, by trying to write out a file 256 # Unfortunately, cound not get if(-w $dirname) to work on directories on Windows 257 ## http://alvinalexander.com/blog/post/perl/perl-file-test-operators-reference-cheat-sheet (test file/dir writable) 258 ## http://www.makelinux.net/alp/083 (real and effective user IDs) 259 260 my $tmp_test_file = &FileUtils::filenameConcatenate($tmp_dirname, "writability_test.tmp"); 261 if (open (FOUT, ">$tmp_test_file")) { 262 close(FOUT); 263 &FileUtils::removeFiles($tmp_test_file); 264 } else { # location not writable, use TMP location 265 if (defined $ENV{'TMP'}) { 266 $tmp_dirname = $ENV{'TMP'}; 267 } else { 268 $tmp_dirname = "/tmp"; 269 } 270 $tmp_dirname = &FileUtils::filenameConcatenate($tmp_dirname, "greenstone"); 271 $ENV{'GS_TMP_OUTPUT_DIR'} = $tmp_dirname; # store for next time 272 } 273 } 274 275 $tmp_dirname = &FileUtils::filenameConcatenate($tmp_dirname, "tmp"); 276 &FileUtils::makeAllDirectories ($tmp_dirname) unless -e $tmp_dirname; 277 278 return $tmp_dirname; 279 279 } 280 280 … … 296 296 } 297 297 298 298 my $tmpdir = &util::determine_tmp_dir(0); 299 299 300 300 my $count = 1000; … … 318 318 sub get_timestamped_tmp_folder 319 319 { 320 321 320 my $tmp_dirname = &util::determine_tmp_dir(1); 321 322 322 # add the timestamp into the path otherwise we can run into problems 323 323 # if documents have the same name 324 324 my $timestamp = time; 325 326 327 328 329 330 331 332 325 326 if (!defined $previous_timestamp || ($timestamp > $previous_timestamp)) { 327 $previous_timestamp_f = 0; 328 $previous_timestamp = $timestamp; 329 } else { 330 $previous_timestamp_f++; 331 } 332 333 333 my $time_tmp_dirname = &FileUtils::filenameConcatenate($tmp_dirname, $timestamp); 334 334 $tmp_dirname = $time_tmp_dirname; 335 335 my $i = $previous_timestamp_f; 336 337 338 339 340 336 337 if($previous_timestamp_f > 0) { 338 $tmp_dirname = $time_tmp_dirname."_".$i; 339 $i++; 340 } 341 341 while (-e $tmp_dirname) { 342 342 $tmp_dirname = $time_tmp_dirname."_".$i; … … 408 408 # need to make single backslashes double so that regex works 409 409 $filename =~ s/\\/\\\\/g; # if ($ENV{'GSDLOS'} =~ /^windows$/i); 410 410 411 411 # note that the first part of a substitution is a regex, so RE chars need to be escaped, 412 412 # the second part of a substitution is not a regex, so for e.g. full-stop can be specified literally 413 414 415 416 417 418 413 $filename =~ s/\./\\./g; # in case there are extensions/other full stops, escape them 414 $filename =~ s@\(@\\(@g; # escape brackets 415 $filename =~ s@\)@\\)@g; # escape brackets 416 $filename =~ s@\[@\\[@g; # escape brackets 417 $filename =~ s@\]@\\]@g; # escape brackets 418 419 419 return $filename; 420 420 } … … 424 424 425 425 # need to put doubled backslashes for regex back to single 426 427 428 429 430 431 432 433 434 426 $filename =~ s/\\\./\./g; # remove RE syntax for . 427 $filename =~ s@\\\(@(@g; # remove RE syntax for ( => "\(" turns into "(" 428 $filename =~ s@\\\)@)@g; # remove RE syntax for ) => "\)" turns into ")" 429 $filename =~ s@\\\[@[@g; # remove RE syntax for [ => "\[" turns into "[" 430 $filename =~ s@\\\]@]@g; # remove RE syntax for ] => "\]" turns into "]" 431 432 # \\ goes to \ 433 # This is the last step in reverse mirroring the order of steps in filename_to_regex() 434 $filename =~ s/\\\\/\\/g; # remove RE syntax for \ 435 435 return $filename; 436 436 } 437 437 438 438 sub filename_cat { 439 # I've disabled this warning for now, as every Greenstone perl440 # script seems to make use of this function and so you drown in a441 # sea of deprecated warnings [jmt12]442 # warnings::warnif("deprecated", "util::filename_cat() is deprecated, using FileUtils::filenameConcatenate() instead");443 return &FileUtils::filenameConcatenate(@_);439 # I've disabled this warning for now, as every Greenstone perl 440 # script seems to make use of this function and so you drown in a 441 # sea of deprecated warnings [jmt12] 442 # warnings::warnif("deprecated", "util::filename_cat() is deprecated, using FileUtils::filenameConcatenate() instead"); 443 return &FileUtils::filenameConcatenate(@_); 444 444 } 445 445 … … 547 547 548 548 # 64 bit linux can't handle ";" as path separator, so make sure to set this to the right one for the OS 549 ## my $pathsep = (defined $ENV{'GSDLOS'} && $ENV{'GSDLOS'} !~ m/windows/) ? ":" : ";";549 ## my $pathsep = (defined $ENV{'GSDLOS'} && $ENV{'GSDLOS'} !~ m/windows/) ? ":" : ";"; 550 550 551 551 # Rewritten above to make ":" the default (Windows is the special … … 632 632 my ($base_dir, $file) = @_; 633 633 634 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(0);635 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/);636 # print STDERR "** Calling method: $lcfilename:$cline $cpackage->$csubr\n";634 # my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(0); 635 # my ($lcfilename) = ($cfilename =~ m/([^\\\/]*)$/); 636 # print STDERR "** Calling method: $lcfilename:$cline $cpackage->$csubr\n"; 637 637 638 638 … … 727 727 $within_dir .= $dirsep; 728 728 } 729 730 729 730 $within_dir = &filename_to_regex($within_dir); # escape DOS style file separator and brackets 731 731 if ($filename =~ m/^$within_dir(.*)$/) { 732 732 $filename = $1; … … 742 742 { 743 743 my ($filename,$within_dir) = @_; 744 745 746 747 748 749 750 751 752 744 745 # convert parameters only to / slashes if Windows 746 747 my $filename_urlformat = &filepath_to_url_format($filename); 748 my $within_dir_urlformat = &filepath_to_url_format($within_dir); 749 750 #if ($within_dir_urlformat !~ m/\/$/) { 751 # make sure directory ends with a slash 752 #$within_dir_urlformat .= "/"; 753 753 #} 754 755 756 757 758 759 754 755 my $within_dir_urlformat_re = &filename_to_regex($within_dir_urlformat); # escape any special RE characters, such as brackets 756 757 #print STDERR "@@@@@ $filename_urlformat =~ $within_dir_urlformat_re\n"; 758 759 # dir prefix may or may not end with a slash (this is discarded when extracting the sub-filepath) 760 760 if ($filename_urlformat =~ m/^$within_dir_urlformat_re(?:\/)*(.*)$/) { 761 761 $filename_urlformat = $1; 762 762 } 763 763 … … 769 769 sub filepath_to_url_format 770 770 { 771 772 773 774 775 776 777 771 my ($filepath) = @_; 772 if (($ENV{'GSDLOS'} =~ /^windows$/i) && ($^O ne "cygwin")) { 773 # Only need to worry about Windows, as Unix style directories already in url-format 774 # Convert Windows style \ => / 775 $filepath =~ s@\\@/@g; 776 } 777 return $filepath; 778 778 } 779 779 … … 804 804 my ($dirs, $file) = $filepath =~ m@(.+/)([^/]+)@; 805 805 return ($file, $dirs); 806 806 807 807 } 808 808 … … 866 866 867 867 if (-e $filename_full_path) { 868 my $long_filename = Win32::GetLongPathName($filename_full_path);869 if (defined $long_filename) {868 my $long_filename = Win32::GetLongPathName($filename_full_path); 869 if (defined $long_filename) { 870 870 871 872 }871 $filename_full_path = $long_filename; 872 } 873 873 } else { 874 875 my ($tailname, $dirname, $suffix)876 877 878 874 875 my ($tailname, $dirname, $suffix) 876 = &File::Basename::fileparse($filename_full_path, "\\.[^\\.]+\$"); 877 my $long_dirname = Win32::GetLongPathName($dirname); 878 if (defined $long_dirname) { 879 879 $filename_full_path = &FileUtils::filenameConcatenate($long_dirname, "$tailname$suffix"); 880 880 } 881 881 } 882 882 … … 901 901 # Ensure the given long Windows filename is in a form that can 902 902 # be opened by Perl => convert it to a short DOS-like filename 903 904 905 my $short_filename = Win32::GetShortPathName($filename_full_path);906 if (defined $short_filename) {907 908 }903 # GetShortPathName doesn't work if the file doesn't exist - in this case, use the directory instead 904 if (-e $filename_full_path) { 905 my $short_filename = Win32::GetShortPathName($filename_full_path); 906 if (defined $short_filename) { 907 $filename_full_path = $short_filename; 908 } 909 909 } else { 910 my ($tailname, $dirname, $suffix)911 912 913 910 my ($tailname, $dirname, $suffix) 911 = &File::Basename::fileparse($filename_full_path, "\\.[^\\.]+\$"); 912 my $short_dirname = Win32::GetShortPathName($dirname); 913 if (defined $short_dirname) { 914 914 $filename_full_path = &FileUtils::filenameConcatenate($short_dirname, "$tailname$suffix"); 915 916 915 } 916 917 917 } 918 918 # Make sure initial drive letter is lower-case (to fit in … … 927 927 sub filename_is_absolute 928 928 { 929 warnings::warnif("deprecated", "util::filename_is_absolute() is deprecated, using FileUtils::isFilenameAbsolute() instead");930 return &FileUtils::isFilenameAbsolute(@_);929 warnings::warnif("deprecated", "util::filename_is_absolute() is deprecated, using FileUtils::isFilenameAbsolute() instead"); 930 return &FileUtils::isFilenameAbsolute(@_); 931 931 } 932 932 … … 950 950 951 951 my ($base_dir, $dir) = @_; 952 ### print STDERR "dir = $dir\n";952 ### print STDERR "dir = $dir\n"; 953 953 $dir =~ s/[\\\/]+/\//g; 954 954 $dir = $base_dir . "/$dir" unless ($dir =~ m|^(\w:)?/|); … … 957 957 $dir =~ s|/[.][.]?/|/|g; 958 958 $dir =~ tr|/|/|s; 959 ### print STDERR "dir = $dir\n";959 ### print STDERR "dir = $dir\n"; 960 960 961 961 return $dir; … … 1039 1039 1040 1040 if (!defined $ENV{'GREENSTONEHOME'}) { # for GS3, would have been defined in use_site_collection, to GSDL3HOME 1041 1041 $ENV{'GREENSTONEHOME'} = $ENV{'GSDLHOME'}; 1042 1042 } 1043 1043 … … 1163 1163 # Code is from http://episteme.arstechnica.com/eve/forums/a/tpc/f/6330927813/m/436007700831 1164 1164 sub is_dir_empty { 1165 warnings::warnif("deprecated", "util::is_dir_empty() is deprecated, using FileUtils::isDirectoryEmpty() instead");1166 return &FileUtils::isDirectoryEmpty(@_);1165 warnings::warnif("deprecated", "util::is_dir_empty() is deprecated, using FileUtils::isDirectoryEmpty() instead"); 1166 return &FileUtils::isDirectoryEmpty(@_); 1167 1167 } 1168 1168 … … 1206 1206 # Not sure why it was done in first place... 1207 1207 #else { 1208 1208 #$suffix = lc($suffix); 1209 1209 #} 1210 1210 … … 1304 1304 # set for the future 1305 1305 $ENV{'GREENSTONE_URL_PREFIX'} = $urlprefix; 1306 # print STDERR "*** in get_greenstone_url_prefix(): $urlprefix\n\n";1306 # print STDERR "*** in get_greenstone_url_prefix(): $urlprefix\n\n"; 1307 1307 return $urlprefix; 1308 1308 } … … 1322 1322 sub get_full_greenstone_url_prefix 1323 1323 { 1324 1325 1324 my ($gs_mode, $lib_name, $get_public_url) = @_; 1325 1326 1326 # if already set on a previous occasion, just return that 1327 1327 # (Don't want to keep repeating this: cost of re-opening and scanning files.) 1328 1328 return $ENV{'FULL_GREENSTONE_URL_PREFIX'} if($ENV{'FULL_GREENSTONE_URL_PREFIX'}); 1329 1329 1330 1330 # set gs_mode if it was not passed in (servercontrol.pm would pass it in, any other callers won't) 1331 1331 $gs_mode = ($ENV{'GSDL3SRCHOME'}) ? "gs3" : "gs2" unless defined $gs_mode; 1332 1332 1333 1333 my $url = undef; 1334 1334 … … 1429 1429 } 1430 1430 close(PIN); 1431 1431 1432 1432 # url can be undef if tomcat.port could not be determined due to 1433 1433 # user having wrong or conflicting server related vals in build.props 1434 1435 1436 1437 1434 if (defined $url && defined $lib_name && $lib_name ne "") { 1435 # replace the servlet_name portion of the url found, with the given library_name 1436 $url =~ s@/[^/]*$@/$lib_name@; 1437 } 1438 1438 } else { 1439 1439 print STDERR "util::get_full_greenstone_url_prefix() failed to run $perl_command to work out library URL for $gs_mode\n"; … … 1492 1492 # 1493 1493 sub setup_greenstone_env() { 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1494 my ($GSDLHOME, $GSDLOS) = @_; 1495 1496 #my %env_map = (); 1497 # Get the localised ENV settings of running a localised source setup.bash 1498 # and put it into the ENV here. Need to clear GSDLHOME before running setup 1499 #my $perl_command = "(cd $GSDLHOME; export GSDLHOME=; . ./setup.bash > /dev/null; env)"; 1500 my $perl_command = "(cd $GSDLHOME; /bin/bash -c \"export GSDLHOME=; source setup.bash > /dev/null; env\")"; 1501 if (($GSDLOS =~ m/windows/i) && ($^O ne "cygwin")) { 1502 #$perl_command = "cmd /C \"cd $GSDLHOME&& set GSDLHOME=&& setup.bat > nul&& set\""; 1503 $perl_command = "(cd $GSDLHOME&& set GSDLHOME=&& setup.bat > nul&& set)"; 1504 } 1505 if (!open(PIN, "$perl_command |")) { 1506 print STDERR ("Unable to execute command: $perl_command. $!\n"); 1507 } 1508 1509 my $lastkey; 1510 while (defined (my $perl_output_line = <PIN>)) { 1511 my($key,$value) = ($perl_output_line =~ m/^([^=]*)[=](.*)$/); 1512 if(defined $key) { 1513 #$env_map{$key}=$value; 1514 $ENV{$key}=$value; 1515 $lastkey = $key; 1516 } elsif($lastkey && $perl_output_line !~ m/^\s*$/) { 1517 # there was no equals sign in $perl_output_line, so this 1518 # $perl_output_line may be a spillover from the previous 1519 $ENV{$lastkey} = $ENV{$lastkey}."\n".$perl_output_line; 1520 } 1521 } 1522 close (PIN); 1523 1524 # If any keys in $ENV don't occur in Greenstone's localised env 1525 # (stored in $env_map), delete those entries from $ENV 1526 #foreach $key (keys %ENV) { 1527 # if(!defined $env_map{$key}) { 1528 # print STDOUT "**** DELETING ENV KEY: $key\tVALUE: $ENV{$key}\n"; 1529 # delete $ENV{$key}; # del $ENV(key, value) pair 1530 # } 1531 #} 1532 #undef %env_map; 1533 1533 } 1534 1534 1535 1535 sub get_perl_exec() { 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 } 1555 1556 1536 my $perl_exec = $^X; # may return just "perl" 1537 1538 if($ENV{'PERLPATH'}) { 1539 # OR: # $perl_exec = &FileUtils::filenameConcatenate($ENV{'PERLPATH'},"perl"); 1540 if (($ENV{'GSDLOS'} =~ m/windows/) && ($^O ne "cygwin")) { 1541 $perl_exec = "$ENV{'PERLPATH'}\\Perl.exe"; 1542 } else { 1543 $perl_exec = "$ENV{'PERLPATH'}/perl"; 1544 } 1545 } else { # no PERLPATH, use Config{perlpath} else $^X: special variables 1546 # containing the full path to the current perl executable we're using 1547 $perl_exec = $Config{perlpath}; # configured path for perl 1548 if (!-e $perl_exec) { # may not point to location on this machine 1549 $perl_exec = $^X; # may return just "perl" 1550 if($perl_exec =~ m/^perl/i) { # warn if just perl or Perl.exe 1551 print STDERR "**** WARNING: Perl exec found contains no path: $perl_exec"; 1552 } 1553 } 1554 } 1555 1556 return $perl_exec; 1557 1557 } 1558 1558 … … 1563 1563 my $java = "java"; 1564 1564 if(defined $ENV{'GSDLHOME'}) { # should be, as this script would be launched from the cmd line 1565 1565 # after running setup.bat or from GLI which also runs setup.bat 1566 1566 my $java_bin = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"packages","jre","bin"); 1567 1567 if(-d $java_bin) { … … 1577 1577 # returns the collection and colgroup parts 1578 1578 sub get_collection_parts { 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1579 # http://perldoc.perl.org/File/Basename.html 1580 # my($filename, $directories, $suffix) = fileparse($path); 1581 # "$directories contains everything up to and including the last directory separator in the $path 1582 # including the volume (if applicable). The remainder of the $path is the $filename." 1583 #my ($collection, $colgroup) = &File::Basename::fileparse($qualified_collection); 1584 1585 my $qualified_collection = shift(@_); 1586 1587 # Since activate.pl can be launched from the command-line, including by a user, 1588 # best not to assume colgroup uses URL-style slashes as would be the case with GLI 1589 # Also allow for the accidental inclusion of multiple slashes 1590 my ($colgroup, $collection) = split(/[\/\\]+/, $qualified_collection); #split('/', $qualified_collection); 1591 1592 if(!defined $collection) { 1593 $collection = $colgroup; 1594 $colgroup = ""; 1595 } 1596 return ($collection, $colgroup); 1597 1597 } 1598 1598 1599 1599 # work out the "collectdir/collection" location 1600 1600 sub resolve_collection_dir { 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1601 my ($collect_dir, $qualified_collection, $site) = @_; #, $gs_mode 1602 1603 if (defined $ENV{'GSDLCOLLECTDIR'}) { # a predefined collection dir exists 1604 return $ENV{'GSDLCOLLECTDIR'}; 1605 } 1606 1607 my ($colgroup, $collection) = &util::get_collection_parts($qualified_collection); 1608 1609 if (!defined $collect_dir || !$collect_dir) { # if undefined or empty string 1610 $collect_dir = &util::get_working_collect_dir($site); 1611 } 1612 1613 return &FileUtils::filenameConcatenate($collect_dir,$colgroup,$collection); 1614 1614 } 1615 1615 … … 1673 1673 $path = &util::upgrade_if_dos_filename($path); # will only do something on windows 1674 1674 } 1675 1675 1676 1676 # now we know we're dealing with absolute paths and have to replace gs prefixes with placeholders 1677 1677 my @gs_paths = ($ENV{'GSDLCOLLECTDIR'}, $ENV{'GSDLCOLLECTHOME'}, $ENV{'SITEHOME'}, $ENV{'GREENSTONEHOME'}); # list in this order: from longest to shortest path … … 1726 1726 $path =~ s/^$re_path/$placeholder/; #case sensitive or not? 1727 1727 #$path =~ s/^[\\\/]//; # remove gs_path's trailing separator left behind at the start of the path 1728 1729 1728 # lowercase file extension, This is needed when shortfilenames are used, as case affects alphetical ordering, which affects diffcol 1729 $path =~ s/\.([A-Z]+)$/".".lc($1)/e; 1730 1730 last; # done 1731 1731 } … … 1745 1745 # replace placeholders with gs prefixes 1746 1746 my @placeholders = ('@THISCOLLECTPATH@', '@COLLECTHOME@', '@SITEHOME@', '@GSDLHOME@'); # order of paths not crucial in this case, 1747 1747 # but listed here from longest to shortest once placeholders are have been resolved 1748 1748 1749 1749 # can't use double-quotes around at-sign, else perl tries to evaluate it as referring to an array … … 1752 1752 # always replace placeholders with short file names of the absolute paths on windows? 1753 1753 %placeholder_to_gspath_map = ('@GSDLHOME@' => &util::downgrade_if_dos_filename($ENV{'GREENSTONEHOME'}), 1754 '@COLLECTHOME@' => &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTHOME'}),1755 '@THISCOLLECTPATH@' => &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTDIR'})1756 );1754 '@COLLECTHOME@' => &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTHOME'}), 1755 '@THISCOLLECTPATH@' => &util::downgrade_if_dos_filename($ENV{'GSDLCOLLECTDIR'}) 1756 ); 1757 1757 $placeholder_to_gspath_map{'@SITEHOME@'} = &util::downgrade_if_dos_filename($ENV{'SITEHOME'}) if defined $ENV{'SITEHOME'}; 1758 1758 } else { … … 1793 1793 my ($dir) = @_; 1794 1794 my ($pagenum) =($dir =~ m/^.*?[-\.]?(\d+)(\.(jpg|gif|png|txt))?$/i); 1795 # my ($pagenum) =($dir =~ m/(\d+)(\.(jpg|gif|png))?$/i); # this works but is not as safe/strict about input filepatterns as the above1795 # my ($pagenum) =($dir =~ m/(\d+)(\.(jpg|gif|png))?$/i); # this works but is not as safe/strict about input filepatterns as the above 1796 1796 1797 1797 $pagenum = 1 unless defined $pagenum; … … 1821 1821 # We just test if a text file exists in the same dir that matches the name of the first image file 1822 1822 # if a matching txt file does not exist, don't output txtfile names into the item file 1823 1823 1824 1824 my ($tailname, $dirname, $suffix) = &File::Basename::fileparse($firstfile, "\\.[^\\.]+\$"); # relative filenames so no dirname 1825 1825 my $txtfilename = &FileUtils::filenameConcatenate($output_dir, $tailname . ".txt"); … … 1882 1882 } 1883 1883 } 1884 1884 1885 1885 # now set other the related env vars, 1886 1886 # IF we've found the gnome-lib dir installed in the ext folder … … 1889 1889 $ENV{'GEXTGNOME'} = $gnome_dir; 1890 1890 $ENV{'GEXTGNOME_INSTALLED'}=&FileUtils::filenameConcatenate($ENV{'GEXTGNOME'}, $ENV{'GSDLOS'}); 1891 1891 1892 1892 my $gnomelib_bin = &FileUtils::filenameConcatenate($ENV{'GEXTGNOME_INSTALLED'}, "bin"); 1893 1893 if(-d $gnomelib_bin) { # no bin subfolder in GS binary's cutdown gnome-lib-minimal folder … … 1912 1912 } 1913 1913 1914 # print STDERR "@@@@@ GEXTGNOME: ".$ENV{'GEXTGNOME'}."\n\tINSTALL".$ENV{'GEXTGNOME_INSTALLED'}."\n";1915 # print STDERR "\tPATH".$ENV{'PATH'}."\n";1916 # print STDERR "\tLD_LIB_PATH".$ENV{'LD_LIBRARY_PATH'}."\n" if $ENV{'LD_LIBRARY_PATH};1917 # print STDERR "\tDYLD_FALLBACK_LIB_PATH".$ENV{'DYLD_FALLBACK_LIBRARY_PATH'}."\n" if $ENV{'DYLD_FALLBACK_LIBRARY_PATH};1914 # print STDERR "@@@@@ GEXTGNOME: ".$ENV{'GEXTGNOME'}."\n\tINSTALL".$ENV{'GEXTGNOME_INSTALLED'}."\n"; 1915 # print STDERR "\tPATH".$ENV{'PATH'}."\n"; 1916 # print STDERR "\tLD_LIB_PATH".$ENV{'LD_LIBRARY_PATH'}."\n" if $ENV{'LD_LIBRARY_PATH}; 1917 # print STDERR "\tDYLD_FALLBACK_LIB_PATH".$ENV{'DYLD_FALLBACK_LIBRARY_PATH'}."\n" if $ENV{'DYLD_FALLBACK_LIBRARY_PATH}; 1918 1918 1919 1919 # if no GEXTGNOME, maybe users didn't need gnome-lib to run gnomelib/libiconv dependent binaries like hashfile, suffix, wget … … 1931 1931 sub augmentINC 1932 1932 { 1933 my ($new_path) = @_; 1934 my $did_add_path = 0; 1935 # might need to be replaced with FileUtils::directoryExists() call eventually 1936 if (-d $new_path) 1937 { 1938 my $did_find_path = 0; 1939 foreach my $existing_path (@INC) 1933 my ($new_path) = @_; 1934 my $did_add_path = 0; 1935 # might need to be replaced with FileUtils::directoryExists() call eventually 1936 if (-d $new_path) 1940 1937 { 1941 if ($existing_path eq $new_path) 1942 { 1943 $did_find_path = 1; 1944 last; 1945 } 1946 } 1947 if (!$did_find_path) 1948 { 1949 unshift(@INC, $new_path); 1950 $did_add_path = 1; 1951 } 1952 } 1953 return $did_add_path; 1938 my $did_find_path = 0; 1939 foreach my $existing_path (@INC) 1940 { 1941 if ($existing_path eq $new_path) 1942 { 1943 $did_find_path = 1; 1944 last; 1945 } 1946 } 1947 if (!$did_find_path) 1948 { 1949 unshift(@INC, $new_path); 1950 $did_add_path = 1; 1951 } 1952 } 1953 return $did_add_path; 1954 1954 } 1955 1955 ## augmentINC()
Note:
See TracChangeset
for help on using the changeset viewer.
