source: main/tags/stable/greenstone2/cgi-bin/gsdlCGI.pm@ 23203

Last change on this file since 23203 was 23196, checked in by ak19, 14 years ago

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