Does nobody have a Mac? Or at least a little insight?
Regards
Jeff
On 13 March 2015 at 22:41, Jeffrey Ratcliffe
<jeffrey.ratcli...@gmail.com> wrote:
> Now, at last with a small working example. The following code works
> fine on Linux, but on MacOS:
>
> a. the gui does not seem to respond to the "hup" signal from the subprocess
> b. gets far more "in" signals than it should
>
> Unfortunately, the above description is secondhand, as I do not have
> access to a Mac.
>
> I would be very glad if somebody could give me a clue how to get
> things working under both operating systems.
>
> Regards
>
> Jeff
>
> #!/usr/bin/perl
>
> use warnings;
> use strict;
> use Gtk2 -init;
> use Glib qw(TRUE FALSE); # To get TRUE and FALSE
> use POSIX qw(locale_h :signal_h :errno_h :sys_wait_h);
> use IPC::Open3;
> use IO::Handle;
> use Readonly;
> Readonly my $_POLL_INTERVAL => 100; # ms
> Readonly my $_1KB => 1024;
> my $EMPTY = q{};
>
> # Create the windows
> my $window = Gtk2::Window->new('toplevel');
> my $box = Gtk2::VBox->new;
> my $entry = Gtk2::Entry->new;
> my $pbar = Gtk2::ProgressBar->new;
> my $qbutton = Gtk2::Button->new('Quit');
> my $sbutton = Gtk2::Button->new('Start');
>
> $window->add($box);
> $box->add($pbar);
> $box->add($qbutton);
> $box->add($sbutton);
>
> # We should also link this to the destroy message on the main window,
> # this is just quick and dirty
> $qbutton->signal_connect( clicked => sub { Gtk2->main_quit } );
> $sbutton->signal_connect( clicked => \&start_process );
> $window->show_all;
> Gtk2->main;
>
> sub start_process {
> watch_cmd(
> cmd => 'for i in `seq 1 5`; do echo $i; sleep 1; done',
> running_callback => sub {
> $pbar->pulse;
> },
> started_callback => sub {
> $pbar->set_text('Started');
> },
> out_callback => sub {
> my ($line) = @_;
> $pbar->set_text($line);
> },
> err_callback => sub {
> my ($line) = @_;
> $pbar->set_text("Error: $line");
> },
> finished_callback => sub {
> $pbar->set_text('Finished');
> },
> );
> return;
> }
>
> sub watch_cmd {
> my (%options) = @_;
>
> my $out_finished = FALSE;
> my $err_finished = FALSE;
> my $error_flag = FALSE;
> print "$options{cmd}\n";
>
> if ( defined $options{running_callback} ) {
> my $timer = Glib::Timeout->add(
> $_POLL_INTERVAL,
> sub {
> $options{running_callback}->();
> return Glib::SOURCE_REMOVE
> if ( $out_finished or $err_finished );
> return Glib::SOURCE_CONTINUE;
> }
> );
> }
>
> my ( $write, $read );
> my $error = IO::Handle->new;
> my $pid = IPC::Open3::open3( $write, $read, $error, $options{cmd} );
> print "Forked PID $pid\n";
>
> if ( defined $options{started_callback} ) {
> $options{started_callback}->() }
> my ( $stdout, $stderr, $error_message );
>
> add_watch(
> $read,
> sub {
> my ($line) = @_;
> $stdout .= $line;
> if ( defined $options{out_callback} ) {
> $options{out_callback}->($line);
> }
> },
> sub {
>
> # Don't flag this until after the callback to avoid the race
> condition
> # where stdout is truncated by stderr prematurely reaping the
> process
> $out_finished = TRUE;
> },
> sub {
> ($error_message) = @_;
> $error_flag = TRUE;
> }
> );
> add_watch(
> $error,
> sub {
> my ($line) = @_;
> $stderr .= $line;
> if ( defined $options{err_callback} ) {
> $options{err_callback}->($line);
> }
> },
> sub {
>
> # Don't flag this until after the callback to avoid the race
> condition
> # where stderr is truncated by stdout prematurely reaping the
> process
> $err_finished = TRUE;
> },
> sub {
> ($error_message) = @_;
> $error_flag = TRUE;
> }
> );
>
> # Watch for the process to hang up before running the finished callback
> Glib::Child->watch_add(
> $pid,
> sub {
>
> # Although the process has hung up, we may still have output to
> read,
> # so wait until the _watch_add flags that the process has ended
> first.
> my $timer = Glib::Timeout->add(
> $_POLL_INTERVAL,
> sub {
> if ($error_flag) {
> if ( defined $options{error_callback} ) {
> $options{error_callback}->($error_message);
> }
> return Glib::SOURCE_REMOVE;
> }
> elsif ( $out_finished and $err_finished ) {
>
> if ( defined $options{finished_callback} ) {
> $options{finished_callback}->( $stdout, $stderr );
> }
> print "Waiting to reap process\n";
>
> # -1 indicates a non-blocking wait for all pending zombie
> processes
> print 'Reaped PID ', waitpid(
> -1, ## no critic (ProhibitMagicNumbers)
> WNOHANG
> ),
> "\n";
> return Glib::SOURCE_REMOVE;
> }
> return Glib::SOURCE_CONTINUE;
> }
> );
> }
> );
> return;
> }
>
> sub add_watch {
> my ( $fh, $line_callback, $finished_callback, $error_callback ) = @_;
> my $line;
> Glib::IO->add_watch(
> fileno($fh),
> [ 'in', 'hup' ],
> sub {
> my ( $fileno, $condition ) = @_;
> my $buffer;
> if ( $condition & 'in' ) { # bit field operation. >= would also
> work
>
> # For Linux, this "if" should always return true, as the
> # callback is only triggered when there is data to read.
> # MacOS seems to trigger this callback even when there is
> # nothing to read, and therefore we need this conditional
> # Only reading one buffer, rather than until sysread gives EOF
> # because things seem to be strange for stderr
> if ( sysread $fh, $buffer, $_1KB ) {
> if ($buffer) { $line .= $buffer }
>
> while ( $line =~ /([\r\n])/xsm ) {
> my $le = $1;
> if ( defined $line_callback ) {
> $line_callback->(
> substr $line, 0, index( $line, $le ) + 1
> );
> }
> $line = substr $line, index( $line, $le ) + 1,
> length $line;
> }
> }
> }
>
> # Only allow the hup if sure an empty buffer has been read.
> if (
> ( $condition & 'hup' ) # bit field operation. >= would also
> work
> and ( not defined $buffer or $buffer eq $EMPTY )
> )
> {
> if ( close $fh ) {
> $finished_callback->();
> }
> elsif ( defined $error_callback ) {
> $error_callback->('Error closing filehandle');
> }
> return Glib::SOURCE_REMOVE;
> }
> return Glib::SOURCE_CONTINUE;
> }
> );
> return;
> }
_______________________________________________
gtk-perl-list mailing list
gtk-perl-list@gnome.org
https://mail.gnome.org/mailman/listinfo/gtk-perl-list
