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

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

The perl-location directive at the top is removed, it shouldn't be in .pm files

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