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

Last change on this file since 20573 was 20573, checked in by davidb, 15 years ago

Encoded entites < > etc. mapped back to original character
  • Property svn:keywords set to Author Date Id Revision
File size: 15.6 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 elsif ($gsdlos eq "windows")
461 {
462 # Perl comes installed with the GS Windows Release Kit. However, note that if GS
463 # is from SVN, the user must have their own Perl and put it on the PATH or set
464 # perlpath in the gsdl site config file.
465 $perl_bin_dir = &util::filename_cat($gsdlhome, "bin", "windows", "perl", "bin");
466 if(-e $perl_bin_dir) {
467 &util::envvar_append("PATH", $perl_bin_dir);
468 }
469 }
470
471 # If javahome is explicitly set in the gsdl site config file then it will override
472 # any env variable JAVA_HOME. A GS2 server does not set JAVA_HOME, though java is on
473 # the path. Therefore, if Fedora is being used for FLI with GS2, then javahome must
474 # be set in gsdlsite.cfg or the JAVA_HOME env var must be explicitly set by the user.
475 my $java_home = $self->get_java_home($optional);
476 if(defined $java_home) {
477 $ENV{'JAVA_HOME'} = $java_home;
478 }
479
480 # FEDORA_HOME and FEDORA_VERSION are needed (by scripts g2f-import and g2f-buildcol).
481 $self->setup_fedora_homes($optional);
482}
483
484sub greenstone_version {
485 my $self = shift @_;
486 return $self->{'greenstone_version'};
487}
488
489sub library_url_suffix {
490 my $self = shift @_;
491 return $self->{'library_url_suffix'};
492}
493
494# Only useful to call this after calling setup_gsdl, as it uses some environment variables
495# Returns the Greenstone collect directory, or a specific collection directory inside collect
496sub get_collection_dir {
497 my $self = shift @_;
498 my ($site, $collection) = @_; # both may be undefined
499
500 my $collection_directory;
501 if($self->{'greenstone_version'} == 2 && defined $ENV{'GSDLHOME'}) {
502 if(defined $collection) {
503 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection);
504 } else {
505 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect");
506 }
507 }
508 elsif($self->{'greenstone_version'} == 3 && defined $ENV{'GSDL3SRCHOME'}) {
509 if(defined $collection) {
510 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect", $collection);
511 } else {
512 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect");
513 }
514 }
515}
516
517sub local_rm_r
518{
519 my $self = shift @_;
520 my ($local_dir) = @_;
521
522 my $prefix_dir = getcwd();
523 my $full_path = &util::filename_cat($prefix_dir,$local_dir);
524
525 if ($prefix_dir !~ m/collect/) {
526 $self->generate_error("Trying to delete outside of Greenstone collect: $full_path");
527 }
528
529 # Delete recursively
530 if (!-e $full_path) {
531 $self->generate_error("File/Directory does not exist: $full_path");
532 }
533
534 &util::rm_r($full_path);
535}
536
537
538sub get_java_path()
539{
540 # Check the JAVA_HOME environment variable first
541 if (defined $ENV{'JAVA_HOME'}) {
542 my $java_home = $ENV{'JAVA_HOME'};
543 $java_home =~ s/\/$//; # Remove trailing slash if present (Unix specific)
544 return &util::filename_cat($java_home, "bin", "java");
545 }
546
547 # Hope that Java is on the PATH
548 return "java";
549}
550
551
552sub check_java_home()
553{
554 # Return a warning unless the JAVA_HOME environment variable is set
555 if (!defined $ENV{'JAVA_HOME'}) {
556 return "JAVA_HOME environment variable not set. Might not be able to find Java unless in PATH (" . $ENV{'PATH'} . ")";
557 }
558
559 return "";
560}
561
562
563sub checked_chdir
564{
565 my $self = shift @_;
566 my ($dir) = @_;
567
568 if (!-e $dir) {
569 $self->generate_error("Directory '$dir' does not exist");
570 }
571
572 chdir $dir
573 || $self->generate_error("Unable to change to directory: $dir");
574}
575
576sub rot13()
577{
578 my $self = shift @_;
579 my ($password)=@_;
580 my @password_arr=split(//,$password);
581
582 my @encrypt_password;
583 foreach my $str (@password_arr){
584 my $char=unpack("c",$str);
585 if ($char>=97 && $char<=109){
586 $char+=13;
587 }elsif ($char>=110 && $char<=122){
588 $char-=13;
589 }elsif ($char>=65 && $char<=77){
590 $char+=13;
591 }elsif ($char>=78 && $char<=90){
592 $char-=13;
593 }
594 $char=pack("c",$char);
595 push(@encrypt_password,$char);
596 }
597 return join("",@encrypt_password);
598}
599
600sub encrypt_password
601{
602 my $self = shift @_;
603
604 if (defined $self->param("pw")) { ##
605 if ($self->{'greenstone_version'} == 3) { # GS3 is in Java, so needs different encryption
606 $self->param('-name' => "pw", '-value' => $self->rot13($self->clean_param("pw")));
607 }
608 else { # GS2 (and versions of GS other than 3?)
609 #require "$self->{'gsdlhome'}/perllib/util.pm"; # This is OK on Windows
610 require "$self->{'gsdlhome'}/perllib/cpan/Crypt/UnixCrypt.pm"; # This is OK on Windows
611 $self->param('-name' => "pw", '-value' => &Crypt::UnixCrypt::crypt($self->clean_param("pw"), "Tp"));
612 }
613 }
614}
615
616
617sub decode {
618 my ($self, $text) = @_;
619 $text =~ s/\+/ /g;
620 $text = &MIME::Base64::decode_base64($text);
621
622 return $text;
623}
624
6251;
626
Note: See TracBrowser for help on using the repository browser.