root/gsdl/trunk/cgi-bin/gsdlCGI.pm @ 14973

Revision 14973, 5.7 KB (checked in by davidb, 11 years ago)

Position of require "/perllib/util.pm"; reloated to assist with earlier call to &util::filename_cat

  • Property svn:keywords set to Author Date Id Revision
Line 
1
2package gsdlCGI;
3
4
5
6use CGI;
7use Cwd;
8
9@ISA = ('CGI');
10
11sub new {
12    my $class = shift @_;
13
14    my $self;
15    if ((defined $ENV{'REQUEST_METHOD'}) && ($ENV{'REQUEST_METHOD'} eq "POST")) {
16    my $line = <STDIN>;
17    if ((defined $line) && ($line ne "")) {
18        $self = new CGI($line);
19    }
20    else {
21        $self = new CGI();
22    }
23    }
24    else {
25    $self = new CGI();
26    }
27
28    return bless $self, $class;
29}
30
31
32sub parse_cgi_args
33{
34    my $self = shift @_;
35    my $xml = (defined $self->param("xml")) ? 1 : 0;
36
37    $self->{'xml'} = $xml;
38
39    my @var_names = $self->param;
40    my @arg_list = ();
41    foreach my $n ( @var_names ) {
42    my $arg = "$n=";
43    my $val =  $self->param($n);
44    $arg .= $val if (defined $val);
45    push(@arg_list,$arg);
46    }
47   
48    $self->{'args'} = join("&",@arg_list);
49}
50
51
52sub clean_param
53{
54    my $self = shift @_;
55    my ($param) = @_;
56
57    my $val = $self->SUPER::param($param);
58    $val =~ s/[\r\n]+$// if (defined $val);
59
60    return $val;
61}
62
63sub safe_val
64{
65    my $self = shift @_;
66    my ($val) = @_;
67
68    # ensure only alpha-numeric plus a few other special chars remain
69
70    $val =~ s/[^[:alnum:]@\.\/\- :_]//g if (defined $val);
71
72    return $val;
73}
74
75
76sub generate_error
77{
78    my $self = shift @_;
79    my ($mess) = @_;
80   
81    my $xml = $self->{'xml'};
82
83    my $full_mess;
84    my $args = $self->{'args'};
85
86    if ($xml) {
87    # Make $args XML safe
88    my $args_xml_safe = $args;
89    $args_xml_safe =~ s/&/&amp;/g;
90
91    $full_mess =  "<Error>\n";
92    $full_mess .= "  $mess\n";
93    $full_mess .= "  CGI args were: $args_xml_safe\n";
94    $full_mess .= "</Error>\n";
95    }
96    else {
97    $full_mess = "ERROR: $mess\n  ($args)\n";
98    }
99
100    print STDOUT "Content-type:text/plain\n\n";
101    print STDOUT $full_mess;
102
103    exit 0;
104}
105
106sub generate_warning
107{
108    my $self = shift @_;
109    my ($mess) = @_;
110   
111    my $xml = $self->{'xml'};
112
113    my $full_mess;
114    my $args = $self->{'args'};
115
116    if ($xml) {
117    # Make $args XML safe
118    my $args_xml_safe = $args;
119    $args_xml_safe =~ s/&/&amp;/g;
120
121    $full_mess =  "<Warning>\n";
122    $full_mess .= "  $mess\n";
123    $full_mess .= "  CGI args were: $args_xml_safe\n";
124    $full_mess .= "</Warning>\n";
125    }
126    else {
127    $full_mess = "Warning: $mess ($args)\n";
128    }
129
130    print STDOUT "Content-type:text/plain\n\n";
131    print STDOUT $full_mess;
132
133    print STDERR $full_mess;
134}
135
136
137sub generate_ok_message
138{
139    my $self = shift @_;
140    my ($mess) = @_;
141   
142    my $xml = $self->{'xml'};
143
144    my $full_mess;
145
146    if ($xml) {
147    $full_mess =  "<Accepted>\n";
148    $full_mess .= "  $mess\n";
149    $full_mess .= "</Accepted>\n";
150    }
151    else {
152    $full_mess = "$mess\n";
153    }
154
155    print STDOUT "Content-type:text/plain\n\n";
156    print STDOUT $full_mess;
157}
158
159
160
161sub get_config_info {
162    my $self = shift @_;
163    my ($infotype) = @_;
164
165    my $site_filename = "gsdlsite.cfg";
166    open (FILEIN, "<$site_filename")
167    || $self->generate_error("Could not open gsdlsite.cfg");
168
169    my $config_content = "";
170    while(defined (my $line = <FILEIN>)) {
171    $config_content .= $line;
172    }
173    close(FILEIN);
174
175    my ($loc) = ($config_content =~ m/^$infotype\s+((\".+\")|(\S+))\s*\n/m);
176    $loc =~ s/\"//g;
177
178    if ((!defined $loc) || ($loc =~ m/^\s*$/)) {
179    $self->generate_error("$infotype is not set in gsdlsite.cfg");
180    }
181
182    return $loc;
183}
184
185
186sub get_gsdl_home {
187    my $self = shift @_;
188   
189    if (defined $self->{'gsdlhome'}) {
190    return $self->{'gsdlhome'};
191    }
192
193    my $gsdlhome = $self->get_config_info("gsdlhome");
194
195    $gsdlhome =~ s/(\/|\\)$//; # remove trailing slash
196
197    $self->{'gsdlhome'} = $gsdlhome;
198
199    return $gsdlhome;
200}
201
202sub get_gsdl_os {
203    my $self = shift @_;
204   
205    my $os = $^O;
206
207    if ($os =~ m/linux/i) {
208    return "linux";
209    }
210    elsif ($os =~ /mswin/i) {
211    return "windows";
212    }
213    elsif ($os =~ /macos/i) {
214    return "darwin";
215    }
216    else {
217    # return as is.
218    return $os;
219    }
220}
221
222sub setup_gsdl {
223    my $self = shift @_;
224
225    my $gsdlhome = $self->get_gsdl_home();
226    my $gsdlos = $self->get_gsdl_os();
227
228    $ENV{'GSDLHOME'} = $gsdlhome;
229    $ENV{'GSDLOS'} = $gsdlos;
230
231    require "$gsdlhome/perllib/util.pm";
232
233    my $gsdl_bin_script = &util::filename_cat($gsdlhome,"bin","script");
234    &util::envvar_append("PATH",$gsdl_bin_script);
235
236    my $gsdl_bin_os = &util::filename_cat($gsdlhome,"bin",$gsdlos);
237    &util::envvar_append("PATH",$gsdl_bin_os);
238
239    if ($gsdlos eq "windows") {
240    my $gsdl_perl_bin_directory = &util::filename_cat($gsdlhome, "bin", "windows", "perl", "bin");
241    &util::envvar_append("PATH", $gsdl_perl_bin_directory);
242    }
243}
244
245
246sub local_rm_r
247{
248    my $self = shift @_;
249    my ($local_dir) = @_;
250
251    my $prefix_dir = getcwd();
252
253    if ($prefix_dir !~ m/collect/) {
254    $self->generate_error("Trying to delete outside of Greenstone collect: $full_dir");
255    }
256
257    my $full_dir = &util::filename_cat($prefix_dir,$local_dir);
258
259    # Delete recursively
260    if (!-e $full_dir) {
261    $self->generate_error("File/Directory does not exist: $full_dir");
262    }
263
264    &util::rm_r($full_dir);
265}
266
267
268sub get_java_path()
269{
270    # Check the JAVA_HOME environment variable first
271    if (defined $ENV{'JAVA_HOME'}) {
272    my $java_home = $ENV{'JAVA_HOME'};
273    $java_home =~ s/\/$//;  # Remove trailing slash if present (Unix specific)
274    return &util::filename_cat($java_home, "bin", "java");
275    }
276
277    # Hope that Java is on the PATH
278    return "java";
279}
280
281
282sub check_java_home()
283{
284    # Return a warning unless the JAVA_HOME enrivonmen variable is set
285    if (!defined $ENV{'JAVA_HOME'}) {
286    return "JAVA_HOME environment variable not set. Might not be able to find Java unless in PATH (" . $ENV{'PATH'} . ")";
287    }
288
289    return "";
290}
291
292
293sub checked_chdir
294{
295    my $self = shift @_;
296    my ($dir) = @_;
297
298    if (!-e $dir) {
299    $self->generate_error("Directory '$dir' does not exist");
300    }
301
302    chdir $dir
303    || $self->generate_error("Unable to change to directory: $dir");
304}
305
3061;
307
Note: See TracBrowser for help on using the browser.