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

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

Merged version of GS2's gliserver.pl and gsdlCGI.pm files and GS3's gliserver4gs3.pl and gsdlCGI.pm. Tested that it works with both GS2 and GS3, after making the necessary changes in GLI's RemoteGreenstoneServer.java. Soon, a common location needs to be found for the combined gliserver and gsdlCGI file which will then have to be checked out into the correct appropriate location for GS2 or GS3 (as the case may be).

File size: 11.1 KB
Line 
1#!/usr/bin/perl -w
2package gsdlCGI;
3
4# This file merges Michael Dewsnip's gsdlCGI.pm for GS2 and Quan Qiu's gsdlCGI4gs3.pm (GS3)
5
6use strict;
7no strict 'subs';
8no strict 'refs'; # allow filehandles to be variables and viceversa
9
10use CGI;
11use Cwd;
12
13@gsdlCGI::ISA = ( 'CGI' ); #@gsdlCGI::ISA = qw( CGI );
14#@ISA = ('CGI'); # syntax error of some kind when using strict
15
16sub new {
17 my $class = shift @_;
18
19 my $self;
20
21 # We'll determine the correct config file in this constructor itself
22 # and use it to determine the Greenstone server's version.
23 # Perhaps later, another test can be used for finding out what version
24 # of the Greenstone server we are working with.
25 my $version;
26 if (-e "gsdl3site.cfg") {
27 $version = 3;
28 } else {
29 $version = 2;
30 }
31
32 if ((defined $ENV{'REQUEST_METHOD'}) && ($ENV{'REQUEST_METHOD'} eq "POST")) {
33 my $line = <STDIN>;
34 # Multipart POST requests' boundaries created by Java's POST method on the client-GLI side
35 # start with --. If there are other kinds of languages and boundaries we will be dealing
36 # with, we can list those patterns alongside here in the (), separated by |:
37 my $multipartPostBoundary = q/^(--)/;
38
39 # cmd=upload-collection-file is not read into $line from STDIN, only the boundary (a
40 # sequence of chars preceeded by --) is encountered. Either we can match on POST requests
41 # whose cmds contain "download" OR we can look for $line NOT being boundary, to process $line.
42 # Multipart POST messages are processed by the zero-argument CGI constructor.
43 if ((defined $line) && ($line ne "") && ($line !~ /$multipartPostBoundary/)) { #&& ($line =~ /download/)) {
44 $self = new CGI($line);
45 }
46 }
47
48 # If one of the conditions above did not hold, then self=new CGI.
49 # This includes multipart post boundaries as are sent for cmd=upload-collection-file,
50 # which should also be processed by the zero-argument CGI constructor.
51 if (!defined $self) {
52 $self = new CGI();
53 }
54
55 if ($version == 2) {
56 $self->{'site_filename'} = "gsdlsite.cfg";
57 $self->{'greenstone_version'} = 2;
58 }
59 elsif ($version == 3) {
60 $self->{'site_filename'} = "gsdl3site.cfg";
61 $self->{'greenstone_version'} = 3;
62 }
63
64 return bless $self, $class;
65}
66
67
68sub parse_cgi_args
69{
70 my $self = shift @_;
71 my $xml = (defined $self->param("xml")) ? 1 : 0;
72
73 $self->{'xml'} = $xml;
74
75 my @var_names = $self->param;
76 my @arg_list = ();
77 foreach my $n ( @var_names ) {
78 my $arg = "$n=";
79 my $val = $self->param($n);
80 $arg .= $val if (defined $val);
81 push(@arg_list,$arg);
82 }
83
84 $self->{'args'} = join("&",@arg_list);
85}
86
87
88sub clean_param
89{
90 my $self = shift @_;
91 my ($param) = @_;
92
93 my $val = $self->SUPER::param($param);
94 $val =~ s/[\r\n]+$// if (defined $val);
95
96 return $val;
97}
98
99sub safe_val
100{
101 my $self = shift @_;
102 my ($val) = @_;
103
104 # ensure only alpha-numeric plus a few other special chars remain
105
106 $val =~ s/[^[:alnum:]@\.\/\- :_]//g if (defined $val);
107
108 return $val;
109}
110
111sub generate_message
112{
113 my $self = shift @_;
114 my ($message) = @_;
115
116 #if($self->{'greenstone_version'} == 2) { # plain text, for IIS 6
117 print STDOUT "Content-type:text/plain\n\n$message";
118 #} else {
119 #print "Content-type:text/html\n\n";
120 #print "<pre>";
121 #print STDOUT $message;
122 #print "</pre>";
123 #}
124}
125
126sub generate_error
127{
128 my $self = shift @_;
129 my ($mess) = @_;
130
131 my $xml = $self->{'xml'};
132
133 my $full_mess;
134 my $args = $self->{'args'};
135
136 if ($xml) {
137 # Make $args XML safe
138 my $args_xml_safe = $args;
139 $args_xml_safe =~ s/&/&amp;/g;
140
141 $full_mess = "<Error>\n";
142 $full_mess .= " $mess\n";
143 $full_mess .= " CGI args were: $args_xml_safe\n";
144 $full_mess .= "</Error>\n";
145 }
146 else {
147 $full_mess = "ERROR: $mess\n ($args)\n";
148 }
149
150 $self->generate_message($full_mess);
151
152 die $full_mess;
153}
154
155sub generate_warning
156{
157 my $self = shift @_;
158 my ($mess) = @_;
159
160 my $xml = $self->{'xml'};
161
162 my $full_mess;
163 my $args = $self->{'args'};
164
165 if ($xml) {
166 # Make $args XML safe
167 my $args_xml_safe = $args;
168 $args_xml_safe =~ s/&/&amp;/g;
169
170 $full_mess = "<Warning>\n";
171 $full_mess .= " $mess\n";
172 $full_mess .= " CGI args were: $args_xml_safe\n";
173 $full_mess .= "</Warning>\n";
174 }
175 else {
176 $full_mess = "Warning: $mess ($args)\n";
177 }
178
179 $self->generate_message($full_mess);
180
181 print STDERR $full_mess;
182}
183
184
185sub generate_ok_message
186{
187 my $self = shift @_;
188 my ($mess) = @_;
189
190 my $xml = $self->{'xml'};
191
192 my $full_mess;
193
194 if ($xml) {
195 $full_mess = "<Accepted>\n";
196 $full_mess .= " $mess\n";
197 $full_mess .= "</Accepted>\n";
198 }
199 else {
200 $full_mess = "$mess\n";
201 }
202
203 $self->generate_message($full_mess);
204}
205
206
207
208sub get_config_info {
209 my $self = shift @_;
210 my ($infotype) = @_;
211
212 my $site_filename = $self->{'site_filename'};
213 open (FILEIN, "<$site_filename")
214 || $self->generate_error("Could not open $site_filename");
215
216 my $config_content = "";
217 while(defined (my $line = <FILEIN>)) {
218 $config_content .= $line;
219 }
220 close(FILEIN);
221
222 my ($loc) = ($config_content =~ m/^$infotype\s+((\".+\")|(\S+))\s*\n/m);
223 $loc =~ s/\"//g;
224
225 if ((!defined $loc) || ($loc =~ m/^\s*$/)) {
226 $self->generate_error("$infotype is not set in $site_filename");
227 }
228
229 return $loc;
230}
231
232sub get_gsdl3_src_home{
233 my $self = shift @_;
234 if (defined $self->{'gsdl3srchome'}) {
235 return $self->{'gsdl3srchome'};
236 }
237
238 my $gsdl3srchome = $self->get_config_info("gsdl3srchome");
239
240 if(defined $gsdl3srchome) {
241 $gsdl3srchome =~ s/(\/|\\)$//; # remove trailing slash
242 }
243 $self->{'gsdl3srchome'} = $gsdl3srchome;
244
245 return $gsdl3srchome;
246}
247
248
249sub get_gsdl_home {
250 my $self = shift @_;
251
252 if (defined $self->{'gsdlhome'}) {
253 return $self->{'gsdlhome'};
254 }
255
256 my $gsdlhome = $self->get_config_info("gsdlhome");
257
258 $gsdlhome =~ s/(\/|\\)$//; # remove trailing slash
259
260 $self->{'gsdlhome'} = $gsdlhome;
261
262 return $gsdlhome;
263}
264
265sub get_java_home {
266 my $self = shift @_;
267
268 if (defined $self->{'javahome'}) {
269 return $self->{'javahome'};
270 }
271
272 my $javahome = $self->get_config_info("javahome");
273
274 $javahome =~ s/(\/|\\)$//; # remove trailing slash
275
276 return $javahome;
277}
278
279sub get_perl_path {
280 my $self = shift @_;
281
282 if (defined $self->{'perlpath'}) {
283 return $self->{'perlpath'};
284 }
285
286 my $perlpath = $self->get_config_info("perlpath");
287
288 $perlpath =~ s/(\/|\\)$//; # remove trailing slash
289
290 return $perlpath;
291}
292
293sub get_gsdl_os {
294 my $self = shift @_;
295
296 my $os = $^O;
297
298 if ($os =~ m/linux/i) {
299 return "linux";
300 }
301 elsif ($os =~ /mswin/i) {
302 return "windows";
303 }
304 elsif ($os =~ /macos/i) {
305 return "darwin";
306 }
307 else {
308 # return as is.
309 return $os;
310 }
311}
312
313sub setup_gsdl {
314 my $self = shift @_;
315
316 my $gsdlhome = $self->get_gsdl_home();
317 my $gsdlos = $self->get_gsdl_os();
318
319 $ENV{'GSDLHOME'} = $gsdlhome;
320 $ENV{'GSDLOS'} = $gsdlos;
321
322 if($self->{'greenstone_version'} == 3) {
323 my $gsdl3srchome = $self->get_gsdl3_src_home();
324 my $javahome = $self->get_java_home();
325
326 $ENV{'GSDL3SRCHOME'} = $gsdl3srchome;
327 $ENV{'JAVA_HOME'} = $javahome;
328 }
329
330 require "$gsdlhome/perllib/util.pm";
331
332 my $gsdl_bin_script = &util::filename_cat($gsdlhome,"bin","script");
333 &util::envvar_append("PATH",$gsdl_bin_script);
334
335 my $gsdl_bin_os = &util::filename_cat($gsdlhome,"bin",$gsdlos);
336 &util::envvar_append("PATH",$gsdl_bin_os);
337
338 if ($gsdlos eq "windows") {
339 my $gsdl_perl_bin_directory = &util::filename_cat($gsdlhome, "bin", "windows", "perl", "bin");
340 &util::envvar_append("PATH", $gsdl_perl_bin_directory);
341 }
342 elsif($self->{'greenstone_version'} == 3) { # and it's on linux now
343 my $perlpath = $self->get_perl_path();
344 &util::envvar_append("PATH", $perlpath);
345 }
346}
347
348sub greenstone_version {
349 my $self = shift @_;
350 return $self->{'greenstone_version'};
351}
352
353# Only useful to call this after calling setup_gsdl, as it uses some environment variables
354# Returns the Greenstone collect directory, or a specific collection directory inside collect
355sub get_collection_dir {
356 my $self = shift @_;
357 my ($site, $collection) = @_; # both may be undefined
358
359 require "$ENV{'GSDLHOME'}/perllib/util.pm";
360 my $collection_directory;
361 if($self->{'greenstone_version'} == 2 && defined $ENV{'GSDLHOME'}) {
362 if(defined $collection) {
363 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection);
364 } else {
365 $collection_directory = &util::filename_cat($ENV{'GSDLHOME'}, "collect");
366 }
367 }
368 elsif($self->{'greenstone_version'} == 3 && defined $ENV{'GSDL3SRCHOME'}) {
369 if(defined $collection) {
370 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect", $collection);
371 } else {
372 $collection_directory = &util::filename_cat($ENV{'GSDL3SRCHOME'}, "web", "sites", $site, "collect");
373 }
374 }
375}
376
377sub local_rm_r
378{
379 my $self = shift @_;
380 my ($local_dir) = @_;
381
382 my $prefix_dir = getcwd();
383 my $full_dir = &util::filename_cat($prefix_dir,$local_dir);
384
385 if ($prefix_dir !~ m/collect/) {
386 $self->generate_error("Trying to delete outside of Greenstone collect: $full_dir");
387 }
388
389 # Delete recursively
390 if (!-e $full_dir) {
391 $self->generate_error("File/Directory does not exist: $full_dir");
392 }
393
394 &util::rm_r($full_dir);
395}
396
397
398sub get_java_path()
399{
400 # Check the JAVA_HOME environment variable first
401 if (defined $ENV{'JAVA_HOME'}) {
402 my $java_home = $ENV{'JAVA_HOME'};
403 $java_home =~ s/\/$//; # Remove trailing slash if present (Unix specific)
404 return &util::filename_cat($java_home, "bin", "java");
405 }
406
407 # Hope that Java is on the PATH
408 return "java";
409}
410
411
412sub check_java_home()
413{
414 # Return a warning unless the JAVA_HOME environment variable is set
415 if (!defined $ENV{'JAVA_HOME'}) {
416 return "JAVA_HOME environment variable not set. Might not be able to find Java unless in PATH (" . $ENV{'PATH'} . ")";
417 }
418
419 return "";
420}
421
422
423sub checked_chdir
424{
425 my $self = shift @_;
426 my ($dir) = @_;
427
428 if (!-e $dir) {
429 $self->generate_error("Directory '$dir' does not exist");
430 }
431
432 chdir $dir
433 || $self->generate_error("Unable to change to directory: $dir");
434}
435
436sub rot13()
437{
438 my $self = shift @_;
439 my ($password)=@_;
440 my @password_arr=split(//,$password);
441
442 my @encrypt_password;
443 foreach my $str (@password_arr){
444 my $char=unpack("c",$str);
445 if ($char>=97 && $char<=109){
446 $char+=13;
447 }elsif ($char>=110 && $char<=122){
448 $char-=13;
449 }elsif ($char>=65 && $char<=77){
450 $char+=13;
451 }elsif ($char>=78 && $char<=90){
452 $char-=13;
453 }
454 $char=pack("c",$char);
455 push(@encrypt_password,$char);
456 }
457 return join("",@encrypt_password);
458}
459
460sub encrypt_password
461{
462 my $self = shift @_;
463
464 if (defined $self->param("pw")) { ##
465 if ($self->{'greenstone_version'} == 3) { # GS3 is in Java, so needs different encryption
466 $self->param('-name' => "pw", '-value' => $self->rot13($self->clean_param("pw")));
467 }
468 else { # GS2 (and versions of GS other than 3?)
469 #require "$self->{'gsdlhome'}/perllib/util.pm"; # This is OK on Windows
470 require "$self->{'gsdlhome'}/perllib/cpan/Crypt/UnixCrypt.pm"; # This is OK on Windows
471 $self->param('-name' => "pw", '-value' => &Crypt::UnixCrypt::crypt($self->clean_param("pw"), "Tp"));
472 }
473 }
474}
475
4761;
477
Note: See TracBrowser for help on using the repository browser.