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

Last change on this file since 22078 was 21804, checked in by ak19, 14 years ago

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