Someone on the perl.beginners maillist asked about putting a progress meter on an rsync transfer running thru cgi. I told him it was not practical, but it could easily be done with a real gui. Here is the basic idea using Tk.

This is just a proof-of-concept example, and is not intended to be a "all purpose solution", and may not run on MSWindows.

This one increments on each file sent, without using the --progress option of rsync. It is simpler that way, but it's drawback is if you have really big files, the percentage done can be misleading. You can change it to "total bytes transferred" if you use the --progress option in your $cmd, and regex for the bytes sent for each file, then change your percent computation.

This script also just moves directories on your local machine, I havn't tested it on a network transfer. In the interest of simplicity, I do a dry run to get the total files to be transferred before starting the gui, so you may want to put that in a sub, so the gui starts first.

The killchd sub is needed for cancelling the transfer, because rsync will fork off many clones to do the transfers, and all child processes must be killed. 

#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::ProgressBar;
use IPC::Open3;
use Proc::Killfam;
$| = 1;

my $srcdir = '/home/zentara/testdir_in';
my $dstdir = '/home/zentara/testdir_out';

my $cmd = "rsync -r -v  $srcdir $dstdir";

#my $cmd = "rsync -r -v --bwlimit=10 $srcdir $dstdir"; 
#my $cmd = "rsync -r --dry-run  --progress  $srcdir $dstdir"; 

my $pid = open3( \*IN, \*OUT, 0, '/bin/sh' );

############################################################# 
#get a count of the files rysnc will transfer for progressbar 
my $count   = 0;
my $counter = 0;
my $percent = 0;
my $last;
my $pid1 = open( DR, " $cmd --dry-run |" ) or warn "$!\n";
while (<DR>) { $last = $_; print; $count++ }
close DR;
my ($totsize) = $last =~ /^total size is (\d+)/;
print "$count\t$totsize\n";

############################################################# 
my $mw = tkinit;

my $reader = $mw->fileevent( \*OUT, 'readable', \&get_out );

my $text = $mw->Scrolled(
    'Text',
    -bg     => 'black',
    -fg     => 'lightsteelblue',
    -width  => 80,
    -height => 5,
    -wrap   => 'none'
)->pack;

my $frame = $mw->Frame( -background => 'grey40' )
                  ->pack( -fill => 'x' );
my $butgo;
$butgo = $frame->Button(
    -text    => 'Start',
    -command => sub {
        $butgo->configure( -state => 'disabled' );
        print IN "$cmd\n";
    }
)->pack( -side => 'left', -padx => 20 );

my $butstop = $frame->Button(
    -text    => 'Cancel',
    -command => sub {
        close OUT;
        &killchd( $pid, 9 );
    }
)->pack( -side => 'left', -padx => 20 );

my $butexit = $frame->Button(
    -text    => 'Exit',
    -command => sub {
        exit;
    }
)->pack( -side => 'left', -padx => 20 );

my $l1 = $frame->Label(
    -text => '%',
    -bg   => 'black',
    -fg   => 'green',
)->pack( -side => 'right' );

my $l2 = $frame->Label(
    -textvariable => \$percent,
    -bg           => 'black',
    -fg           => 'green',
    -width        => 3,
)->pack( -side => 'right' );

my $pb = $frame->ProgressBar(
    -troughcolor => 'lightsteelblue',
    -fg          => 'hotpink',
    -blocks      => $count,
    -width       => 20,
    -length      => 200,
    -from        => 0,
    -to          => $count,
    -variable    => \$counter,
)->pack( -side => 'right', -padx => 20 );

MainLoop;
############################################################ 
sub get_out {
    my $texout = (<OUT>);
    $text->insert( 'end', "$texout" );
    $text->see('end');
    $text->update;
    $counter++;
    $percent = sprintf( '%2d', ( ( $counter / $count ) * 100 ) );
}
############################################################## 
sub killchd ($;$) {
    require Proc::ProcessTable;
    my $sig    = ( $_[1] =~ /^\-?\d+$/ ) ? $_[1] : 0;
    my $proc   = Proc::ProcessTable->new;
    my %fields = map { $_ => 1 } $proc->fields;
    return undef unless exists $fields{'ppid'};
    foreach ( @{ $proc->table } ) {
        kill $sig, $_->pid if ( $_->ppid == $_[0] );
    }
    kill $sig, $_[0];
}

__END__

[download]

Back to Cool Uses for Perl