####################################################################
+########
#  
#
#  FILE NAME:    SimpleExecDialog.pm
#
# 
#
#  DESCRIPTION:  This module provides the means for a Perl/Tk applicat
+ion
#      to execute a system command in a subprocess while displaying a 
+status
#      dialog that allows the user to cancel the request.  The dialog 
+is
#      modal, and so prevents the parent window from accepting user in
+put.
#
#      The calling application can retrieve the return code of the
#      system command as well as any output sent to stdout.
#
#      The SimpleExecDialog is controlled in stages to allow multiple
#      commands to be executed while displaying only one dialog.  A ty
+pical
#      program might do something like:
#
#          $d = SimpleExecDialog->new(-parent => $mw, -text => 'Doing 
+stuff');
#          $d->raise;
#          $out1 = $d->exec_cmd('/bin/ls');
#          $out2 = $d->exec_cmd('/bin/ls -a');
#          $d->withdraw;
#
#      SimpleExecDialog is based on the ExecuteCommand package from
#      "Mastering Perl/Tk", Lidie and Walsh, O'Reilly 2002.
#
#  HISTORY:
#  
#
# 
######################################################################
+########


package SimpleExecDialog;
require SimpleExecDialog;

use strict;
use warnings;

use IO::Handle;
use POSIX ":sys_wait_h";

our @ISA        = qw(Exporter);
our @EXPORT     = qw( );
our @EXPORT_OK  = qw( );
our $VERSION    = 1.00;


######################################################################
+########
# Function:    new
# Description: Creates a new SimpleExecDialog.  Parameters are given
#     as key-value pairs.  The only required parameter is -parent.
# Parameters:
#     -text    => Text to display in the dialog
#     -title   => Title to display at the top of the dialog window
#     -parent  => Parent Toplevel widget.  The dialog will be transien
+t
#                 for this Toplevel.
# Returns:     none.
######################################################################
+########
sub new {
    my $invokant = shift;
    my $class    = ref($invokant) || $invokant;
    my $self     = { -text => 'Please wait...', -title => 'Processing'
+ };
    bless($self, $class);

    while (@_) {
        my $opt = shift;
        
        if    ($opt eq '-text')   { $self->{-text}   = shift;  }
        elsif ($opt eq '-title')  { $self->{-title}  = shift;  }
        elsif ($opt eq '-parent') { $self->{-parent} = shift;  }
        else { die "unknown option: $opt"; }
    }

    die 'missing parameters' if not defined ($self->{-parent});
    
    # Create Toplevel to act as the cancel dialog.
    $self->{-toplevel} = $self->{-parent}->Toplevel(-title => $self->{
+-title});
    my $top_frame = $self->{-toplevel}->Frame(-relief => 'groove', 
        -borderwidth => 1)->pack(-side => 'top', -expand => 1, 
        -fill => 'both');
    $self->{-textlabel} = $top_frame->Label(-text => $self->{-text}, -
+justify => 'left')
        ->pack(-expand => 1, -padx => 10, -pady => 10, -expand => 1, 
        -fill => 'both');
    my $bottom_frame = $self->{-toplevel}->Frame(-relief => 'groove',
        -borderwidth => 1)->pack(-side => 'top', -fill => 'x');
    my $cancel = $bottom_frame->Button(-text => 'Cancel', 
        -command => [ \&_cancel_cb, $self ])->pack(-pady => 10);
    
    $self->{-toplevel}->protocol('WM_DELETE_WINDOW', [ \&_cancel_cb, $
+self ]);
    
    # The dialog will stay hidden until SimpleExecDialog::raise is cal
+led.
    $self->{-toplevel}->resizable(0, 0);
    $self->{-toplevel}->transient( $self->{-parent} );
    $self->{-toplevel}->withdraw;

    return $self;
}


