source: gsdl/trunk/cgi-bin/gsdlCGI.pm@ 19202

Last change on this file since 19202 was 19202, checked in by ak19, 12 years ago

Removed an older require statement on util.pm which resulted in errors going to the webserver.log of the form: Subroutine x redefined at /research/ak19/gs2-server-svn/perllib/util.pm line y, <USERS_DB> line z.

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