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

Last change on this file since 19232 was 19232, checked in by ak19, 15 years ago

Cosmetic change: removed a commented out line of code no longer used.
  • Property svn:keywords set to Author Date Id Revision
File size: 15.3 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 $text = &MIME::Base64::decode_base64($text);
610
611 return $text;
612}
613
6141;
615
Note: See TracBrowser for help on using the repository browser.