source: main/trunk/greenstone2/cgi-bin/gsdlCGI.pm@ 23184

Last change on this file since 23184 was 23184, checked in by davidb, 11 years ago

Updating of PATH changed to prepend (rather than append) so new environment for Greenstone found ahead of any older settting. The latter happens with the main NZDL web server that sets GSDLHOME we now have the situation that we run more than one Greenstone install from within the same Apache installation

  • Property svn:keywords set to Author Date Id Revision
File size: 17.2 KB
Line 
1package gsdlCGI;
2
3# This file merges Michael Dewsnip's gsdlCGI.pm for GS2 and Quan Qiu's gsdlCGI4gs3.pm (GS3)
4
5use strict;
6no strict 'subs';
7no strict 'refs'; # allow filehandles to be variables and viceversa
8
9use CGI;
10use Cwd;
11use MIME::Base64;
12
13@gsdlCGI::ISA = ( 'CGI' );
14
15sub prenew {
16 my $class = shift @_;
17
18 my $version;
19 if (-e "gsdl3site.cfg") {
20 $version = 3;
21 } else {
22 $version = 2;
23 }
24
25 my $self = {};
26
27 if ($version == 2) {
28 $self->{'site_filename'} = "gsdlsite.cfg";
29 $self->{'greenstone_version'} = 2;
30 }
31 elsif ($version == 3) {
32 $self->{'site_filename'} = "gsdl3site.cfg";
33 $self->{'greenstone_version'} = 3;
34 }
35
36 my $bself = bless $self, $class;
37
38 $bself->setup_gsdl();
39
40 return $bself;
41}
42
43
44sub new {
45 my $class = shift @_;
46
47# my $self;
48
49 # We'll determine the correct config file in this constructor itself
50 # and use it to determine the Greenstone server's version.
51 # Perhaps later, another test can be used for finding out what version
52 # of the Greenstone server we are working with.
53 my $version;
54 if (-e "gsdl3site.cfg") {
55 $version = 3;
56 } else {
57 $version = 2;
58 }
59
60# if ((defined $ENV{'REQUEST_METHOD'}) && ($ENV{'REQUEST_METHOD'} eq "POST")) {
61#
62# # Check if we're dealing with the upload-coll-file cmd. Because it will be a
63# # multipart POST message and must be dealt with by the default CGI() constructor
64# if((defined $ENV{'QUERY_STRING'}) && ($ENV{'QUERY_STRING'} =~ m/upload-collection-file/)) {
65# $self = new CGI();
66# }
67#
68# else { # all other POST commands processed using CGI($line)
69# my $line = <STDIN>;
70# if ((defined $line) && ($line ne "")) {
71# $self = new CGI($line);
72# }
73# }
74#
75# }
76
77 # If one of the conditions above did not hold, then self=new CGI()
78# if (!defined $self) {
79# $self = new CGI();
80# }
81
82 my $self = new CGI(@_);
83
84 if ($version == 2) {
85 $self->{'site_filename'} = "gsdlsite.cfg";
86 $self->{'greenstone_version'} = 2;
87 }
88 elsif ($version == 3) {
89 $self->{'site_filename'} = "gsdl3site.cfg";
90 $self->{'greenstone_version'} = 3;
91 }
92
93 return bless $self, $class;
94}
95
96
97sub parse_cgi_args
98{
99 my $self = shift @_;
100 my $xml = (defined $self->param("xml")) ? 1 : 0;
101
102 $self->{'xml'} = $xml;
103
104 my @var_names = $self->param;
105 my @arg_list = ();
106 foreach my $n ( @var_names ) {
107 my $arg = "$n=";
108 my $val = $self->param($n);
109 $arg .= $val if (defined $val);
110 push(@arg_list,$arg);
111 }
112
113 $self->{'args'} = join("&",@arg_list);
114}
115
116
117sub clean_param
118{
119 my $self = shift @_;
120 my ($param) = @_;
121
122 my $val = $self->SUPER::param($param);
123 $val =~ s/[\r\n]+$// if (defined $val);
124
125 return $val;
126}
127
128sub safe_val
129{
130 my $self = shift @_;
131 my ($val) = @_;
132
133 # convert any encoded entities to true form
134 $val =~ s/&amp;/&/osg;
135 $val =~ s/&lt;/</osg;
136 $val =~ s/&gt;/>/osg;
137 $val =~ s/&quot;/\"/osg;
138 $val =~ s/&nbsp;/ /osg;
139
140
141 # ensure only alpha-numeric plus a few other special chars remain
142
143 $val =~ s/[^[:alnum:]@\.\/\- :_]//g if (defined $val);
144
145 return $val;
146}
147
148sub generate_message
149{
150 my $self = shift @_;
151 my ($message) = @_;
152
153 #if($self->{'greenstone_version'} == 2) { # plain text, for IIS 6
154 print STDOUT "Content-type:text/plain\n\n$message";
155 #} else {
156 #print "Content-type:text/html\n\n";
157 #print "<pre>";
158 #print STDOUT $message;
159 #print "</pre>";
160 #}
161}
162
163sub generate_error
164{
165 my $self = shift @_;
166 my ($mess) = @_;
167
168 my $xml = $self->{'xml'};
169
170 my $full_mess;
171 my $args = $self->{'args'};
172
173 if ($xml) {
174 # Make $args XML safe
175 my $args_xml_safe = $args;
176 $args_xml_safe =~ s/&/&amp;/g;
177
178 $full_mess = "<Error>\n";
179 $full_mess .= " $mess\n";
180 $full_mess .= " CGI args were: $args_xml_safe\n";
181 $full_mess .= "</Error>\n";
182 }
183 else {
184 $full_mess = "ERROR: $mess\n ($args)\n";
185 }
186
187 $self->generate_message($full_mess);
188
189 die $full_mess;
190}
191
192sub generate_warning
193{
194 my $self = shift @_;
195 my ($mess) = @_;
196
197 my $xml = $self->{'xml'};
198
199 my $full_mess;
200 my $args = $self->{'args'};
201
202 if ($xml) {
203 # Make $args XML safe
204 my $args_xml_safe = $args;
205 $args_xml_safe =~ s/&/&amp;/g;
206
207 $full_mess = "<Warning>\n";
208 $full_mess .= " $mess\n";
209 $full_mess .= " CGI args were: $args_xml_safe\n";
210 $full_mess .= "</Warning>\n";
211 }
212 else {
213 $full_mess = "Warning: $mess ($args)\n";
214 }
215
216 $self->generate_message($full_mess);
217
218 print STDERR $full_mess;
219}
220
221
222sub generate_ok_message
223{
224 my $self = shift @_;
225 my ($mess) = @_;
226
227 my $xml = $self->{'xml'};
228
229 my $full_mess;
230
231 if ($xml) {
232 $full_mess = "<Accepted>\n";
233 $full_mess .= " $mess\n";
234 $full_mess .= "</Accepted>\n";
235 }
236 else {
237 $full_mess = "$mess";
238 }
239
240 $self->generate_message($full_mess);
241}
242
243
244
245sub get_config_info {
246 my $self = shift @_;
247 my ($infotype, $optional) = @_;
248
249 my $site_filename = $self->{'site_filename'};
250 open (FILEIN, "<$site_filename")
251 || $self->generate_error("Could not open $site_filename");
252
253 my $config_content = "";
254 while(defined (my $line = <FILEIN>)) {
255 $config_content .= $line;
256 }
257 close(FILEIN);
258
259 my ($loc) = ($config_content =~ m/^$infotype\s+((\".+\")|(\S+))\s*\n/m);
260 $loc =~ s/\"//g if defined $loc;
261
262 if ((!defined $loc) || ($loc =~ m/^\s*$/)) {
263 if((!defined $optional) || (!$optional)) {
264 $self->generate_error("$infotype is not set in $site_filename");
265 }
266 }
267
268 return $loc;
269}
270
271sub get_gsdl3_src_home{
272 my $self = shift @_;
273 if (defined $self->{'gsdl3srchome'}) {
274 return $self->{'gsdl3srchome'};
275 }
276
277 my $gsdl3srchome = $self->get_config_info("gsdl3srchome");
278
279 if(defined $gsdl3srchome) {
280 $gsdl3srchome =~ s/(\/|\\)$//; # remove trailing slash
281 }
282 $self->{'gsdl3srchome'} = $gsdl3srchome;
283
284 return $gsdl3srchome;
285}
286
287
288sub get_gsdl_home {
289 my $self = shift @_;
290
291 if (defined $self->{'gsdlhome'}) {
292 return $self->{'gsdlhome'};
293 }
294
295 my $gsdlhome = $self->get_config_info("gsdlhome");
296
297 $gsdlhome =~ s/(\/|\\)$//; # remove trailing slash
298
299 $self->{'gsdlhome'} = $gsdlhome;
300
301 return $gsdlhome;
302}
303
304sub get_gsdl3_home {
305 my $self = shift @_;
306 my ($optional) = @_;
307
308 if (defined $self->{'gsdl3home'}) {
309 return $self->{'gsdl3home'};
310 }
311
312 my $gsdl3home = $self->get_config_info("gsdl3home", $optional);
313
314 if(defined $gsdl3home) {
315 $gsdl3home =~ s/(\/|\\)$//; # remove trailing slash
316 $self->{'gsdl3home'} = $gsdl3home;
317 }
318 return $gsdl3home;
319}
320
321sub get_java_home {
322 my $self = shift @_;
323 my ($optional) = @_;
324
325 if (defined $self->{'javahome'}) {
326 return $self->{'javahome'};
327 }
328
329 my $javahome = $self->get_config_info("javahome", $optional);
330 if(defined $javahome) {
331 $javahome =~ s/(\/|\\)$//; # remove trailing slash
332 $self->{'javahome'} = $javahome;
333 }
334 return $javahome;
335}
336
337sub get_perl_path {
338 my $self = shift @_;
339 my ($optional) = @_;
340
341 if (defined $self->{'perlpath'}) {
342 return $self->{'perlpath'};
343 }
344
345 my $perlpath = $self->get_config_info("perlpath", $optional);
346
347 if(defined $perlpath) {
348 $perlpath =~ s/(\/|\\)$//; # remove trailing slash
349 $self->{'perlpath'} = $perlpath;
350 }
351 return $perlpath;
352}
353
354sub get_gsdl_os {
355 my $self = shift @_;
356
357 my $os = $^O;
358
359 if ($os =~ m/linux/i) {
360 return "linux";
361 }
362 elsif ($os =~ m/mswin/i) {
363 return "windows";
364 }
365 elsif ($os =~ m/macos/i) {
366 return "darwin";
367 }
368 else {
369 # return as is.
370 return $os;
371 }
372}
373
374sub get_library_url_suffix {
375 my $self = shift @_;
376
377 if (defined $self->{'library_url_suffix'}) {
378 return $self->{'library_url_suffix'};
379 }
380
381 my $optional = 1; # ignore absence of gwcgi if not found
382 my $library_url = $self->get_config_info("gwcgi", $optional);
383 if(defined $library_url) {
384 $library_url =~ s/(\/|\\)$//; # remove trailing slash
385 }
386 else {
387
388 if($self->{'greenstone_version'} == 2) {
389 $library_url = $self->get_config_info("httpprefix", $optional);
390 $library_url = "/greenstone" unless defined $library_url;
391 $library_url = "$library_url/cgi-bin/library.cgi"; # same extension for linux and windows
392 }
393 else { # greenstone 3 or later and gwcgi not defined
394 $library_url = "/greenstone3"; #"/greenstone3/library";
395 }
396 }
397
398 $self->{'library_url_suffix'} = $library_url;
399 return $library_url;
400}
401
402sub setup_fedora_homes {
403 my $self = shift @_;
404 my ($optional) = @_;
405
406 # The following will still allow the FEDORA_HOME and FEDORA_VERSION environment
407 # variables to have been set outside the gsdlsite.cfg file. Existing env vars
408 # are only overwritten if they've *also* been defined in gsdlsite.cfg.
409
410 if (!defined $self->{'fedora_home'}) # Don't need to go through it all again if we'd already done this before
411 {
412 # First look in the gsdlsite.cfg file for the fedora properties to be defined
413 # and set $ENV{FEDORA_HOME} and $ENV{FEDORA_VERSION} if values were provided
414 $self->{'fedora_home'} = $self->get_config_info("fedorahome", $optional);
415
416 if (defined $self->{'fedora_home'}) {
417 $ENV{'FEDORA_HOME'} = $self->{'fedora_home'};
418 }
419 elsif (defined $ENV{'FEDORA_HOME'}) { # check environment variable
420 $self->{'fedora_home'} = $ENV{'FEDORA_HOME'};
421 }
422
423 # if FEDORA_HOME is now defined, we can look for the fedora version that is being used
424 if (defined $ENV{'FEDORA_HOME'})
425 {
426 # first look in the file
427 $self->{'fedora_version'} = $self->get_config_info("fedoraversion", $optional);
428
429 if (defined $self->{'fedora_version'}) {
430 $ENV{'FEDORA_VERSION'} = $self->{'fedora_version'};
431 }
432 elsif (defined $ENV{'FEDORA_VERSION'}) { # then check environment variable
433 $self->{'fedora_version'} = $ENV{'FEDORA_VERSION'};
434 }
435 else { # finally, default to version 3 and warn the user
436 $ENV{'FEDORA_VERSION'} = "3";
437 $self->{'fedora_version'} = $ENV{'FEDORA_VERSION'};
438 #$self->generate_ok_message("FEDORA_HOME is set, but not FEDORA_VERSION, defaulted to: 3.");
439 }
440 }
441 }
442}
443
444sub setup_gsdl {
445 my $self = shift @_;
446 my $optional = 1; # ignore absence of specified properties in gsdl(3)site.cfg if not found
447
448 my $gsdlhome = $self->get_gsdl_home();
449 my $gsdlos = $self->get_gsdl_os();
450 $ENV{'GSDLHOME'} = $gsdlhome;
451 $ENV{'GSDLOS'} = $gsdlos;
452
453
454 my $library_url = $self->get_library_url_suffix(); # best to have GSDLOS set beforehand
455 $self->{'library_url_suffix'} = $library_url;
456
457 unshift(@INC, "$ENV{'GSDLHOME'}/cgi-bin"); # This is OK on Windows
458 unshift(@INC, "$ENV{'GSDLHOME'}/perllib");
459 unshift(@INC, "$ENV{'GSDLHOME'}/perllib/cpan");
460
461 require util;
462
463 if($self->{'greenstone_version'} == 3) {
464 my $gsdl3srchome = $self->get_gsdl3_src_home();
465 $ENV{'GSDL3SRCHOME'} = $gsdl3srchome;
466
467 my $gsdl3home = $self->get_gsdl3_home($optional);
468 # if a specific location for GS3's web folder is not provided,
469 # assume the GS3 web folder is in the default location
470 if(!defined $gsdl3home) {
471 $gsdl3home = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web");
472 $self->{'gsdl3home'} = $gsdl3home;
473 }
474 $ENV{'GSDL3HOME'} = $gsdl3home;
475 }
476
477
478 my $gsdl_bin_script = &util::filename_cat($gsdlhome,"bin","script");
479 &util::envvar_prepend("PATH",$gsdl_bin_script);
480
481 my $gsdl_bin_os = &util::filename_cat($gsdlhome,"bin",$gsdlos);
482 &util::envvar_prepend("PATH",$gsdl_bin_os);
483
484 # If the "perlpath" property is set in the gsdl(3)site.cfg config file, it is
485 # prepended to PATH only if the same perl bin dir path is not already on PATH env
486 my $perl_bin_dir = $self->get_perl_path($optional);
487 if(defined $perl_bin_dir)
488 {
489 &util::envvar_prepend("PATH", $perl_bin_dir);
490
491 #my ($perl_home) = ($perl_bin_dir =~ m/(.*)[\\|\/]bin[\\|\/]?$/);
492 my ($tailname,$perl_home) = File::Basename::fileparse($perl_bin_dir, "\\.(?:[^\\.]+?)\$");
493 $ENV{'PERL5LIB'} = &util::filename_cat($perl_home, "lib");
494
495 if($gsdlos eq "darwin") {
496 &util::envvar_prepend("DYLD_LIBRARY_PATH", &util::filename_cat($perl_home,"5.8.9","darwin-thread-multi-2level","CORE"));
497 } elsif($gsdlos eq "linux") {
498 &util::envvar_prepend("LD_LIBRARY_PATH", &util::filename_cat($perl_home,"5.8.9","i686-linux-thread-multi","CORE"));
499 }
500 }
501 elsif ($gsdlos eq "windows")
502 {
503 # Perl comes installed with the GS Windows Release Kit. However, note that if GS
504 # is from SVN, the user must have their own Perl and put it on the PATH or set
505 # perlpath in the gsdl site config file.
506 $perl_bin_dir = &util::filename_cat($gsdlhome, "bin", "windows", "perl", "bin");
507 if(-e $perl_bin_dir) {
508 &util::envvar_append("PATH", $perl_bin_dir);
509 }
510 }
511
512 # If javahome is explicitly set in the gsdl site config file then it will override
513 # any env variable JAVA_HOME. A GS2 server does not set JAVA_HOME, though java is on
514 # the path. Therefore, if Fedora is being used for FLI with GS2, then javahome must
515 # be set in gsdlsite.cfg or the JAVA_HOME env var must be explicitly set by the user.
516 my $java_home = $self->get_java_home($optional);
517 if(defined $java_home) {
518 $ENV{'JAVA_HOME'} = $java_home;
519 }
520
521 # Process any extension setup.pl files
522 my $ext_home = &util::filename_cat($gsdlhome,"ext");
523
524 if (opendir(EXTDIR,$ext_home) ) {
525 my @pot_ext_dir = grep { $_ !~ m/^\./ } readdir(EXTDIR);
526
527 closedir(EXTXDIR);
528
529 foreach my $ed (@pot_ext_dir) {
530 my $full_ext_dir = &util::filename_cat($ext_home,$ed);
531 if (-d $full_ext_dir) {
532 my $full_inc_file = &util::filename_cat($full_ext_dir,
533 "$ed-setup.pl");
534 if (-f $full_inc_file) {
535
536 my $store_cwd = Cwd::cwd();
537
538 chdir($full_ext_dir);
539 require "./$ed-setup.pl";
540 chdir($store_cwd);
541 }
542 }
543 }
544 }
545
546 # FEDORA_HOME and FEDORA_VERSION are needed (by scripts g2f-import and g2f-buildcol).
547 $self->setup_fedora_homes($optional);
548}
549
550sub greenstone_version {
551 my $self = shift @_;
552 return $self->{'greenstone_version'};
553}
554
555sub library_url_suffix {
556 my $self = shift @_;
557 return $self->{'library_url_suffix'};
558}
559
560# Only useful to call this after calling setup_gsdl, as it uses some environment variables
561# Returns the Greenstone collect directory, or a specific collection directory inside collect
562sub get_collection_dir {
563 my $self = shift @_;
564 my ($site, $collection) = @_; # both may be undefined
565
566 my $collection_directory;
567 if($self->{'greenstone_version'} == 2 && defined $ENV{'GSDLHOME'}) {
568 if(defined $collection) {
569 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection);
570 } else {
571 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect");
572 }
573 }
574 elsif($self->{'greenstone_version'} == 3 && defined $ENV{'GSDL3SRCHOME'}) {
575 if(defined $collection) {
576 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect", $collection);
577 } else {
578 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect");
579 }
580 }
581}
582
583sub local_rm_r
584{
585 my $self = shift @_;
586 my ($local_dir) = @_;
587
588 my $prefix_dir = getcwd();
589 my $full_path = &util::filename_cat($prefix_dir,$local_dir);
590
591 if ($prefix_dir !~ m/collect/) {
592 $self->generate_error("Trying to delete outside of Greenstone collect: $full_path");
593 }
594
595 # Delete recursively
596 if (!-e $full_path) {
597 $self->generate_error("File/Directory does not exist: $full_path");
598 }
599
600 &util::rm_r($full_path);
601}
602
603
604sub get_java_path()
605{
606 # Check the JAVA_HOME environment variable first
607 if (defined $ENV{'JAVA_HOME'}) {
608 my $java_home = $ENV{'JAVA_HOME'};
609 $java_home =~ s/\/$//; # Remove trailing slash if present (Unix specific)
610 return &util::filename_cat($java_home, "bin", "java");
611 }
612
613 # Hope that Java is on the PATH
614 return "java";
615}
616
617
618sub check_java_home()
619{
620 # Return a warning unless the JAVA_HOME environment variable is set
621 if (!defined $ENV{'JAVA_HOME'}) {
622 return "JAVA_HOME environment variable not set. Might not be able to find Java unless in PATH (" . $ENV{'PATH'} . ")";
623 }
624
625 return "";
626}
627
628
629sub checked_chdir
630{
631 my $self = shift @_;
632 my ($dir) = @_;
633
634 if (!-e $dir) {
635 $self->generate_error("Directory '$dir' does not exist");
636 }
637
638 chdir $dir
639 || $self->generate_error("Unable to change to directory: $dir");
640}
641
642sub rot13()
643{
644 my $self = shift @_;
645 my ($password)=@_;
646 my @password_arr=split(//,$password);
647
648 my @encrypt_password;
649 foreach my $str (@password_arr){
650 my $char=unpack("c",$str);
651 if ($char>=97 && $char<=109){
652 $char+=13;
653 }elsif ($char>=110 && $char<=122){
654 $char-=13;
655 }elsif ($char>=65 && $char<=77){
656 $char+=13;
657 }elsif ($char>=78 && $char<=90){
658 $char-=13;
659 }
660 $char=pack("c",$char);
661 push(@encrypt_password,$char);
662 }
663 return join("",@encrypt_password);
664}
665
666sub encrypt_password
667{
668 my $self = shift @_;
669
670 if (defined $self->param("pw")) { ##
671 if ($self->{'greenstone_version'} == 3) { # GS3 is in Java, so needs different encryption
672 $self->param('-name' => "pw", '-value' => $self->rot13($self->clean_param("pw")));
673 }
674 else { # GS2 (and versions of GS other than 3?)
675 #require "$self->{'gsdlhome'}/perllib/util.pm"; # This is OK on Windows
676 require "$self->{'gsdlhome'}/perllib/cpan/Crypt/UnixCrypt.pm"; # This is OK on Windows
677 $self->param('-name' => "pw", '-value' => &Crypt::UnixCrypt::crypt($self->clean_param("pw"), "Tp"));
678 }
679 }
680}
681
682
683sub decode {
684 my ($self, $text) = @_;
685 $text =~ s/\+/ /g;
686 $text = &MIME::Base64::decode_base64($text);
687
688 return $text;
689}
690
6911;
692
Note: See TracBrowser for help on using the repository browser.