######################################################################
+########
# Function:     raise
# Description:  Pops up the dialog, typically before exec_cmd is calle
+d.
# Parameters:   none.
# Returns:      none.
######################################################################
+########
sub raise {
    my ($self) = @_;

    # The tricky part of this routine is figuring out how to center th
+e
    # dialog on its parent.  There are routines in Perl/Tk to provide 
+window
    # width and height, but these do not include the title bar and bor
+ders.
    # That means we'll have to figure those out for ourselves using
    # calls to geometry.  First we'll call raise and update on the
    # Toplevel to finalize its size without actually displaying it to
    # the user.
    $self->{-toplevel}->raise;
    $self->{-toplevel}->update;
 
    # By observing the difference between the window's offset accordin
+g to
    # geometry (which includes the window manager's decorations) and i
+ts root-y
    # position, we can figure the extra pixels taken up by the title b
+ar 
    # and borders.
    my ($wm_y) = ( $self->{-parent}->geometry =~ /([+-]\d+$)/ );
    
    my $parent_x      = $self->{-parent}->rootx;
    my $parent_y      = $self->{-parent}->rooty;
    my $parent_width  = $self->{-parent}->width;
    my $parent_height = $self->{-parent}->height;
    
    my $my_width      = $self->{-toplevel}->width;
    my $my_height     = $self->{-toplevel}->height;

    # Since both the dialog and its parent have the same height title 
+bar,
    # these cancel each other out in our calculations.  Therefore, onl
+y need
    # to do "normal" centering arithmetic, but offset the y value by t
+he window
    # manager y (which includes the title bar) rather than the widget'
+s y.
    my $my_x = $parent_x + int(($parent_width - $my_width) / 2);
    my $my_y = $wm_y + int(($parent_height - $my_height) / 2);
    $my_x = 0 if $my_x < 0;
    $my_y = 0 if $my_y < 0;

    # Set the new location for the dialog and finally display it.
    my $new_geo = ($my_x >= 0 ? '+' : '') . $my_x . 
        ($my_y >= 0 ? '+' : '') . $my_y;
    $self->{-toplevel}->geometry($new_geo);
    $self->{-toplevel}->deiconify;
    $self->{-toplevel}->grab;
}


