1 | #!/usr/bin/perl -w
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 |
|
---|
5 | use CGI::Carp qw(fatalsToBrowser);
|
---|
6 | use CGI;
|
---|
7 |
|
---|
8 | my $gsdl_cgi;
|
---|
9 | my $gsdl_home;
|
---|
10 | my $gsdl_tmp_dir;
|
---|
11 |
|
---|
12 | my $debugging_enabled = 0; # if 1, if enabled deleting files will not happen
|
---|
13 |
|
---|
14 | BEGIN {
|
---|
15 |
|
---|
16 | $|=1; # Force auto-flushing for output
|
---|
17 |
|
---|
18 | eval('require "./gsdlCGI.pm"');
|
---|
19 | if ($@)
|
---|
20 | {
|
---|
21 | print STDOUT "Content-type:text/plain\n\n";
|
---|
22 | print STDOUT "ERROR: $@\n";
|
---|
23 | exit 0;
|
---|
24 | }
|
---|
25 |
|
---|
26 | }
|
---|
27 |
|
---|
28 |
|
---|
29 | sub get_progress_filename
|
---|
30 | {
|
---|
31 | my ($uploaded_file) = @_;
|
---|
32 |
|
---|
33 | my $progress_file = $uploaded_file;
|
---|
34 |
|
---|
35 | $progress_file =~ s{^(.*)\/}{};
|
---|
36 | $progress_file =~ s/\.*?$//;
|
---|
37 | $progress_file .= "-progress.txt";
|
---|
38 |
|
---|
39 | my $progress_filename = &util::filename_cat($gsdl_tmp_dir, $progress_file);
|
---|
40 |
|
---|
41 | return $progress_filename;
|
---|
42 | }
|
---|
43 |
|
---|
44 | sub get_file_central_filename
|
---|
45 | {
|
---|
46 | my $file_central = &util::filename_cat($gsdl_tmp_dir,"file-central.txt");
|
---|
47 |
|
---|
48 | return $file_central;
|
---|
49 | }
|
---|
50 |
|
---|
51 | sub read_file_central
|
---|
52 | {
|
---|
53 | my $fc_filename = get_file_central_filename();
|
---|
54 |
|
---|
55 | my @fc_list;
|
---|
56 |
|
---|
57 | if (open(FCIN,"<$fc_filename")) {
|
---|
58 |
|
---|
59 | my $fc_list_str = do { local $/; <FCIN> };
|
---|
60 | @fc_list = split(/\n/,$fc_list_str);
|
---|
61 |
|
---|
62 | close(FCIN);
|
---|
63 | }
|
---|
64 | else {
|
---|
65 | # OK to have no file-central.txt to start with
|
---|
66 | # return empty list
|
---|
67 | @fc_list = ();
|
---|
68 | }
|
---|
69 |
|
---|
70 | return \@fc_list;
|
---|
71 |
|
---|
72 | }
|
---|
73 |
|
---|
74 | sub remove_from_file_central
|
---|
75 | {
|
---|
76 | my ($filename,$fc_list) = @_;
|
---|
77 |
|
---|
78 | my @new_fc_list = ();
|
---|
79 |
|
---|
80 | my $removed = 0;
|
---|
81 |
|
---|
82 | foreach my $f (@$fc_list) {
|
---|
83 |
|
---|
84 | if ($f ne $filename) {
|
---|
85 | push(@new_fc_list,$f);
|
---|
86 | }
|
---|
87 | else {
|
---|
88 | $removed = 1;
|
---|
89 | }
|
---|
90 | }
|
---|
91 |
|
---|
92 | if (!$removed) {
|
---|
93 | print STDERR "Warning: Failed to locate '$filename' in file-central.txt\n";
|
---|
94 | }
|
---|
95 |
|
---|
96 | return \@new_fc_list;
|
---|
97 | }
|
---|
98 |
|
---|
99 | sub add_to_file_central
|
---|
100 | {
|
---|
101 | my ($filename,$fc_list) = @_;
|
---|
102 |
|
---|
103 | my @new_fc_list = @$fc_list;
|
---|
104 |
|
---|
105 | my $duplicate = 0;
|
---|
106 | foreach my $f (@new_fc_list) {
|
---|
107 |
|
---|
108 | if ($f eq $filename) {
|
---|
109 | $duplicate = 1;
|
---|
110 | }
|
---|
111 | }
|
---|
112 |
|
---|
113 | if (!$duplicate) {
|
---|
114 | push(@new_fc_list,$filename);
|
---|
115 | }
|
---|
116 | else {
|
---|
117 | print STDERR "Warning: Ingoring request to add duplicate entry:\n";
|
---|
118 | print STDERR " '$filename' into file-central.txt\n"
|
---|
119 | }
|
---|
120 |
|
---|
121 | return \@new_fc_list;
|
---|
122 | }
|
---|
123 |
|
---|
124 |
|
---|
125 |
|
---|
126 | sub write_file_central
|
---|
127 | {
|
---|
128 | my ($fc_list) = @_;
|
---|
129 |
|
---|
130 | my $fc_filename = get_file_central_filename();
|
---|
131 |
|
---|
132 |
|
---|
133 | if (open(FCOUT,">$fc_filename")) {
|
---|
134 |
|
---|
135 | foreach my $f (@$fc_list) {
|
---|
136 | print FCOUT "$f\n";
|
---|
137 | }
|
---|
138 |
|
---|
139 | close(FCOUT);
|
---|
140 |
|
---|
141 |
|
---|
142 | # Ensure it can be edited by owner of Greenstone install (if needed)
|
---|
143 | chmod(0777,$fc_filename);
|
---|
144 | }
|
---|
145 | else {
|
---|
146 | print STDERR "Error: Failed to write out $fc_filename\n";
|
---|
147 | print STDERR "$!\n";
|
---|
148 | }
|
---|
149 | }
|
---|
150 |
|
---|
151 | sub monitor_upload
|
---|
152 | {
|
---|
153 | my ($uploading_file, $buffer, $bytes_read, $data) = @_;
|
---|
154 |
|
---|
155 | $bytes_read ||= 0;
|
---|
156 |
|
---|
157 | my $progress_filename = get_progress_filename($uploading_file);
|
---|
158 |
|
---|
159 | if (! -f $progress_filename) {
|
---|
160 | my $fc_list = read_file_central();
|
---|
161 | $fc_list = add_to_file_central($uploading_file,$fc_list);
|
---|
162 | write_file_central($fc_list);
|
---|
163 | }
|
---|
164 |
|
---|
165 | open(COUNTER, ">$progress_filename");
|
---|
166 |
|
---|
167 | my $per = 0;
|
---|
168 | if ($ENV{CONTENT_LENGTH} > 0) {
|
---|
169 | $per = int(($bytes_read * 100) / $ENV{CONTENT_LENGTH});
|
---|
170 | }
|
---|
171 | print COUNTER $per;
|
---|
172 | close(COUNTER);
|
---|
173 |
|
---|
174 | # Useful debug to slow down a 'fast' upload
|
---|
175 | # Sleep for 10 msecs
|
---|
176 | #select(undef, undef, undef, 0.01);
|
---|
177 | #select(undef, undef, undef, 0.1);
|
---|
178 | }
|
---|
179 |
|
---|
180 |
|
---|
181 |
|
---|
182 | sub upload_file {
|
---|
183 |
|
---|
184 | my ($gsdl_cgi,$full_filename) = @_;
|
---|
185 |
|
---|
186 | my $fh = $gsdl_cgi->upload('uploadedfile');
|
---|
187 | my $filename = $gsdl_cgi->param('uploadedfile');
|
---|
188 |
|
---|
189 | return '' if ! $filename;
|
---|
190 |
|
---|
191 | open (OUTFILE, '>' . $full_filename)
|
---|
192 | || die("Can't write to $full_filename: $!");
|
---|
193 |
|
---|
194 | binmode(OUTFILE);
|
---|
195 |
|
---|
196 | while (my $bytesread = read($fh, my $buffer, 1024)) {
|
---|
197 | print OUTFILE $buffer;
|
---|
198 | }
|
---|
199 |
|
---|
200 | close (OUTFILE);
|
---|
201 | chmod(0666, $full_filename);
|
---|
202 |
|
---|
203 | }
|
---|
204 |
|
---|
205 | sub remove_progress_file
|
---|
206 | {
|
---|
207 | my ($uploaded_file) = @_;
|
---|
208 |
|
---|
209 | my $progress_filename = get_progress_filename($uploaded_file);
|
---|
210 |
|
---|
211 | unlink($progress_filename)
|
---|
212 | unless $debugging_enabled;
|
---|
213 |
|
---|
214 | my $fc_list = read_file_central();
|
---|
215 | $fc_list = remove_from_file_central($uploaded_file,$fc_list);
|
---|
216 | write_file_central($fc_list);
|
---|
217 | }
|
---|
218 |
|
---|
219 |
|
---|
220 | sub unzip_archives_doc
|
---|
221 | {
|
---|
222 | my ($gsdl_cgi,$gsdl_home,$collect_home,$collect,$zip_filename) = @_;
|
---|
223 |
|
---|
224 | my $lang_env = $gsdl_cgi->clean_param("lr") || "";
|
---|
225 |
|
---|
226 | my $import_dir = &util::filename_cat($collect_home,$collect,"import");
|
---|
227 |
|
---|
228 | # Unzip $zip_filename in the collection's import folder
|
---|
229 | my $java = $gsdl_cgi->get_java_path();
|
---|
230 | my $jar_dir= &util::filename_cat($gsdl_home, "bin", "java");
|
---|
231 | my $java_classpath = &util::filename_cat($jar_dir,"GLIServer.jar");
|
---|
232 |
|
---|
233 | if (!-f $java_classpath) {
|
---|
234 | my $progname = $0;
|
---|
235 | $progname =~ s/^.*[\/\\]//;
|
---|
236 | my $mess = "$progname:\nFailed to find $java_classpath\n";
|
---|
237 | $gsdl_cgi->generate_error($mess);
|
---|
238 | }
|
---|
239 |
|
---|
240 | my $java_args = "\"$zip_filename\" \"$import_dir\"";
|
---|
241 |
|
---|
242 | $ENV{'LANG'} = $lang_env;
|
---|
243 | my $java_command = "\"$java\" -classpath \"$java_classpath\" org.greenstone.gatherer.remote.Unzip $java_args";
|
---|
244 |
|
---|
245 | my $java_output = `$java_command`;
|
---|
246 | my $java_status = $?;
|
---|
247 | if ($java_status > 0) {
|
---|
248 | my $report = "Java failed: $java_command\n--\n";
|
---|
249 | $report .= "$java_output\n";
|
---|
250 | $report .= "Exit status: " . ($java_status / 256) . "\n";
|
---|
251 | $report .= $gsdl_cgi->check_java_home();
|
---|
252 |
|
---|
253 | $gsdl_cgi->generate_error($report);
|
---|
254 | }
|
---|
255 | else {
|
---|
256 | # Remove the zip file once we have unzipped it, since it is an intermediate file only
|
---|
257 | `chmod -R a+rw $import_dir/HASH*`;
|
---|
258 | unlink($zip_filename) unless $debugging_enabled;
|
---|
259 | }
|
---|
260 | }
|
---|
261 |
|
---|
262 |
|
---|
263 | sub rebuild_collection
|
---|
264 | {
|
---|
265 | my ($collect) = @_;
|
---|
266 |
|
---|
267 | my $bin_script = &util::filename_cat($gsdl_home,"bin","script");
|
---|
268 | ## my $inc_rebuild_pl = &util::filename_cat($bin_script,"incremental-rebuild.pl");
|
---|
269 |
|
---|
270 | my $rebuild_cmd = "perl -S incremental-rebuild.pl \"$collect\"";
|
---|
271 |
|
---|
272 | my $rebuild_output = `$rebuild_cmd 2>&1`;
|
---|
273 | my $rebuild_status = $?;
|
---|
274 | if ($rebuild_status > 0) {
|
---|
275 | my $report = "Perl rebuild failed: $rebuild_cmd\n--\n";
|
---|
276 | $report .= "$rebuild_output\n";
|
---|
277 | $report .= "Exit status: " . ($rebuild_status / 256) . "\n";
|
---|
278 | ## $report .= $gsdl_cgi->check_perl_home();
|
---|
279 |
|
---|
280 | # $report .= "PATH = ". $ENV{'PATH'}. "\n";
|
---|
281 |
|
---|
282 |
|
---|
283 | $gsdl_cgi->generate_error($report);
|
---|
284 | }
|
---|
285 | }
|
---|
286 |
|
---|
287 | sub main {
|
---|
288 |
|
---|
289 | # gsdlCGI->prenew() constructs a 'lite' version of the object where the
|
---|
290 | # GSDL environment has been setup
|
---|
291 | #
|
---|
292 | # This is needed because the main call the gsdlCGI->new takes an
|
---|
293 | # initializer rountine -- monitor_upload() -- as a parameter, AND THAT
|
---|
294 | # routine (which is called before the constructor is finished) needs to
|
---|
295 | # know the tmp directory to use to write out the progress file.
|
---|
296 |
|
---|
297 | my $gsdl_config = gsdlCGI->prenew();
|
---|
298 |
|
---|
299 | $gsdl_home = $gsdl_config->get_gsdl_home();
|
---|
300 | $gsdl_tmp_dir = &util::get_toplevel_tmp_dir();
|
---|
301 |
|
---|
302 | require talkback;
|
---|
303 |
|
---|
304 | # Use the initializer mechanism so a 'callback' routine can monitor
|
---|
305 | # the progress of how much data has been uploaded
|
---|
306 |
|
---|
307 | $gsdl_cgi = gsdlCGI->new(\&monitor_upload);
|
---|
308 |
|
---|
309 |
|
---|
310 | require CGI::Ajax;
|
---|
311 |
|
---|
312 | my $perlAjax = new CGI::Ajax('check_status' => \&check_status);
|
---|
313 |
|
---|
314 |
|
---|
315 | if ($gsdl_cgi->param('process')) {
|
---|
316 |
|
---|
317 | my $uploaded_file = $gsdl_cgi->param('uploadedfile');
|
---|
318 | my $full_filename = &util::filename_cat($gsdl_tmp_dir,$uploaded_file);
|
---|
319 |
|
---|
320 | my $done_html = &talkback::generate_done_html($full_filename);
|
---|
321 |
|
---|
322 | if ($gsdl_cgi->param('yes_upload')) {
|
---|
323 | upload_file($gsdl_cgi,$full_filename);
|
---|
324 |
|
---|
325 | my $collect = $gsdl_cgi->param('toCollect');
|
---|
326 | my $collect_home = &util::filename_cat($gsdl_home,"collect");
|
---|
327 |
|
---|
328 | unzip_archives_doc($gsdl_cgi,$gsdl_home,$collect_home,$collect,$full_filename);
|
---|
329 | rebuild_collection($collect);
|
---|
330 | }
|
---|
331 |
|
---|
332 | print $gsdl_cgi->header();
|
---|
333 | print $done_html;
|
---|
334 |
|
---|
335 | remove_progress_file($uploaded_file);
|
---|
336 | }
|
---|
337 | else {
|
---|
338 |
|
---|
339 | my $upload_html_form;
|
---|
340 |
|
---|
341 | #my $oid = $gsdl_cgi->param('oid');
|
---|
342 | #my $collect = $gsdl_cgi->param('collect');
|
---|
343 | my $uniq_file = $gsdl_cgi->param('uploadedfile');
|
---|
344 |
|
---|
345 | #my $uniq_file = "$collect-$oid-doc.zip";
|
---|
346 | # Light-weight (hidden) form with progress bar
|
---|
347 |
|
---|
348 | $upload_html_form
|
---|
349 | = &talkback::generate_upload_form_progressbar($uniq_file);
|
---|
350 |
|
---|
351 | print $perlAjax->build_html($gsdl_cgi, $upload_html_form);
|
---|
352 | }
|
---|
353 | }
|
---|
354 |
|
---|
355 |
|
---|
356 | main();
|
---|
357 |
|
---|
358 |
|
---|
359 | #=====
|
---|
360 |
|
---|
361 | sub inc_wait_dots
|
---|
362 | {
|
---|
363 | my $wait_filename = &util::filename_cat($gsdl_tmp_dir,"wait.txt");
|
---|
364 | open(WIN,"<$wait_filename");
|
---|
365 | my $wait = <WIN>;
|
---|
366 | close(WIN);
|
---|
367 |
|
---|
368 | $wait = ($wait+1) %6;
|
---|
369 | my $wait_dots = "." x ($wait+1);
|
---|
370 |
|
---|
371 | open(WOUT,">$wait_filename");
|
---|
372 | print WOUT "$wait\n";
|
---|
373 | close(WOUT);
|
---|
374 |
|
---|
375 | return $wait_dots;
|
---|
376 | }
|
---|
377 |
|
---|
378 |
|
---|
379 | sub check_status_single_file
|
---|
380 | {
|
---|
381 | my ($filename) = @_;
|
---|
382 |
|
---|
383 | my $monitor_filename = get_progress_filename($filename);
|
---|
384 |
|
---|
385 | if (! -f $monitor_filename ) {
|
---|
386 | return "";
|
---|
387 | }
|
---|
388 |
|
---|
389 | open my $PROGRESS, '<', $monitor_filename or die $!;
|
---|
390 | my $s = do { local $/; <$PROGRESS> };
|
---|
391 | close ($PROGRESS);
|
---|
392 |
|
---|
393 | my $fgwidth = int($s * 1.5);
|
---|
394 | my $bgwidth = 150 - $fgwidth;
|
---|
395 |
|
---|
396 | my $fgcol = "background-color:#dddd00;";
|
---|
397 | my $bgcol = "background-color:#008000;";
|
---|
398 |
|
---|
399 | my $style_base = "height:10px; float:left;";
|
---|
400 |
|
---|
401 | my $r = "";
|
---|
402 | $r .= "<div>$filename:</div>";
|
---|
403 | $r .= "<nobr>";
|
---|
404 | $r .= "<div style=\"width: ${fgwidth}px; $fgcol $style_base\"></div>";
|
---|
405 | $r .= "<div style=\"width: ${bgwidth}px; $bgcol $style_base\"></div>";
|
---|
406 | $r .= "<div style=\"float:left; width: 80px\"> $s%</div>";
|
---|
407 | $r .= "</nobr>";
|
---|
408 | $r .= "<br />";
|
---|
409 |
|
---|
410 | return $r;
|
---|
411 | }
|
---|
412 |
|
---|
413 |
|
---|
414 | sub check_status_all
|
---|
415 | {
|
---|
416 | my $file_central = get_file_central_filename();
|
---|
417 |
|
---|
418 | my $html = "";
|
---|
419 |
|
---|
420 | my $fc_list = read_file_central();
|
---|
421 |
|
---|
422 | foreach my $f (@$fc_list) {
|
---|
423 | $html .= check_status_single_file($f);
|
---|
424 | }
|
---|
425 |
|
---|
426 | return $html;
|
---|
427 |
|
---|
428 | }
|
---|
429 |
|
---|
430 |
|
---|
431 | # Accessed from HTML web page through the majic of perlAjax
|
---|
432 |
|
---|
433 | sub check_status
|
---|
434 | {
|
---|
435 |
|
---|
436 | my $wait_dots = inc_wait_dots();
|
---|
437 | my $dots_html = "Waiting for transfer: $wait_dots<br>";
|
---|
438 |
|
---|
439 | my $filename = $gsdl_cgi->param('uploadedfile');
|
---|
440 |
|
---|
441 | my $inner_html;
|
---|
442 |
|
---|
443 | if ((defined $filename) && ($filename ne "")) {
|
---|
444 | $inner_html = check_status_single_file($filename);
|
---|
445 | }
|
---|
446 | else {
|
---|
447 | $inner_html = check_status_all();
|
---|
448 | }
|
---|
449 |
|
---|
450 | my $html = ($inner_html ne "") ? $inner_html : $dots_html;
|
---|
451 |
|
---|
452 | return $html;
|
---|
453 | }
|
---|