I work mostly in a web-based environment and a good part of the problems that need to be solved is actually working within this environment.

One of my major problems is attempting to have long-running processes initiated via a web browser and all the things that go with it: making sure the process works, not using too many server resources at one time, working within a basically stateless environment, session issues, knowing how to fork() correctly, giving feedback to the user on the other end, etc. The below little cgi script is my first swing at making a progress bar for file uploads in Perl for the CGI env.

I looked around when doing research and found a few things:

So, it looked like wheel re-inventing time. Something told me the problem wasn't as hard as I thought it was and I'm glad to see with a bit of hacking, it wasn't, so below is my first stab at making a little script that has a progress bar meter for file uploads.

I consulted CPAN and did find this module: CGI::ProgressBar , but still decided to make one myself. I like having code separated from design and this module seemed to keep on the paradigm of how has methods for HTML tags that I've been trying to avoid (even though it does look sort of neat)

The heavy lifting, I realized, could come from the old workhorse, and its hook callback. I hadn't known about it before - it seems to have had a bad history (from my research) of not working in some instances, of not working AT ALL, and other such things. I don't know the current status of it and looking through the test suite for the module there... isn't any tests that I found that deal with this callback. Odd.

Along with CGI, I also used the handy module called CGI::Ajax. A handy module in of itself, it works well with my current program that used HTML::Template templates. Basically, you can feed it a string that has your HTML document and it will parse in the various Javascript bits that you need to have to then use its Javascript function to Perl function bridge. Pretty cool.

Basically, the way the script works is that when a file is uploaded, the hook callback in keeps sort of a state file of how much data has been uploaded to the server.

The AJAX calls periodically check on this state file and report that back to the browser in the form of a status bar/percent done thingy. As you probably know, AJAX can be used to update a specific <div> witin an HTML doc - so as that part of the doc is being updated, the upload itself is still going on. When the upload is done, the screen refreshed automatically. And that's it.

This script is a bit of a proof-of-concept - there are some things I'm not sure of:

I'd like to RFC this script, if possible and shape it up, so I can release it as an example on how to do this particular idea in Perl for other people. As I stated, there isn't a very clear way to do it in Perl, but there seems to be lots of ways to do it in other backend scripting languages.

Code's below the



#!/usr/bin/perl -w # Where is the upload file going? my $Upload_Dir = '/tmp'; ### That's all for user-serviceable parts. $|++; use strict; use CGI::Carp qw(fatalsToBrowser); use CGI; use CGI::Ajax; my $pjx = new CGI::Ajax('check_status' => \&check_status); my $q = CGI->new(\&hook); sub hook { my ($filename, $buffer, $bytes_read, $data) = @_; $bytes_read ||= 0; open(COUNTER, ">" . $Upload_Dir . '/' . $filename . '-meta.txt'); my $per = 0; if($ENV{CONTENT_LENGTH} > 0){ # This *should* stop us from dividi +ng by 0, right? $per = int(($bytes_read * 100) / $ENV{CONTENT_LENGTH}); } print COUNTER $per; close(COUNTER); } my $init_rand_string = 0; if(!$q->param('process')){ $init_rand_string = generate_rand_string(); } my $d = <<EOF <html> <head> </head> <body> <form name="default_form" enctype="multipart/form-data" method +="post"> <p> <input type="file" name="uploadedfile" /> </p> <input type="hidden" name="yes_upload" value="1" /> <input type="hidden" name="process" value="1" /> <input type="hidden" name="rand_string" id="rand_string" v +alue="$init_rand_string" /> <p> <input type="submit" value="upload." /> </p> <script language="Javascript"> setInterval("check_status(['check_upload__1', 'rand_string', 'uplo +adedfile'], ['statusbar']);",'1000') </script> <div id="statusbar"> </div> </body> </html> EOF ; my $outfile = $Upload_Dir . '/' . $q->param('rand_string') . '-' . $q- +>param('uploadedfile'); my $p = <<EOF <html> <head> </head> <body> <h1> Done!: </h1> <hr /> <p> $outfile </p> </body> </html> EOF ; main(); sub main { if($q->param('process')){ if($q->param('yes_upload')) { upload_that_file($q); } print $q->header(); print $p; dump_meta_file(); } else { print $pjx->build_html( $q, $d); } } sub upload_that_file { my $q = shift; my $fh = $q->upload('uploadedfile'); my $filename = $q->param('uploadedfile'); return '' if ! $filename; my $outfile = $Upload_Dir . '/' . $q->param('rand_string') . '-' . + $q->param('uploadedfile'); open (OUTFILE, '>' . $outfile) or die("can't write to " . $outfile . ": $!"); while (my $bytesread = read($fh, my $buffer, 1024)) { print OUTFILE $buffer; } close (OUTFILE); chmod(0666, $outfile); } sub check_status { my $filename = $q->param('uploadedfile'); $filename =~ s{^(.*)\/}{}; return '' if ! -f $Upload_Dir . '/' . $filename . '-meta.txt'; open my $META, '<', $Upload_Dir . '/' . $filename . '-meta.txt' o +r die $!; my $s = do { local $/; <$META> }; close ($META); my $small = 500 - ($s * 5); my $big = $s * 5; my $r = '<h1>' . $s . '%</h1>'; $r .= '<div style="width:' . $big . 'px;height:25px;background- +color:#6f0;float:left"></div>'; $r .= '<div style="width:' . $small . 'px;height:25px;backgroun +d-color:f33;float:left"></div>'; return $r; } sub dump_meta_file { my $filename = $q->param('uploadedfile'); $filename =~ s{^(.*)\/}{}; unlink($Upload_Dir . '/' . $filename . '-meta.txt') or warn "delet +ing meta file didn't work..."; } sub generate_rand_string { my $chars = shift || 'aAeEiIoOuUyYabcdefghijkmnopqrstuvwxyzABCDEFG +HJKMNPQRSTUVWXYZ23456789'; my $num = shift || 1024; require Digest::MD5; my @chars = split '', $chars; my $ran; for(1..$num){ $ran .= $chars[rand @chars]; } return Digest::MD5::md5_hex($ran); } =pod =head1 COPYRIGHT Copyright (c) 2006 Justin Simoni All rights reserved. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, + USA. =cut