######################################################################
+########
# Function:     exec_cmd
# Description:  Executes the given system command in a subprocess.  Th
+e
#     command can be stopped before completion by the user clicking th
+e
#     Cancel button.
# Parameters:   
#     $cmd - The command to execute.
# Returns:      The final status of the request - 'ok', 'cancel', or '
+error'.
######################################################################
+########
sub exec_cmd {
    my ($self, $cmd) = @_;

    die "Missing command in SimpleExecDialog::exec_cmd" if not defined
+ $cmd;

    # Initialize all the status variables before execution.
    $self->{-command}  = $cmd;
    $self->{-finish}   = 0;
    $self->{-output}   = '';
    $self->{-status}   = 'ok';
    $self->{-retcode}  = undef;

    # The command will execute in a subprocess with its output tied to
+ a
    # handle we can read from in a fileevent callback.  Any output can
+ thus
    # be read asynchronously through the normal Tk event mechanisms.
    my $h = IO::Handle->new;
    die "IO::Handle->new failed." unless defined $h;
    $self->{-handle} = $h;
    $self->{-pid} = open $h, $self->{-command} . ' 2>&1 |';
    if (not defined $self->{-pid}) {
        $self->{-status} = 'error';
        $self->{-output} = "Could not start the requested command:\n" 
+.
            "$self->{-command}";
        $self->kill_cmd;
        $self->{-toplevel}->messageBox(-title => 'Error', 
            -message => $self->{-output}, -type => 'OK', -bitmap => 'e
+rror');
        return $self->{-status};
    }
    $h->autoflush(1);
    $self->{-toplevel}->fileevent($h, 'readable' => [ \&_read_stdout, 
+$self ]);
    
    # Keep the dialog up until finished with it.
    $self->{-toplevel}->waitVariable(\$self->{-finish});
    $self->kill_cmd;
    
    return $self->{-status};
}


######################################################################
+########
# Function:     set_text
# Description:  Used to change the text displayed inside the dialog wi
+ndow.
# Parameters:   
#     $text - the new string to display
#     $resize - if defined, causes the dialog to resize and reposition
#               itself to accomodate the new label.
# Returns:      none.
######################################################################
+########
sub set_text {
    my ($self, $text, $resize) = @_;
    
    $self->{-text} = $text;
    $self->{-textlabel}->configure(-text => $text);

    if (defined $resize) {
        $self->withdraw;
        $self->raise;
    }
}


######################################################################
+########
# Function:     _read_stdout
# Description:  Callback used to read output from an active subprocess
+.  It
#     collects output in the -output attribute until the process compl
+etes,
#     at which point it sets -finish (which exec_cmd is waiting on) so
+ the 
#     dialog can return control to the calling app.
# Parameters:   none.
# Returns:      none.
######################################################################
+########
sub _read_stdout {
    my ($self) = @_;
    print "@_";
    if ($self->{-finish}) {
        $self->kill_cmd;
    } else {
        my $h = $self->{-handle};
        # Use sysread to prevent buffering from getting in the way.
        if ( sysread $h, $_, 4096 ) {
            $self->{-output} .= $_;
        } else {
            $self->{-finish} = 1;
        }
    }
}


######################################################################
+########
# Function:     kill_cmd
# Description:  Cleans up a command that was executing, killing it if 
+still
#     executing.  The cleanup includes calling waitpid to collect the
#     return code if the process completed, turning off the fileevent,
+ and
#     closing any file handle.
# Parameters:   none.
# Returns:      none.
######################################################################
+########
sub kill_cmd {
    my ($self) = @_;
    
    $self->{-finish} = 1;
    my $h = $self->{-handle};
    return unless defined $h;
    
    $self->{-toplevel}->fileevent($h, 'readable' => '');

    if (defined $self->{-pid}) {
    
        # Check to see if the process is still running.  If not, grab 
+the
        # return code from the process.
        my $pid = waitpid($self->{-pid}, &WNOHANG);
        if ($pid != 0 && $self->{-status} eq 'ok') {
            $self->{-retcode} = ($? >> 8);
        } else {
            $self->{-retcode} = undef;
        }

        # FIXME
        # Note:  To be very thorough, should actually kill off the chi
+ld and
        # all its descendants.  Since the current Perl installation do
+es not
        # have Proc::ProcessTable, this is complicated, so we'll just 
+kill the 
        # child.
        kill 'TERM', $self->{-pid};
    }
    
    close $h;
    $self->{-handle} = undef;
}


######################################################################
+########
# Function:     _cancel_cb
# Description:  Called when the SimpleExecDialog is closed before the
#     command it was executing completes.
# Parameters:   none.
# Returns:      none.
######################################################################
+########
sub _cancel_cb {
    my ($self) = @_;
    
    return if $self->{-finish} != 0;
    $self->{-status} = 'cancel';
    $self->{-finish} = 1;
}


######################################################################
+########
# Function:     withdraw
# Description:  Hides the dialog without destroying it.
# Parameters:   none.
# Returns:      none.
######################################################################
+########
sub withdraw {
    my ($self) = @_;
    
    if (defined($self->{-toplevel})) {
        $self->{-toplevel}->grabRelease;
        $self->{-toplevel}->withdraw;
    }
}


sub status {
    my ($self) = @_;
    
    return $self->{-status};
}

sub output {
    my ($self) = @_;
    
    return $self->{-output};
}

sub command {
    my ($self) = @_;
    
    return $self->{-command};
}

sub retcode {
    my ($self) = @_;
    
    return $self->{-retcode};
}

######################################################################
+########
# Function:     DESTROY
# Description:  Destructor function that cleans up any allocated resou
+rces
#     when a SimpleExecDialog is no longer referenced.
# Parameters:   none.
# Returns:      none.
######################################################################
+########
sub DESTROY {
    my ($self) = @_;

}

1;
[download]