Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

tk-http-file-upload-w-progress

by zentara (Archbishop)
on Mar 04, 2005 at 23:45 UTC ( #436810=snippet: print w/ replies, xml ) Need Help??

Description: Thanks to beauregard's tip in LWP Upload a file with a progress indicator, I have made a tk gui for uploading files through LWP to a cgi script. This script takes a file(s) as @ARGV, and if not given, will give you a list of files to select from in the current working directory. A default url is set in the script, but you can change it with a dialog. You could modify this to take a hash of servers and files to send to that server.

It may act funny with the bogus url I have in there. Apparently, you can send any file to it? ha ha.

#!/usr/bin/perl
use warnings;
use strict;
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
use Tk;
require Tk::ProgressBar;
use Tk::DialogBox;

#set a default $url 
my $url = 'http://foobar.net/~user/cgi-bin/up1.cgi';
my @files = @_;
my $progress = 0;
my $cancel = 0;

$|++;
my $mw  = MainWindow->new;
my $tframe =  $mw->Frame(
        -background => 'grey45' )->pack( -fill => 'x' );

$tframe->Label(
         -background => 'black',
         -foreground => 'green',
         -width => 4,
         -textvariable => \$progress,
         )->pack(-side =>'left');

$tframe->Label(
         -background => 'black',
         -foreground => 'green',
         -text => '%',
         )->pack(-side =>'left');

my $pb = $tframe->ProgressBar(
          -length => 500,
          -width  => 20,
          -from   => 0,
          -to     => 100,
          -blocks => 100,
          -colors => [ 0, 'green', 50, 'lightblue', 80, 'yellow' ],
  )->pack(-padx => 10);
############################################################## 
my $t1frame =  $mw->Frame(
        -background => 'black' )->pack( -fill => 'x' );

$t1frame->Label(
         -background => 'black',
         -foreground => 'lightblue',
         -text => 'URL:',
         )->pack(-side =>'left');

$t1frame->Label(
         -background => 'black',
         -foreground => 'lightblue',
         -width => 50,
         -textvariable => \$url,
         )->pack(-side =>'left');

############################################################## 

my $text = $mw->Scrolled("Text",
                -height => 20,
                -background => 'black',
                -foreground => 'yellow',
         )->pack( -expand => 1, -fill => 'both' );

my $bframe = $mw->Frame(
            -background => 'grey45' )->pack( -fill => 'x' );

my $button;
$button = $bframe->Button(
         -text       => 'Start Upload',
         -background => 'lightgreen',
         -command    => sub {
                       if($button->cget('-text') eq 'Start Upload'){
                           if(scalar @files == 0 ){@files =  &get_file
+s};
                           $button->configure(-text => 'Cancel',
                                        -background => 'hotpink');
                                        $cancel = 0;
                                 foreach my $file(@files){
                                   &upload_it( $url, $file);
                                   }
                          $button->configure(-text => 'Start Upload',
                            -background => 'lightgreen');
                           @files = ();

                         }else{
                         $button->configure(-text => 'Start Upload',
                                -background => 'lightgreen');
                         $cancel = 1;
                         }
                      }
                   )->pack(-side => 'left', -padx => 20);
$bframe->Button( -text => 'Select Files',
             -background => 'lightblue',
             -command  => sub {
                         @files = &get_files;
                          }
             )->pack(-side =>'left',-padx => 20);

$bframe->Button( -text => 'Select URL',
             -background => 'lightyellow',
             -command  => sub {
                         $url = &get_url;
                          }
             )->pack(-side =>'left',-padx => 20);


$bframe->Button( -text => 'Exit',
             -background => 'Red',
             -command  => sub {
                 $pb->destroy;
                 exit;
                 }
             )->pack(-side =>'right',-padx => 20);



if(scalar @files == 0 ){@files =  &get_files};

MainLoop;
############################################################ 
sub get_url{

 my $dlg = $mw->DialogBox(
       -title => 'URL Select',
       -buttons => [qw/Ok Cancel/],
     );
 my $urlin = $url;
 my $urlout;
 my $entry = $dlg->Entry(
       -width => 80,
       -textvariable => \$urlin,
          )->pack();

 if( $dlg->Show() eq 'Ok'){
 $urlout = $entry->get()
 }

return $urlout;
}
############################################################3 
sub get_files{

 my $dlg = $mw->DialogBox(
       -title => 'File Select',
       -buttons => [qw/Ok Cancel/],
     );

 my $f_frame = $dlg->Frame()->pack();

  my @files;
  push @files, $_ for <*>;
  @files = grep {  ! -d } @files;

 my $listbox = $f_frame->Scrolled("Listbox",
    -background => 'white',
    -scrollbars => "oe",
    -selectmode => "extended")->pack;
  $listbox->insert('end', @files);

@files = ();
 if( $dlg->Show() eq 'Ok'){
     my @selected_files = $listbox->curselection;
     for (@selected_files) {
        push @files, $listbox->get($_);
      }
 }

my $message = "\nSelected Files:\n".join "\n", @files;
$text->insert ('end',$message);
$text->see('end');

return @files;
}
################################################################ 

sub upload_it() {

    my ( $url , $file) = @_;
    my $size = -s $file;
    my $tot = 0;
    $pb->value(0);
    $progress = 0;
    my $start = time;
    my $starttime = scalar localtime;
    my $message =
    "\n\n\nUploading $file , size $size to\n$url\n  at $starttime\n ";

    $text->insert('end', $message);
    $text->see('end');

    $HTTP::Request::Common::DYNAMIC_FILE_UPLOAD = 1;
    my $ua = new LWP::UserAgent;

    my $req = POST $url,
      Content_Type => 'multipart/form-data',
      Content      => [ file => [$file] ];

    my $gen = $req->content();
            die unless ref($gen) eq "CODE";

    $req->content(
        sub {
            my $chunk = &$gen();
            if (defined $chunk){ $tot += length($chunk) }
            $progress = int(($tot/$size) *100);

            if($cancel){goto END}

            $pb->value($progress);
            $mw->update;
            return $chunk;
        }
    );

    my $res = $ua->request($req);   #do it 

    if ( $res->is_success ) {
        $text->insert('end', $res->as_string);
    }
    else {
        $text->insert('end',$res->status_line);
    }


END:

my $condition = 'Finished';
 if($cancel){
     $condition = 'CANCELLED';
     $cancel = 0;
     @files = ();
 }

 my $diff = time - $start;
 my $endtime = scalar localtime;

 $message =
    "$condition $file, at $endtime  total time = $diff seconds\n\n\n "
+;

     $text->insert('end', $message);
     $text->see('end');

undef $ua;
}


Comment on tk-http-file-upload-w-progress
Download Code

Back to Snippets Section

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://436810]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others wandering the Monastery: (10)
As of 2015-07-29 20:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (268 votes), past polls