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

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

Minor. Now tests for matches using m/something/ rather than /something/

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'} =~ 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_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 =~ m/mswin/i) {
305 return "windows";
306 }
307 elsif ($os =~ m/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 =~ m/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.