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

Last change on this file since 23236 was 23236, checked in by ak19, 14 years ago

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