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

Last change on this file since 23070 was 23070, checked in by davidb, 14 years ago

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