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

Last change on this file since 16509 was 16509, checked in by ak19, 16 years ago

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