source: greenstone3/trunk/web/WEB-INF/cgi/gsdlCGI4gs3.pm@ 16505

Last change on this file since 16505 was 16505, checked in by ak19, 14 years ago

Does not read javahome and perlpath from gsdl3site.cfg, since setting them is no longer needed.

File size: 7.9 KB
Line 
1
2package gsdlCGI4gs3;
3
4use strict;
5no strict 'subs';
6no strict 'refs'; # allow filehandles to be variables and viceversa
7
8use CGI;
9use Cwd;
10
11@gsdlCGI4gs3::ISA = ('CGI');
12
13sub new {
14 my $class = shift @_;
15
16
17 my $self;
18 if ((defined $ENV{'REQUEST_METHOD'}) && ($ENV{'REQUEST_METHOD'} eq "POST")) {
19
20 # 1st check if we're dealing with the upload-coll-file cmd. Because it will be a
21 # multipart POST message and must be dealt with by the default CGI() constructor
22 if((defined $ENV{'QUERY_STRING'}) && ($ENV{'QUERY_STRING'} =~ /upload-collection-file/)) {
23 $self = new CGI();
24 }
25
26 else { # all other POST commands processed using CGI($line)
27 my $line = <STDIN>;
28 if ((defined $line) && ($line ne "")) {
29 $self = new CGI($line);
30 }
31 }
32 }
33
34 # If one of the conditions above did not hold, then self=new CGI()
35 if(!defined $self) {
36 $self = new CGI();
37 }
38
39 return bless $self, $class;
40}
41
42
43sub parse_cgi_args
44{
45 my $self = shift @_;
46 my $xml = (defined $self->param("xml")) ? 1 : 0;
47
48 $self->{'xml'} = $xml;
49
50 my @var_names = $self->param;
51 my @arg_list = ();
52 foreach my $n ( @var_names ) {
53 my $arg = "$n=";
54 my $val = $self->param($n);
55 $arg .= $val if (defined $val);
56 push(@arg_list,$arg);
57 }
58
59 $self->{'args'} = join("&",@arg_list);
60}
61
62
63sub clean_param
64{
65 my $self = shift @_;
66 my ($param) = @_;
67
68 my $val = $self->SUPER::param($param);
69 $val =~ s/[\r\n]+$// if (defined $val);
70
71 return $val;
72}
73
74sub safe_val
75{
76 my $self = shift @_;
77 my ($val) = @_;
78
79 # ensure only alpha-numeric plus a few other special chars remain
80
81 $val =~ s/[^[:alnum:]@\.\/\- :_]//g if (defined $val);
82
83 return $val;
84}
85
86
87sub generate_error
88{
89 my $self = shift @_;
90 my ($mess) = @_;
91
92 my $xml = $self->{'xml'};
93
94 my $full_mess;
95 my $args = $self->{'args'};
96
97 if ($xml) {
98 # Make $args XML safe
99 my $args_xml_safe = $args;
100 $args_xml_safe =~ s/&/&amp;/g;
101
102 $full_mess = "<Error>\n";
103 $full_mess .= " $mess\n";
104 $full_mess .= " CGI args were: $args_xml_safe\n";
105 $full_mess .= "</Error>\n";
106 }
107 else {
108 $full_mess = "ERROR: $mess\n ($args)\n";
109 }
110
111 print STDOUT "Content-type:text/plain\n\n";
112 print STDOUT $full_mess;
113
114 die $full_mess;
115}
116
117sub generate_warning
118{
119 my $self = shift @_;
120 my ($mess) = @_;
121
122 my $xml = $self->{'xml'};
123
124 my $full_mess;
125 my $args = $self->{'args'};
126
127 if ($xml) {
128 # Make $args XML safe
129 my $args_xml_safe = $args;
130 $args_xml_safe =~ s/&/&amp;/g;
131
132 $full_mess = "<Warning>\n";
133 $full_mess .= " $mess\n";
134 $full_mess .= " CGI args were: $args_xml_safe\n";
135 $full_mess .= "</Warning>\n";
136 }
137 else {
138 $full_mess = "Warning: $mess ($args)\n";
139 }
140
141 print STDOUT "Content-type:text/plain\n\n";
142 print STDOUT $full_mess;
143
144 print STDERR $full_mess;
145}
146
147
148sub generate_ok_message
149{
150 my $self = shift @_;
151 my ($mess) = @_;
152
153 my $xml = $self->{'xml'};
154
155 my $full_mess;
156
157 if ($xml) {
158 $full_mess = "<Accepted>\n";
159 $full_mess .= " $mess\n";
160 $full_mess .= "</Accepted>\n";
161 }
162 else {
163 $full_mess = "$mess\n";
164 }
165
166 print "<pre>";
167 print STDOUT $full_mess;
168 print "</pre>";
169}
170
171
172
173sub get_config_info {
174 my $self = shift @_;
175 my ($infotype) = @_;
176
177 my $site_filename = "gsdl3site.cfg";
178 open (FILEIN, "<$site_filename")
179 || $self->generate_error("Could not open gsdl3site.cfg");
180
181 my $config_content = "";
182 while(defined (my $line = <FILEIN>)) {
183 $config_content .= $line;
184 }
185 close(FILEIN);
186
187 my ($loc) = ($config_content =~ m/^$infotype\s+((\".+\")|(\S+))\s*\n/m);
188 $loc =~ s/\"//g if defined $loc;
189
190 if ((!defined $loc) || ($loc =~ m/^\s*$/)) {
191 $self->generate_error("$infotype is not set in gsdl3site.cfg");
192 }
193
194 return $loc;
195}
196
197sub get_gsdl3_src_home{
198 my $self = shift @_;
199 if (defined $self->{'gsdl3srchome'}) {
200 return $self->{'gsdl3srchome'};
201 }
202
203 my $gsdl3srchome = $self->get_config_info("gsdl3srchome");
204
205 $gsdl3srchome =~ s/(\/|\\)$//; # remove trailing slash
206
207 $self->{'gsdl3srchome'} = $gsdl3srchome;
208
209 return $gsdl3srchome;
210}
211
212
213sub get_gsdl_home {
214 my $self = shift @_;
215
216 if (defined $self->{'gsdlhome'}) {
217 return $self->{'gsdlhome'};
218 }
219
220 my $gsdlhome = $self->get_config_info("gsdlhome");
221
222 #require "$gsdlhome/perllib/util.pm";
223
224 $gsdlhome =~ s/(\/|\\)$//; # remove trailing slash
225
226 $self->{'gsdlhome'} = $gsdlhome;
227
228 return $gsdlhome;
229}
230
231sub get_java_home {
232 my $self = shift @_;
233
234 if (defined $self->{'javahome'}) {
235 return $self->{'javahome'};
236 }
237
238 my $javahome = $self->get_config_info("javahome");
239
240 $javahome =~ s/(\/|\\)$//; # remove trailing slash
241
242 $self->{'javahome'} = $javahome;
243
244 return $javahome;
245}
246
247sub get_perl_path {
248 my $self = shift @_;
249
250 if (defined $self->{'perlpath'}) {
251 return $self->{'perlpath'};
252 }
253
254 my $perlpath = $self->get_config_info("perlpath");
255
256 $perlpath =~ s/(\/|\\)$//; # remove trailing slash
257
258 return $perlpath;
259}
260
261sub get_gsdl_os {
262 my $self = shift @_;
263
264 my $os = $^O;
265
266 if ($os =~ m/linux/i) {
267 return "linux";
268 }
269 elsif ($os =~ /mswin/i) {
270 return "windows";
271 }
272 elsif ($os =~ /macos/i) {
273 return "darwin";
274 }
275 else {
276 # return as is.
277 return $os;
278 }
279}
280
281sub setup_gsdl {
282 my $self = shift @_;
283
284 my $gsdl3srchome = $self->get_gsdl3_src_home();
285 my $gsdlhome = $self->get_gsdl_home();
286 my $gsdlos = $self->get_gsdl_os();
287 #my $javahome = $self->get_java_home();
288
289 $ENV{'GSDL3SRCHOME'} = $gsdl3srchome;
290 $ENV{'GSDLHOME'} = $gsdlhome;
291 $ENV{'GSDLOS'} = $gsdlos;
292 #$ENV{'JAVA_HOME'} = $javahome;
293
294 require "$gsdlhome/perllib/util.pm";
295
296 my $gsdl_bin_script = &util::filename_cat($gsdlhome,"bin","script");
297 &util::envvar_append("PATH",$gsdl_bin_script);
298
299 my $gsdl_bin_os = &util::filename_cat($gsdlhome,"bin",$gsdlos);
300 &util::envvar_append("PATH",$gsdl_bin_os);
301
302 if ($gsdlos eq "windows") {
303 my $gsdl_perl_bin_directory = &util::filename_cat($gsdlhome, "bin", "windows", "perl", "bin");
304 &util::envvar_append("PATH", $gsdl_perl_bin_directory);
305 }
306 #else { # it's on linux now
307 #my $perlpath = $self->get_perl_path();
308 #&util::envvar_append("PATH", $perlpath);
309 #}
310}
311
312
313sub local_rm_r
314{
315 my $self = shift @_;
316 my ($local_dir) = @_;
317
318 my $prefix_dir = getcwd();
319 my $full_dir = &util::filename_cat($prefix_dir,$local_dir);
320 if ($prefix_dir !~ m/collect/) {
321 $self->generate_error("Trying to delete outside of Greenstone collect: $full_dir");
322 }
323
324 # Delete recursively
325 if (!-e $full_dir) {
326 $self->generate_error("File/Directory does not exist: $full_dir");
327 }
328
329 &util::rm_r($full_dir);
330}
331
332
333sub get_java_path()
334{
335 # Check the JAVA_HOME environment variable first
336 if (defined $ENV{'JAVA_HOME'}) {
337 my $java_home = $ENV{'JAVA_HOME'};
338 $java_home =~ s/\/$//; # Remove trailing slash if present (Unix specific)
339 return &util::filename_cat($java_home, "bin", "java");
340 }
341
342 # Hope that Java is on the PATH
343 return "java";
344}
345
346
347sub check_java_home()
348{
349 # Return a warning unless the JAVA_HOME enrivonmen variable is set
350 if (!defined $ENV{'JAVA_HOME'}) {
351 return "JAVA_HOME environment variable not set. Might not be able to find Java unless in PATH (" . $ENV{'PATH'} . ")";
352 }
353
354 return "";
355}
356
357
358sub checked_chdir
359{
360 my $self = shift @_;
361 my ($dir) = @_;
362
363 if (!-e $dir) {
364 $self->generate_error("Directory '$dir' does not exist");
365 }
366
367 chdir $dir
368 || $self->generate_error("Unable to change to directory: $dir");
369}
370
371sub rot13()
372{
373 my $self = shift @_;
374 my ($password)=@_;
375 my @password_arr=split(//,$password);
376
377 my @encrypt_password;
378 foreach my $str (@password_arr){
379 my $char=unpack("c",$str);
380 if ($char>=97 && $char<=109){
381 $char+=13;
382 }elsif ($char>=110 && $char<=122){
383 $char-=13;
384 }elsif ($char>=65 && $char<=77){
385 $char+=13;
386 }elsif ($char>=78 && $char<=90){
387 $char-=13;
388 }
389 $char=pack("c",$char);
390 push(@encrypt_password,$char);
391 }
392 return join("",@encrypt_password);
393}
394
395
3961;
397
Note: See TracBrowser for help on using the repository browser.