Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??


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:

  • most of the attempts were written using php. Some of the attempts required actually patching php itself - I couldn't really figure that one out, but that's pretty crazy

  • The few examples I found in Perl seem to be very verbosely coded - either they spanned multiple files, weren't put into logical modules, were a mixture (I'm not kidding) of perl and some other backend scripting language or - the one example where the feature was in a single script - over 6,000 lines long. And none of them had a compatible license for what I needed (GPL).

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:

  • How well the CGI::Ajax module works in the Real World. I've used it in limited ways before, but this is the first time it's done something *really* cool. I'm pretty pleased with it. The documentation for the module is very well written - kudos to the developers

  • How well the hook callback in is faring. I haven't ever used it before, so I don't know if there are any ways you *shouldn't* use it. The documentation for *it* is relatively lacking. It seems that the current documentation on how to use it (from the docs), doesn't really makes sense, it states:

    You can set up a callback that will be called whenever a file upload is being read during the form processing. This is much like the UPLOAD_HOOK facility available in Apache::Request, with the exception that the first argument to the callback is an Apache::Upload object, here it's the remote filename.

    $q = CGI->new(\&hook [,$data [,$use_tempfile]]); sub hook { my ($filename, $buffer, $bytes_read, $data) = @_; print "Read $bytes_read bytes of $filename\n"; }
    is this: $q = CGI->new(\&hook [,$data [,$use_tempfile]]); valid Perl? I looked and see if it was a pod parsing error but it seems like that's the way it actually is in source. Perhaps it's simply a shorthand schematic of what is available...? In any case, it's confusing. I had to actually go to the Apache::Request docs, grok it's similar method and then do some research on how people were using *that* method and do some tests on how to use's. If I get a conclusion to how to safely use this callback, I'll annotate the current docs.
  • I doubt that the progress bar will stop the problem that sometimes on slow/large uploads, something will timeout and you'll be left with an unfinished upload. I don't know what initiates the timeout - if it's the server, or the browser, or the what. I also don't know what the workaround is - it may be a pref in the server itself or something you can't workaround in a CGI script - perhaps your program has to be for mod_perl - I don't know (but any insight is welcome)

  • My current script is not secure in any way, so please don't use it for anything :) It's just used to illustrate - I do know about its blatant security problems ;)

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

In reply to Web Browser File Upload Progress Bar in Perl w/AJAX by skazat

Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?

    What's my password?
    Create A New User
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others scrutinizing the Monastery: (3)
    As of 2021-03-03 22:06 GMT
    Find Nodes?
      Voting Booth?
      My favorite kind of desktop background is:

      Results (95 votes). Check out past polls.