1 | #!/usr/bin/perl -w
|
---|
2 |
|
---|
3 |
|
---|
4 | use strict;
|
---|
5 |
|
---|
6 | use CGI::Carp qw(fatalsToBrowser);
|
---|
7 | use CGI;
|
---|
8 |
|
---|
9 | my $gsdl_cgi;
|
---|
10 | my $gsdl_tmp_dir;
|
---|
11 |
|
---|
12 | BEGIN {
|
---|
13 |
|
---|
14 | $|=1; # Force auto-flushing for output
|
---|
15 |
|
---|
16 | eval('require "./gsdlCGI.pm"');
|
---|
17 | if ($@)
|
---|
18 | {
|
---|
19 | print STDOUT "Content-type:text/plain\n\n";
|
---|
20 | print STDOUT "ERROR: $@\n";
|
---|
21 | exit 0;
|
---|
22 | }
|
---|
23 |
|
---|
24 | }
|
---|
25 |
|
---|
26 |
|
---|
27 | sub get_progress_filename
|
---|
28 | {
|
---|
29 | my ($uploaded_file) = @_;
|
---|
30 |
|
---|
31 | my $progress_file = $uploaded_file;
|
---|
32 |
|
---|
33 | $progress_file =~ s{^(.*)\/}{};
|
---|
34 | $progress_file =~ s/\.*?$//;
|
---|
35 | $progress_file .= "-progress.txt";
|
---|
36 |
|
---|
37 | my $progress_filename = &util::filename_cat($gsdl_tmp_dir, $progress_file);
|
---|
38 |
|
---|
39 | return $progress_filename;
|
---|
40 | }
|
---|
41 |
|
---|
42 | sub get_file_central_filename
|
---|
43 | {
|
---|
44 | my $file_central = &util::filename_cat($gsdl_tmp_dir,"file-central.txt");
|
---|
45 |
|
---|
46 | return $file_central;
|
---|
47 | }
|
---|
48 |
|
---|
49 | sub read_file_central
|
---|
50 | {
|
---|
51 | my $fc_filename = get_file_central_filename();
|
---|
52 |
|
---|
53 | my @fc_list;
|
---|
54 |
|
---|
55 | if (open(FCIN,"<$fc_filename")) {
|
---|
56 |
|
---|
57 | my $fc_list_str = do { local $/; <FCIN> };
|
---|
58 | @fc_list = split(/\n/,$fc_list_str);
|
---|
59 |
|
---|
60 | close(FCIN);
|
---|
61 | }
|
---|
62 | else {
|
---|
63 | # OK to have no file-central.txt to start with
|
---|
64 | # return empty list
|
---|
65 | @fc_list = ();
|
---|
66 | }
|
---|
67 |
|
---|
68 | return \@fc_list;
|
---|
69 |
|
---|
70 | }
|
---|
71 |
|
---|
72 | sub remove_from_file_central
|
---|
73 | {
|
---|
74 | my ($filename,$fc_list) = @_;
|
---|
75 |
|
---|
76 | my @new_fc_list = ();
|
---|
77 |
|
---|
78 | my $removed = 0;
|
---|
79 |
|
---|
80 | foreach my $f (@$fc_list) {
|
---|
81 |
|
---|
82 | if ($f ne $filename) {
|
---|
83 | push(@new_fc_list,$f);
|
---|
84 | }
|
---|
85 | else {
|
---|
86 | $removed = 1;
|
---|
87 | }
|
---|
88 | }
|
---|
89 |
|
---|
90 | if (!$removed) {
|
---|
91 | print STDERR "Warning: Failed to locate '$filename' in file-central.txt\n";
|
---|
92 | }
|
---|
93 |
|
---|
94 | return \@new_fc_list;
|
---|
95 | }
|
---|
96 |
|
---|
97 | sub add_to_file_central
|
---|
98 | {
|
---|
99 | my ($filename,$fc_list) = @_;
|
---|
100 |
|
---|
101 | my @new_fc_list = @$fc_list;
|
---|
102 |
|
---|
103 | my $duplicate = 0;
|
---|
104 | foreach my $f (@new_fc_list) {
|
---|
105 |
|
---|
106 | if ($f eq $filename) {
|
---|
107 | $duplicate = 1;
|
---|
108 | }
|
---|
109 | }
|
---|
110 |
|
---|
111 | if (!$duplicate) {
|
---|
112 | push(@new_fc_list,$filename);
|
---|
113 | }
|
---|
114 | else {
|
---|
115 | print STDERR "Warning: Ingoring request to add duplicate entry:\n";
|
---|
116 | print STDERR " '$filename' into file-central.txt\n"
|
---|
117 | }
|
---|
118 |
|
---|
119 | return \@new_fc_list;
|
---|
120 | }
|
---|
121 |
|
---|
122 |
|
---|
123 |
|
---|
124 | sub write_file_central
|
---|
125 | {
|
---|
126 | my ($fc_list) = @_;
|
---|
127 |
|
---|
128 | my $fc_filename = get_file_central_filename();
|
---|
129 |
|
---|
130 | if (open(FCOUT,">$fc_filename")) {
|
---|
131 |
|
---|
132 | foreach my $f (@$fc_list) {
|
---|
133 | print FCOUT "$f\n";
|
---|
134 | }
|
---|
135 |
|
---|
136 | close(FCOUT);
|
---|
137 | }
|
---|
138 | else {
|
---|
139 | print STDERR "Error: Failed to write out $fc_filename\n";
|
---|
140 | print STDERR "$!\n";
|
---|
141 | }
|
---|
142 | }
|
---|
143 |
|
---|
144 | sub monitor_upload
|
---|
145 | {
|
---|
146 | my ($uploading_file, $buffer, $bytes_read, $data) = @_;
|
---|
147 |
|
---|
148 | $bytes_read ||= 0;
|
---|
149 |
|
---|
150 | my $progress_filename = get_progress_filename($uploading_file);
|
---|
151 |
|
---|
152 | if (! -f $progress_filename) {
|
---|
153 | my $fc_list = read_file_central();
|
---|
154 | $fc_list = add_to_file_central($uploading_file,$fc_list);
|
---|
155 | write_file_central($fc_list);
|
---|
156 | }
|
---|
157 |
|
---|
158 | open(COUNTER, ">$progress_filename");
|
---|
159 |
|
---|
160 | my $per = 0;
|
---|
161 | if ($ENV{CONTENT_LENGTH} > 0) {
|
---|
162 | $per = int(($bytes_read * 100) / $ENV{CONTENT_LENGTH});
|
---|
163 | }
|
---|
164 | print COUNTER $per;
|
---|
165 | close(COUNTER);
|
---|
166 |
|
---|
167 | # Useful debug to slow down a 'fast' upload
|
---|
168 | # Sleep for 10 msecs
|
---|
169 | select(undef, undef, undef, 0.01);
|
---|
170 | #select(undef, undef, undef, 0.1);
|
---|
171 | }
|
---|
172 |
|
---|
173 |
|
---|
174 |
|
---|
175 | sub upload_file {
|
---|
176 |
|
---|
177 | my ($gsdl_cgi,$full_filename) = @_;
|
---|
178 |
|
---|
179 | my $fh = $gsdl_cgi->upload('uploadedfile');
|
---|
180 | my $filename = $gsdl_cgi->param('uploadedfile');
|
---|
181 |
|
---|
182 | return '' if ! $filename;
|
---|
183 |
|
---|
184 | open (OUTFILE, '>' . $full_filename)
|
---|
185 | || die("Can't write to $full_filename: $!");
|
---|
186 |
|
---|
187 | binmode(OUTFILE);
|
---|
188 |
|
---|
189 | while (my $bytesread = read($fh, my $buffer, 1024)) {
|
---|
190 | print OUTFILE $buffer;
|
---|
191 | }
|
---|
192 |
|
---|
193 | close (OUTFILE);
|
---|
194 | chmod(0666, $full_filename);
|
---|
195 |
|
---|
196 | }
|
---|
197 |
|
---|
198 | sub remove_progress_file
|
---|
199 | {
|
---|
200 | my ($uploaded_file) = @_;
|
---|
201 |
|
---|
202 | my $progress_filename = get_progress_filename($uploaded_file);
|
---|
203 |
|
---|
204 | if (!unlink($progress_filename)) {
|
---|
205 | print STDERR "Warning: Failed to delete $progress_filename\n";
|
---|
206 | }
|
---|
207 |
|
---|
208 | my $fc_list = read_file_central();
|
---|
209 | $fc_list = remove_from_file_central($uploaded_file,$fc_list);
|
---|
210 | write_file_central($fc_list);
|
---|
211 | }
|
---|
212 |
|
---|
213 |
|
---|
214 | sub main {
|
---|
215 |
|
---|
216 | # gsdlCGI->prenew() constructs a 'lite' version of the object where the
|
---|
217 | # GSDL environment has been setup
|
---|
218 | #
|
---|
219 | # This is needed because the main call the gsdlCGI->new takes an
|
---|
220 | # initializer rountine -- monitor_upload() -- as a parameter, AND THAT
|
---|
221 | # routine (which is called before the constructor is finished) needs to
|
---|
222 | # know the tmp directory to use to write out the progress file.
|
---|
223 |
|
---|
224 | my $gsdl_config = gsdlCGI->prenew();
|
---|
225 | $gsdl_tmp_dir = &util::get_toplevel_tmp_dir();
|
---|
226 |
|
---|
227 | require talkback;
|
---|
228 |
|
---|
229 | # Use the initializer mechanism so a 'callback' routine can monitor
|
---|
230 | # the progress of how much data has been uploaded
|
---|
231 |
|
---|
232 | $gsdl_cgi = gsdlCGI->new(\&monitor_upload);
|
---|
233 |
|
---|
234 |
|
---|
235 | require CGI::Ajax;
|
---|
236 |
|
---|
237 | my $perlAjax = new CGI::Ajax('check_status' => \&check_status);
|
---|
238 |
|
---|
239 |
|
---|
240 | if ($gsdl_cgi->param('process')) {
|
---|
241 |
|
---|
242 | my $uploadedfile = $gsdl_cgi->param('uploadedfile');
|
---|
243 | my $full_filename = &util::filename_cat($gsdl_tmp_dir,$uploadedfile);
|
---|
244 |
|
---|
245 | my $done_html = &talkback::generate_done_html($full_filename);
|
---|
246 |
|
---|
247 | if ($gsdl_cgi->param('yes_upload')) {
|
---|
248 | upload_file($gsdl_cgi,$full_filename);
|
---|
249 | }
|
---|
250 |
|
---|
251 | print $gsdl_cgi->header();
|
---|
252 | print $done_html;
|
---|
253 |
|
---|
254 | remove_progress_file($gsdl_cgi->param('uploadedfile'));
|
---|
255 | }
|
---|
256 | else {
|
---|
257 |
|
---|
258 | my $upload_html_form;
|
---|
259 |
|
---|
260 | #my $oid = $gsdl_cgi->param('oid');
|
---|
261 | #my $collect = $gsdl_cgi->param('collect');
|
---|
262 | my $uniq_file = $gsdl_cgi->param('uploadedfile');
|
---|
263 |
|
---|
264 | #my $uniq_file = "$collect-$oid-doc.xml";
|
---|
265 | # Light-weight (hidden) form with progress bar
|
---|
266 |
|
---|
267 | $upload_html_form
|
---|
268 | = &talkback::generate_upload_form_progressbar($uniq_file);
|
---|
269 |
|
---|
270 | print $perlAjax->build_html($gsdl_cgi, $upload_html_form);
|
---|
271 | }
|
---|
272 | }
|
---|
273 |
|
---|
274 |
|
---|
275 | main();
|
---|
276 |
|
---|
277 |
|
---|
278 | #=====
|
---|
279 |
|
---|
280 | sub inc_wait_dots
|
---|
281 | {
|
---|
282 | my $wait_filename = &util::filename_cat($gsdl_tmp_dir,"wait.txt");
|
---|
283 | open(WIN,"<$wait_filename");
|
---|
284 | my $wait = <WIN>;
|
---|
285 | close(WIN);
|
---|
286 |
|
---|
287 | $wait = ($wait+1) %6;
|
---|
288 | my $wait_dots = "." x ($wait+1);
|
---|
289 |
|
---|
290 | open(WOUT,">$wait_filename");
|
---|
291 | print WOUT "$wait\n";
|
---|
292 | close(WOUT);
|
---|
293 |
|
---|
294 | return $wait_dots;
|
---|
295 | }
|
---|
296 |
|
---|
297 |
|
---|
298 | sub check_status_single_file
|
---|
299 | {
|
---|
300 | my ($filename) = @_;
|
---|
301 |
|
---|
302 | my $monitor_filename = get_progress_filename($filename);
|
---|
303 |
|
---|
304 | if (! -f $monitor_filename ) {
|
---|
305 | return "";
|
---|
306 | }
|
---|
307 |
|
---|
308 | open my $PROGRESS, '<', $monitor_filename or die $!;
|
---|
309 | my $s = do { local $/; <$PROGRESS> };
|
---|
310 | close ($PROGRESS);
|
---|
311 |
|
---|
312 | my $fgwidth = int($s * 1.5);
|
---|
313 | my $bgwidth = 150 - $fgwidth;
|
---|
314 |
|
---|
315 | my $fgcol = "background-color:#dddd00;";
|
---|
316 | my $bgcol = "background-color:#008000;";
|
---|
317 |
|
---|
318 | my $style_base = "height:10px; float:left;";
|
---|
319 |
|
---|
320 | my $r = "";
|
---|
321 | $r .= "<div>$filename:</div>";
|
---|
322 | $r .= "<nobr>";
|
---|
323 | $r .= "<div style=\"width: ${fgwidth}px; $fgcol $style_base\"></div>";
|
---|
324 | $r .= "<div style=\"width: ${bgwidth}px; $bgcol $style_base\"></div>";
|
---|
325 | $r .= "<div style=\"float:left; width: 80px\"> $s%</div>";
|
---|
326 | $r .= "</nobr>";
|
---|
327 | $r .= "<br />";
|
---|
328 |
|
---|
329 | return $r;
|
---|
330 | }
|
---|
331 |
|
---|
332 |
|
---|
333 | sub check_status_all
|
---|
334 | {
|
---|
335 | my $file_central = get_file_central_filename();
|
---|
336 |
|
---|
337 | my $html = "";
|
---|
338 |
|
---|
339 | my $fc_list = read_file_central();
|
---|
340 |
|
---|
341 | foreach my $f (@$fc_list) {
|
---|
342 | $html .= check_status_single_file($f);
|
---|
343 | }
|
---|
344 |
|
---|
345 | return $html;
|
---|
346 |
|
---|
347 | }
|
---|
348 |
|
---|
349 |
|
---|
350 | # Accessed from HTML web page through the majic of perlAjax
|
---|
351 |
|
---|
352 | sub check_status
|
---|
353 | {
|
---|
354 |
|
---|
355 | my $wait_dots = inc_wait_dots();
|
---|
356 | my $html = "$wait_dots<br>";
|
---|
357 |
|
---|
358 | my $filename = $gsdl_cgi->param('uploadedfile');
|
---|
359 |
|
---|
360 | if ((defined $filename) && ($filename ne "")) {
|
---|
361 | $html .= check_status_single_file($filename);
|
---|
362 | }
|
---|
363 | else {
|
---|
364 | $html .= check_status_all();
|
---|
365 | }
|
---|
366 |
|
---|
367 | return $html;
|
---|
368 | }
|
---|