root/main/trunk/greenstone2/cgi-bin/gsdlCGI.pm @ 21804

Revision 21804, 16.1 KB (checked in by ak19, 10 years ago)

Dr Bainbridge modified the section setting Perl to bring it in line with what setup.bash does when Perl 5.8.9 has been downloaded and extracted into the bin linux folder. Need perlpath property in gsdlsite.cfg set, for the Remote Greenstone to do the same, though.

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