source: greenstone3/trunk/web/WEB-INF/cgi/gsdlCGI.pm@ 16385

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

Processes new fedorahome and fedoraversion variables if these have been set in the gsdlsite.cfg files. Otherwise, if FEDORA_HOME env var has been set, it uses this to set either FEDORA2_HOME or FEDORA3_HOME as is needed by the Fedora import and build scripts. Additional minor (cosmetic) changes.

File size: 14.0 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'} =~ /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_java_home {
265 my $self = shift @_;
266 my ($optional) = @_;
267
268 if (defined $self->{'javahome'}) {
269 return $self->{'javahome'};
270 }
271
272 my $javahome = $self->get_config_info("javahome", $optional);
273 if(defined $javahome) {
274 $javahome =~ s/(\/|\\)$//; # remove trailing slash
275 $self->{'javahome'} = $javahome;
276 }
277 return $javahome;
278}
279
280sub get_perl_path {
281 my $self = shift @_;
282
283 if (defined $self->{'perlpath'}) {
284 return $self->{'perlpath'};
285 }
286
287 my $perlpath = $self->get_config_info("perlpath");
288
289 if(defined $perlpath) {
290 $perlpath =~ s/(\/|\\)$//; # remove trailing slash
291 $self->{'perlpath'} = $perlpath;
292 }
293 return $perlpath;
294}
295
296sub get_gsdl_os {
297 my $self = shift @_;
298
299 my $os = $^O;
300
301 if ($os =~ m/linux/i) {
302 return "linux";
303 }
304 elsif ($os =~ /mswin/i) {
305 return "windows";
306 }
307 elsif ($os =~ /macos/i) {
308 return "darwin";
309 }
310 else {
311 # return as is.
312 return $os;
313 }
314}
315
316sub get_library_url_suffix {
317 my $self = shift @_;
318
319 if (defined $self->{'library_url_suffix'}) {
320 return $self->{'library_url_suffix'};
321 }
322
323 my $optional = 1; # ignore absence of gwcgi if not found
324 my $library_url = $self->get_config_info("gwcgi", $optional);
325 if(defined $library_url) {
326 $library_url =~ s/(\/|\\)$//; # remove trailing slash
327 }
328 else {
329
330 if($self->{'greenstone_version'} == 2) {
331 $library_url = $self->get_config_info("httpprefix");
332 $library_url = "$library_url/cgi-bin/library";
333
334 my $gsdlos = (defined $ENV{'GSDLOS'}) ? $ENV{'GSDLOS'} : $self->get_gsdl_os();
335 if($gsdlos =~ /windows/) { # remote GS2 server on Windows uses "library.exe"
336 $library_url .= ".exe";
337 }
338 }
339 else { # greenstone 3 or later and gwcgi not defined
340 $library_url = "/greenstone3"; #"/greenstone3/library";
341 }
342 }
343
344 $self->{'library_url_suffix'} = $library_url;
345 return $library_url;
346}
347
348sub setup_fedora_homes {
349 my $self = shift @_;
350 my ($optional) = @_;
351
352 # The following will still allow the ENV FEDORA_HOME variables to have been set outside
353 # the gsdlsite.cfg file. Existing env vars are only overwritten if they've *also* been
354 # defined in gsdlsite.cfg.
355 if(!defined $self->{'fedora_home'} && !defined $self->{'fedora_version'})
356 {
357 # Can look for any fedorahome properties defined in the gsdlsite.cfg file
358 $self->{'fedora_home'} = $self->get_config_info("fedorahome", $optional);
359 $self->{'fedora_version'} = $self->get_config_info("fedoraversion", $optional);
360
361 if(defined $self->{'fedora_home'} && defined $self->{'fedora_version'})
362 {
363 # need to set $ENV{FEDORA2_HOME} or $ENV{FEDORA3_HOME} *and* $ENV{FEDORA_HOME}
364 my $env_name = "FEDORA".$self->{'fedora_version'}."_HOME";
365 $ENV{$env_name} = $self->{'fedora_home'};
366 $ENV{'FEDORA_HOME'} = $self->{'fedora_home'};
367 }
368
369 # if none were specified in the file, use the ENV vars if FEDORA_HOME is already set there
370 elsif(defined $ENV{'FEDORA_HOME'})
371 {
372 $self->{'fedora_home'} = $ENV{'FEDORA_HOME'};
373 if(defined $ENV{'FEDORA2_HOME'} && ($ENV{'FEDORA_HOME'} eq $ENV{'FEDORA2_HOME'}))
374 {
375 $self->{'fedora_version'} = 2;
376 }
377 else # try defaulting to Fedora 3
378 {
379 print STDERR "Setting FEDORA3_HOME env variable to FEDORA_HOME (".$ENV{'FEDORA_HOME'}.").\n";
380 $self->{'fedora_version'} = 3;
381 $ENV{'FEDORA3_HOME'} = $ENV{'FEDORA_HOME'};
382 }
383 }
384 }
385}
386
387sub setup_gsdl {
388 my $self = shift @_;
389
390 my $gsdlhome = $self->get_gsdl_home();
391 my $gsdlos = $self->get_gsdl_os();
392 $ENV{'GSDLHOME'} = $gsdlhome;
393 $ENV{'GSDLOS'} = $gsdlos;
394
395 my $library_url = $self->get_library_url_suffix(); # best to have GSDLOS set beforehand
396 $self->{'library_url_suffix'} = $library_url;
397
398 if($self->{'greenstone_version'} == 3) {
399 my $gsdl3srchome = $self->get_gsdl3_src_home();
400 $ENV{'GSDL3SRCHOME'} = $gsdl3srchome;
401 }
402
403 require "$gsdlhome/perllib/util.pm";
404
405 my $gsdl_bin_script = &util::filename_cat($gsdlhome,"bin","script");
406 &util::envvar_append("PATH",$gsdl_bin_script);
407
408 my $gsdl_bin_os = &util::filename_cat($gsdlhome,"bin",$gsdlos);
409 &util::envvar_append("PATH",$gsdl_bin_os);
410
411 # Perl comes installed with the GS Windows Release Kit.
412 # However, if GS is from SVN, the user must have their own Perl and put it on the path.
413 my $perl_bin_dir; # undefined
414 if ($gsdlos eq "windows") {
415 $perl_bin_dir = &util::filename_cat($gsdlhome, "bin", "windows", "perl", "bin");
416 if(-e $perl_bin_dir) {
417 &util::envvar_append("PATH", $perl_bin_dir);
418 }
419 }
420
421 # Uncomment these lines if you want to read the "perlpath" property from
422 # the gsdl(3)site.cfg config file into PATH
423 #if(!defined $perl_bin_dir) {
424 #$perl_bin_dir = $self->get_perl_path();
425 #&util::envvar_append("PATH", $perl_bin_dir);
426 #}
427
428 # gsdl(3)site.cfg can specify JAVA_HOME and FEDORA_HOME along with Fedora's version. Both
429 # are needed (by scripts g2f-import and g2f-buildcol) when using Greenstone 2 with Fedora.
430 my $optional = 1; # ignore absence of these properties in gsdl(3)site.cfg if not found
431
432 if(!defined $ENV{'JAVA_HOME'}) {
433 $ENV{'JAVA_HOME'} = $self->get_java_home($optional);
434 }
435
436 $self->setup_fedora_homes($optional);
437}
438
439sub greenstone_version {
440 my $self = shift @_;
441 return $self->{'greenstone_version'};
442}
443
444sub library_url_suffix {
445 my $self = shift @_;
446 return $self->{'library_url_suffix'};
447}
448
449# Only useful to call this after calling setup_gsdl, as it uses some environment variables
450# Returns the Greenstone collect directory, or a specific collection directory inside collect
451sub get_collection_dir {
452 my $self = shift @_;
453 my ($site, $collection) = @_; # both may be undefined
454
455 require "$ENV{'GSDLHOME'}/perllib/util.pm";
456 my $collection_directory;
457 if($self->{'greenstone_version'} == 2 && defined $ENV{'GSDLHOME'}) {
458 if(defined $collection) {
459 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection);
460 } else {
461 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect");
462 }
463 }
464 elsif($self->{'greenstone_version'} == 3 && defined $ENV{'GSDL3SRCHOME'}) {
465 if(defined $collection) {
466 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect", $collection);
467 } else {
468 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect");
469 }
470 }
471}
472
473sub local_rm_r
474{
475 my $self = shift @_;
476 my ($local_dir) = @_;
477
478 my $prefix_dir = getcwd();
479 my $full_path = &util::filename_cat($prefix_dir,$local_dir);
480
481 if ($prefix_dir !~ m/collect/) {
482 $self->generate_error("Trying to delete outside of Greenstone collect: $full_path");
483 }
484
485 # Delete recursively
486 if (!-e $full_path) {
487 $self->generate_error("File/Directory does not exist: $full_path");
488 }
489
490 &util::rm_r($full_path);
491}
492
493
494sub get_java_path()
495{
496 # Check the JAVA_HOME environment variable first
497 if (defined $ENV{'JAVA_HOME'}) {
498 my $java_home = $ENV{'JAVA_HOME'};
499 $java_home =~ s/\/$//; # Remove trailing slash if present (Unix specific)
500 return &util::filename_cat($java_home, "bin", "java");
501 }
502
503 # Hope that Java is on the PATH
504 return "java";
505}
506
507
508sub check_java_home()
509{
510 # Return a warning unless the JAVA_HOME environment variable is set
511 if (!defined $ENV{'JAVA_HOME'}) {
512 return "JAVA_HOME environment variable not set. Might not be able to find Java unless in PATH (" . $ENV{'PATH'} . ")";
513 }
514
515 return "";
516}
517
518
519sub checked_chdir
520{
521 my $self = shift @_;
522 my ($dir) = @_;
523
524 if (!-e $dir) {
525 $self->generate_error("Directory '$dir' does not exist");
526 }
527
528 chdir $dir
529 || $self->generate_error("Unable to change to directory: $dir");
530}
531
532sub rot13()
533{
534 my $self = shift @_;
535 my ($password)=@_;
536 my @password_arr=split(//,$password);
537
538 my @encrypt_password;
539 foreach my $str (@password_arr){
540 my $char=unpack("c",$str);
541 if ($char>=97 && $char<=109){
542 $char+=13;
543 }elsif ($char>=110 && $char<=122){
544 $char-=13;
545 }elsif ($char>=65 && $char<=77){
546 $char+=13;
547 }elsif ($char>=78 && $char<=90){
548 $char-=13;
549 }
550 $char=pack("c",$char);
551 push(@encrypt_password,$char);
552 }
553 return join("",@encrypt_password);
554}
555
556sub encrypt_password
557{
558 my $self = shift @_;
559
560 if (defined $self->param("pw")) { ##
561 if ($self->{'greenstone_version'} == 3) { # GS3 is in Java, so needs different encryption
562 $self->param('-name' => "pw", '-value' => $self->rot13($self->clean_param("pw")));
563 }
564 else { # GS2 (and versions of GS other than 3?)
565 #require "$self->{'gsdlhome'}/perllib/util.pm"; # This is OK on Windows
566 require "$self->{'gsdlhome'}/perllib/cpan/Crypt/UnixCrypt.pm"; # This is OK on Windows
567 $self->param('-name' => "pw", '-value' => &Crypt::UnixCrypt::crypt($self->clean_param("pw"), "Tp"));
568 }
569 }
570}
571
5721;
573
Note: See TracBrowser for help on using the repository browser.