Arch::Run - run subprocesses and capture output

    use Gtk2 -init;
    use Arch::Run qw(poll run_async LINES);

    my $window = Gtk2::Window->new;
    my $label = Gtk2::Label->new;
    my $pbar = Gtk2::ProgressBar->new;
    my $vbox = Gtk2::VBox->new;
    $vbox->add($label); $vbox->add($pbar); $window->add($vbox);
    $window->signal_connect(destroy => sub { Gtk2->main_quit; });
    $window->set_default_size(200, 48); $window->show_all;
    sub set_str { $label->set_text($_[0]); }

    my $go = 1;  # keep progress bar pulsing
    Glib::Timeout->add(100, sub { $pbar->pulse; poll(0); $go; });

    run_async(   
        command => [ 'du', '-hs', glob('/usr/share/*') ],
        mode    => LINES,
        datacb  => sub { chomp(my $str = $_[0]); set_str($str); },
        exitcb  => sub { $go = 0; set_str("exit code: $_[0]"); },
    );

    Gtk2->main;

# Arch Perl library, Copyright (C) 2004-2005 Mikhael Goikhman, Enno Cramer
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use 5.006;
use strict;

package Arch::Run;

use IO::Poll qw(POLLIN POLLOUT POLLERR);
use POSIX qw(waitpid WNOHANG setsid);

use constant RAW   => 0;
use constant LINES => 1;
use constant ALL   => 2;

use vars qw(@ISA @EXPORT_OK @OBSERVERS %SUBS $DETACH_CONSOLE);

use Exporter;

@ISA = qw(Exporter);
@EXPORT_OK = qw(
	run_with_pipe run_async poll wait unobserve observe
	RAW LINES ALL
);

BEGIN {
	$DETACH_CONSOLE = 0;
}

sub set_detach_console ($) {
	$DETACH_CONSOLE = shift;
}

sub run_with_pipe (@) {
	my $arg0 = shift || die "Missing command to run_with_pipe\n";
	my @args = (split(/\s+/, $arg0), @_);

	pipe TO_PARENT_RDR, TO_PARENT_WRT;
	pipe TO_CHILD_RDR,  TO_CHILD_WRT;

	my $pid = fork;
	die "Can't fork: $!\n" unless defined $pid;

	if ($pid) {
		close TO_PARENT_WRT;
		close TO_CHILD_RDR;

		return wantarray
			? (\*TO_PARENT_RDR, \*TO_CHILD_WRT, $pid)
			: \*TO_PARENT_RDR;

	} else {
		close TO_PARENT_RDR;
		close TO_CHILD_WRT;

		close STDIN;
		# my perl won't compile this if i use
		#   open STDIN, "<&", TO_CHILD_RDR
		# the same thing for STDOUT is accepted though,
		# the "<&" vs ">&" makes the difference
		open STDIN, "<&TO_CHILD_RDR";
		close TO_CHILD_RDR;

		close STDOUT;
		open STDOUT, ">&TO_PARENT_WRT";
		close TO_PARENT_WRT;

		setsid
			if $DETACH_CONSOLE;

		exec(@args);
	}
}

sub run_async (%) {
	my %args = @_;

	die "Missing command to run_async\n"
		unless exists $args{command};

	my @args = ref $args{command} ? @{$args{command}} : $args{command};
	my ($out, $in, $pid) = run_with_pipe(@args);

	_notify('cmd_start', $pid, @args);

	$SUBS{$pid} = {
		# in   => $in, # not for now
		out  => $out,
		mode => $args{mode},
		data => $args{datacb},
		exit => $args{exitcb},

		accum => '',
	};

	close($in); # no input for now

	return $pid;
}

sub get_output_handle ($) {
	my $key = shift;

	return $SUBS{$key}->{out};
}

sub handle_output ($) {
	my $key = shift;
	my $rec = $SUBS{$key};

	my $buffer;
	my $result = sysread $rec->{out}, $buffer, 4096;

	_notify('cmd_output_raw', $key, $buffer)
		if $result > 0;

	# handle output
	if ($result) {
		# raw mode
		if ($rec->{mode} eq RAW) {
			$rec->{data}->($buffer);

		# line mode
		} elsif ($rec->{mode} eq LINES) {
			$rec->{accum} .= $buffer;

			while ($rec->{accum} =~ s/^.*?(\015\012|\012|\015)//) {
				$rec->{data}->($&);
			}

		# bloody big block mode
		} else {
			$rec->{accum} .= $buffer;
			$rec->{data}->($rec->{accum})
				if $result == 0;
		}

	# error and eof
	} else {
		$rec->{data}->($rec->{accum})
			if length $rec->{accum};

		my $pid = waitpid $key, 0;
		my $exitcode = $pid == $key ? $? : undef;

		_notify('cmd_exit', $exitcode);

		$rec->{exit}->($exitcode)
			if defined $rec->{exit};

		delete $SUBS{$key};
	}
}

sub poll (;$) {
	my $count = 0;

	# check for output
	my $poll = IO::Poll->new;
	foreach my $key (keys %SUBS) {
		$poll->mask($SUBS{$key}->{out}, POLLIN | POLLERR)
			unless $SUBS{$key}->{done};
	}

	my $result = $poll->poll($_[0]);
	foreach my $key (keys %SUBS) {
		if ($poll->events($SUBS{$key}->{out})) {
			handle_output($key);
			++$count;
		}
	}

	return $count;
}

sub wait ($) {
	my $pid = shift;

	my $ret;

	# overwrite callback to capture exit code
	if (exists $SUBS{$pid}) {
		my $old_cb = $SUBS{$pid}->{exit};
		$SUBS{$pid}->{exit} = sub {
			$ret = shift;
			$old_cb->($ret)
				if defined $old_cb;
		};

		# Poll until a) our target has exited or b) there are no more
		# file handles to poll for.
		while (exists $SUBS{$pid} && poll(undef)) {}
	}

	# returns undef if childs exit has already been handled
	return $ret;
}

sub killall (;$) {
	my $signal = shift || 'INT';

	kill $signal, keys %SUBS;
	while (%SUBS && poll(undef)) {}
}

sub _notify (@) {
	die "no touching\n"
		if caller ne __PACKAGE__;

	my $method = shift;
	foreach my $observer (@OBSERVERS) {
		$observer->$method(@_) if $observer->can($method);
	}
}

sub unobserve ($) {
	my $observer = shift;
	@OBSERVERS = grep { $_ ne $observer } @OBSERVERS;
}   

sub observe ($) {
   my $observer = shift;
	unobserve($observer);
	push @OBSERVERS, $observer;
}

1;

__END__