END
{
    $widget->quit;
}


# create two bars - 'execution report' and 'some other report'
my $widget = new ProgressWidget("Execution Report", "Some Other Report
+");

my $pid;
if ($pid = fork)
{
    # run the Tk Mainloop off by itself
    $widget->run();
    waitpid($pid, 0);
}
else
{
    # actually do the work. increment each progress bar
    # the bars scale from 0% to 100%, so scale your
    # range down between these two values.
    # (progress/totalProgress*100)
    for (my $i=0; $i<100; $i++)
    {
        $widget->incrementBar(0, $i);
    }
    sleep 5;
    for (my $i=0; $i<100; $i++)
    {
        $widget->incrementBar(1, $i);
    }
    # put a green 'info' message into the dialog.
    $widget->insertText('info', 'green', "Complete");
    
}
[download]

package progressWidget;

use warnings;
use strict;
use Tk;
use Fcntl;
use Tk::ProgressBar;

sub new
{
    my $classname = shift;
    my $self = {};

    # create the pipe
    pipe(FROM, TO) or die "pipe $!";
    fcntl(FROM, F_SETFL, O_NONBLOCK) or die "can't fcntl $!\n";
    fcntl(TO, F_SETFL, O_NONBLOCK) or die "can't fcntl $!\n";

    $self->{fromFh} = \*FROM;
    $self->{toFh} = \*TO;


    $self->{mainTk} = new MainWindow(-title => 'Generating report ...'
+);
    # $self->{mainTk} = new MainWindow;
    
    my $maxsize = 0;
    for (my $i=0; $i<@_; $i++)
    {
        if (length($_[$i]) > $maxsize)
        {
            $maxsize = length($_[$i]);
        }
    }

    
    for (my $i=0; $i<@_; $i++)
    {
        my $frame = $self->{mainTk}->Frame;
        $frame->Label(-text => $_[$i],
                      -width => $maxsize
                      )->pack(-side => 'left', -expand => 1);
        $self->{bars}[$i] = $frame->ProgressBar(
                                                -borderwidth => 2,
                                                -relief => 'sunken',
                                                -width => 20,
                                                -length => 200,
                                                -anchor => 'w',
                                                -blocks => 50,
                                                -from => 0,
                                                -to => 100
                                               )->pack(-expand => 1);
        $frame->pack;
    }

    my $frame = $self->{mainTk}->Frame;

    require Tk::ROText;
    $self->{output} = $frame->Scrolled('ROText');

    $self->{output}->pack(-side => 'left', -expand => 1, -fill =>'both
+');
    $frame->pack(-fill => 'both', -expand => 1);
    
    $self->{mainTk}->after(50, \&guiUpdateLoop, $self);
    
    return bless($self, $classname);
}

sub incrementBar
{
    my $self = shift;
    my $barnum = shift;
    my $barvalue = shift;
    
    my $fh = $self->{toFh};
    select($fh); $|=1;
    
    print $fh "$barnum:$barvalue\n";
    select(STDOUT);
}

sub insertText
{
    my $self = shift;
    my $title = shift;
    my $colour = shift;
    my $message = shift;

    my $fh = $self->{toFh};
    select($fh); $|=1;

    print $fh "log:$title:$colour:$message\n";
    select(STDOUT);
}

sub quit
{
    my $self = shift;
    my $fh = $self->{toFh};
    select($fh); $|=1;
    print $fh "exit\n";
    select(STDOUT);
}

sub run
{
    my $self = shift;
    MainLoop;
}


sub guiUpdateLoop
{
    my $self = $_[0];

    my $fh = $self->{fromFh};
    while (my $stuff = <$fh>)
    {
        if ($stuff =~ /exit/)
        {
            # exit;
        }
        elsif ($stuff =~ /^log:/)
        {
            my ($log, $title, $colour, $text) = split(/:/, $stuff, 4);
            # find the end.
            my $tag = 'foo' . ++$self->{tag};
            $self->{output}->insert('end', $title . ": ", $tag);
            $self->{output}->tagConfigure($tag, 'foreground', $colour)
+;
            $self->{output}->insert('end', $text);
        }
        else
        {
            my @break = split(/:/, $stuff);
            my $bar = $self->{bars}[$break[0]];
            $bar->value($break[1]);
        }
        
        $self->{mainTk}->update;
    }
    $self->{mainTk}->after(5, \&guiUpdateLoop, $self);

}

1;
[download]