File Coverage

blib/lib/Zoidberg/Contractor.pm

Criterion	Covered	Total	%
statement	297	522	56.9
branch	96	276	34.7
condition	25	98	25.5
subroutine	31	53	58.4
pod	9	10	90.0
total	458	959	47.7

package Zoidberg::Contractor;

our $VERSION = '0.981';

use strict;
use POSIX ();
use Config;
use Zoidberg::Utils;
no warnings; # yes, undefined == '' == 0

=head1 NAME

Zoidberg::Contractor - Module to manage jobs

=head1 SYNOPSIS

	use Zoidberg::Contractor;
	my $c = Zoidberg::Contractor->new();

	$c->shell_list( [qw(cat ./log)], '|', [qw(grep -i error)] );

=head1 DESCRIPTION

Zoidberg inherits from this module, it manages jobs.

It uses Zoidberg::StringParser.

Also it defines Zoidberg::Job and subclasses.

FIXME lots of documentation

=head1 METHODS

=over 4

=item new()

Simple constructor, calls C.

=cut

sub new { # stub, to be overloaded
	my $class = shift;
	shell_init(bless {@_}, $class);
}

=item shell_init()

Initialises things like hashes with signal names and sets terminal control.
Should be called before usage when the constructor is overloaded.

=cut

# Job control code adapted from example code
# in the glibc manual
# also some snippets from this manual include as comment blocks

# A subshell that runs non-interactively cannot and should not support job control.

sub shell_init {
	my $self = shift;
	bug 'Contractor can\'t live without a shell' unless $$self{shell};

	## jobs stuff
	$self->{jobs} = [];
	$self->{_sighash} = {};
	$self->{terminal} = fileno(STDIN);

	my @sno = split /[, ]/, $Config{sig_num};
	my @sna = split /[, ]/, $Config{sig_name};
	$self->{_sighash}{$sno[$_]} = $sna[$_] for (0..$#sno);

	if ($self->{shell}{settings}{interactive}) {
		# Loop check until we are in the foreground.
		while (POSIX::tcgetpgrp($self->{terminal}) != ($self->{pgid} = getpgrp)) {
			# FIXME is this logic allright !??
			CORE::kill($$self{_sighash}{TTIN}, -$self->{pgid}); # stop ourselfs
		}
		# ignore interactive and job control signals
		$SIG{$_} = 'IGNORE' for qw/INT QUIT TSTP TTIN TTOU/;

		# And get terminal control
		POSIX::tcsetpgrp($self->{terminal}, $self->{pgid});
		$self->{tmodes} = POSIX::Termios->new;
		$self->{tmodes}->getattr;
	}
	else { $self->{pgid} = getpgrp }

	return $self;
}

=item round_up()

Recursively calls the C function of all current jobs.

=cut

sub round_up { $_->round_up() for @{$_[0]->{jobs}} }

=item shell_list(@blocks)

Executes a list of jobs and logic operators.

=cut

sub shell_list {
	my ($self, @list) = grep {defined $_} @_;

	my $save_fg_job = $$self{shell}{fg_job}; # could be undef

	my $meta = (ref($list[0]) eq 'HASH') ? shift(@list) : {} ;
	return unless @list;

	my @re;
	for (@list) { $_ = $$self{shell}->prepare_block($_) if ref $_ }
	PARSE_LIST:
	return unless @list;
	if (ref $list[0]) {
		eval {
			my $j = Zoidberg::Job->new(%$meta, boss => $self, tree => \@list);
			@list = @{$$j{tree}} and goto PARSE_LIST if $$j{empty};
			unless ( $$meta{prepare} ) { @re = $j->exec() }
			else {
				$j->bg(); # put it in @jobs
				$$j{bg} = 0;
			}
		};
		complain $@ if $@; # FIXME FIXME check eval {} blocks for redundancy
	}
	elsif (@{$$self{jobs}}) {
		debug 'enqueuing '.scalar(@list).' blocks';
		push @{$$self{jobs}[-1]{tree}}, @list;
	}
	else {
		debug 'no job to enqueu in, trying logic';
		@list = $self->_logic($$self{shell}{error}, @list);
		@re = $self->shell_list(@list);
	}

	$$self{shell}{fg_job} = $save_fg_job;

	return @re;
}

=item shell_job($block)

Executes a single job.

=cut

sub shell_job {
	my ($self, $meta, $block) = @_;
	$block = $meta unless ref($meta) eq 'HASH';
	my $save_fg_job = $$self{shell}{fg_job}; # could be undef
	my @re;
	eval {
		my $j = Zoidberg::Job->new(%$meta, boss => $self, procs => [$block]);
		@re = $j->exec()
	};
	complain $@ if $@;
	$$self{shell}{fg_job} = $save_fg_job;
	return @re;
}

=item reap_jobs()

Checks for jobs that are finished and removes them from the job list.

=cut

sub reap_jobs {
	my $self = shift;
	return unless  @{$self->{jobs}};
	my (@completed, @running);
	#debug 'reaping jobs';
	for ( @{$self->{jobs}} ) {
		next unless ref($_) =~ /Job/; # prohibit autogenerated faults
		$_->update_status;
		if ($_->completed) {
			if (@{$$_{tree}}) { $self->reinc_job($_) } # reincarnate it
			else { push @completed, $_ }
		}
		else { push @running, $_ }
	}
	$self->{jobs} = \@running;
	#debug 'body count: '.scalar(@completed);
	if ($$self{shell}{settings}{interactive}) {
		++$$_{completed} and message $_->status_string
			for sort {$$a{id} <=> $$b{id}} grep {! $$_{no_notify}} @completed;
	}
}

sub reinc_job { # reincarnate
	my ($self, $job) = @_;
	debug "job \%$$job{id} reincarnates (error: $$job{error})";
	my @b = $self->_logic($$job{error}, @{$$job{tree}});
	$$job{tree} = [];
	return unless @b;
	debug @b. ' blocks left';
	$self->shell_list({ map {($_ => $$job{$_})} qw#bg id capture wantarray# }, @b);
}

sub _logic {
	my ($self, $error, @list) = @_;
	my $op = ref( $list[0] ) ? 'EOS' : shift @list ;
	# mind that logic grouping for AND and OR isn't the same, OR is stronger
	while ( $error ? ( $op eq 'AND' ) : ( $op eq 'OR' ) ) { # skip
		my $i = 0;
		while ( ref $list[0] or $list[0] eq 'AND' ) {
			shift @list;
			$i++;
		}
		debug( ($error ? 'error' : 'no error') . " => $i blocks skipped" );
		$op = shift @list;
	}
	return @list;
}

# ############# #
# info routines #
# ############# #

=item job_by_id($id)

Returns a job object based on the (numeric) id.

(Note that the job list is un-ordered,
 so the id and the index are not usually identical.)

=item job_by_spec($string)

Returns a job object based on a string.
The following formats are supported:

=over 4

=item %I

Job with id I

=item %+

Current job

=item %-

Previous job

=item %?I

Last job matching I

=item %I

Last job starting with I

=back

=item sig_by_spec($string)

Returns the signal number for a named signal
or undef if no such signal exists.

=cut

sub job_by_id {
	my ($self, $id) = @_;
	for (@{$$self{jobs}}) { return $_ if $$_{id} eq $id }
	return undef;
}

sub job_by_spec {
	my ($self, $spec) = @_;
	return @{$$self{jobs}} ? $$self{jobs}[-1] : undef unless $spec;
	# see posix 1003.2 speculation for arbitrary cruft
	$spec = '%+' if $spec eq '%%' or $spec eq '%';
	$spec =~ /^ \%? (?: (\d+) | ([\+\-\?]?) (.*) ) $/x;
	my ($id, $q, $string) = ($1, $2, $3);
	if ($id) {
		for (@{$$self{jobs}}) { return $_ if $$_{id} == $id }
	}
	elsif ($q eq '+') { return $$self{jobs}[-1] if @{$$self{jobs}}     }
	elsif ($q eq '-') { return $$self{jobs}[-2] if @{$$self{jobs}} > 1 }
	elsif ($q eq '?') {
		for (reverse @{$$self{jobs}}) { return $_ if $$_{zoidcmd} =~ /$string/ }
	}
	else {
		for (reverse @{$$self{jobs}}) { return $_ if $$_{zoidcmd} =~ /^\W*$string/ }
	}
	return undef;
}

sub sig_by_spec {
	my ($self, $z) = @_;
	return $z if exists $$self{_sighash}{$z};
	$z =~ s{^(sig)?(.*)$}{uc($2)}ei;
	while (my ($k, $v) = each %{$$self{_sighash}}) {
		return $k if $v eq $z
	}
	return undef;
}


# ########### #
# Job objects #
# ########### #

package Zoidberg::Job;

our $VERSION = '0.981';

use strict;
use vars '$AUTOLOAD';
use POSIX qw/:sys_wait_h :signal_h/;
use Zoidberg::Utils;

use overload
	'@{}' => sub { $_[0]->{tree} },
	fallback => 'TRUE';

our @ISA = qw/Zoidberg::Contractor/;

=back

=head1 JOBS

Jobs are objects of the class C or a subclass of this class.

This object AUTOLOADS methods to process signals. For example:

  $job->TERM(); # is identical to
  $job->kill('TERM');

=head2 Methods

The job obbjects have the following methods:

=over 4

=item new()

Simple constructor.

=item exec()

Execute the job.

=item round_up()

Recursively kill the job, ends all child processes forcefully.

=cut

sub new { # @_ should at least contain 'boss' and either 'proc' or 'tree'
	shift; # class
	my $self = { new => 1, id => 0, procs => [], @_ };
	$$self{shell} ||= $$self{boss}{shell};
	$$self{$_}  ||= [] for qw/jobs tree/;
	$$self{$_} = $$self{boss}{$_} for qw/_sighash terminal/; # FIXME check this

	if ($$self{tree}) {
		while ( ref $$self{tree}[0] ) {
			my @b = grep {defined $_} $$self{shell}->parse_block(shift @{$$self{tree}});  # FIXME breaks interface, should be a hook
			if (@b > 1) { unshift @{$$self{tree}}, @b } # probably macro expansion
			else { push @{$$self{procs}}, @b }
		}
		$$self{bg}++ if $$self{tree}[0] eq 'EOS_BG';
	}

	return bless {%$self, empty => 1}, 'Zoidberg::Job' unless @{$$self{procs}};
	debug 'blocks in job ', $$self{procs};
	my $pipe = @{$$self{procs}} > 1;
	$$self{string}  ||= ($pipe ? '|' : '') . $$self{procs}[-1][0]{string};
	$$self{zoidcmd} ||= $$self{procs}[-1][0]{zoidcmd};
	$$self{pwd} ||= $$self{procs}[0][0]{env}{pwd} || $ENV{PWD};

	my $meta = $$self{procs}[0][0];
	unless ($pipe || ( defined($$meta{fork_job}) ? $$meta{fork_job} : 0 ) || $$self{bg}) {
		bless $self, 'Zoidberg::Job::builtin'
	}
	else { bless $self, 'Zoidberg::Job' }

	return $self;
}

sub exec {
	die unless ref($_[0]); # check against deprecated api
	my $self = shift;
	if (ref $_[0]) { %$self = (%$self, %{$_[0]}) }

	message $self->status_string('Running') if $$self{prepare};
	$$self{new} = 0;

	return unless @{$$self{procs}};
	local $ENV{ZOIDREF} = "$$self{shell}";

	my @re = eval { $self->_run };
	if ($$self{error}) { $$self{shell}{error} = $$self{error} }
	elsif ($@) {
		complain;
		my $error = ref($@) ? $@ : bless { string => ($@ || 'Error') }, 'Zoidberg::Utils::Error';
		$error->PROPAGATE(); # just for the record
		$$self{error} = $$self{shell}{error} = $error;
	}
	else { delete $$self{shell}{error} }

	if ($self->completed()) {
		$$self{shell}->broadcast('envupdate'); # FIXME breaks interface
		$$self{boss}->reinc_job($self) if @{ $$self{tree} };
	}

	if ( $$self{tree}[0] eq 'EOS_BG' ) { # step over it - FIXME conflicts with fg_job
		shift @{$$self{tree}};
		my $ref = $$self{tree};
		$$self{tree} = [];
		$$self{boss}->shell_list(@$ref);
	}

	return @re;
}

sub round_up {
	$_[0]->kill('HUP', 'WIPE');
	$_->round_up() for @{$_[0]->{jobs}};
}

# ######## #
# Run code #
# ######## #

# As each process is forked, it should put itself in the new process group by calling setpgid
# The shell should also call setpgid to put each of its child processes into the new process
# group. This is because there is a potential timing problem: each child process must be put
# in the process group before it begins executing a new program, and the shell depends on
# having all the child processes in the group before it continues executing. If both the child
# processes and the shell call setpgid, this ensures that the right things happen no matter
# which process gets to it first.

# If the job is being launched as a foreground job, the new process group also needs to be
# put into the foreground on the controlling terminal using tcsetpgrp. Again, this should be
# done by the shell as well as by each of its child processes, to avoid race conditions.

sub _run {
	my $self = shift;
	$$self{shell}{fg_job} = $self;

	$self->{tmodes}	= POSIX::Termios->new;

	$self->{procs}[-1][0]{last}++ unless $$self{capture}; # don't close the pipeline if capturing

	my ($pid, @pipe, $stdin, $stdout);
	my $zoidpid = $$;
	$stdin = fileno STDIN;

	# use pgid of boss when boss is part of a pipeline
	$$self{pgid} = $$self{boss}{pgid} unless $$self{shell}{settings}{interactive};

	my $i = 0;
	for my $proc (@{$self->{procs}}) {
		$i++;
		if ($$proc[0]{last}) { $stdout = fileno STDOUT }
		else { # open pipe to next process
			@pipe = POSIX::pipe;
			$stdout = $pipe[1];
		}

		$pid = fork; # fork process
		if ($pid) {  # parent process
			# set pid and pgid
			$$proc[0]{pid} = $pid;
			$self->{pgid} ||= $pid ;
			POSIX::setpgid($pid, $self->{pgid});
			debug "job \%$$self{id} part $i has pid $pid and pgid $$self{pgid}";
			# set terminal control
			POSIX::tcsetpgrp($self->{shell}{terminal}, $self->{pgid})
				if $$self{shell}{settings}{interactive} && ! $$self{bg};
		}
		else { # child process
			# set pgid
			$self->{pgid} ||= $$; # after first pgid is set allready
			POSIX::setpgid($$, $self->{pgid});
			# set terminal control
			POSIX::tcsetpgrp($self->{shell}{terminal}, $self->{pgid})
				if $$self{shell}{settings}{interactive} && ! $$self{bg};
			# and run child
			$ENV{ZOIDPID} = $zoidpid;
			eval { $self->_run_child($proc, $stdin, $stdout) };
			my $error = $@ || 0;
			if ($error) {
				complain;
				$error = ref($error) ? ($$error{exit_status} || 1) : 1 if $error;
			}
			exit $error; # exit child process
		}

		POSIX::close($stdin)  unless $stdin  == fileno STDIN ;
		POSIX::close($stdout) unless $stdout == fileno STDOUT;
		$stdin = $pipe[0] unless $$proc[0]{last} ;
	}

	my @re  = $$self{bg}      ? $self->bg
		: $$self{capture} ? ($self->_capture($stdin)) : $self->fg ;

	# postrun
	POSIX::tcsetpgrp($$self{shell}{terminal}, $$self{shell}{pgid});

	return @re;
}

sub _capture { # called in parent when capturing
	my ($self, $stdin) = @_;
	local $/ = (exists $ENV{RS} and defined $ENV{RS})
       		? $ENV{RS} : "\n" ; # Record Separator
	debug "capturing output from fd $stdin, \$/ = '$/'";
	open IN, "<&=$stdin"; # open file descriptor
	my @re = ();
	close IN;
	POSIX::close($stdin)  unless $stdin  == fileno STDIN ;
	$self->wait_job; # job should be dead by now
	return $$self{wantarray} ? (map {chomp $_; $_} @re) : (join '', @re);
}

sub _run_child { # called in child process
	my $self = shift;
	my ($block, $stdin, $stdout) = @_;

	$self->{shell}{round_up} = 0;
	$self->{shell}{settings}{interactive} = 0;
	map { $SIG{$_} = 'DEFAULT' } qw{INT QUIT TSTP TTIN TTOU};

	# make sure stdin and stdout are right, else dup them
	for ([$stdin, fileno STDIN], [$stdout, fileno STDOUT]) {
		next if $_->[0] == $_->[1];
		POSIX::dup2(@$_);
		POSIX::close($_->[0]);
	}

	$self->_set_env($block);

	# here we go ... finally
	$$self{shell}->eval_block($block); # FIXME should be hook
}

# ##################### #
# Execution environment #
# ##################### #

sub _set_env {
	my ($self, $block) = @_;

	# check the pwd we want
	my $pwd = $$block[0]{env}{pwd};
	if ($pwd and $pwd ne $ENV{PWD}) {
		debug "Changing pwd to: $pwd";
		chdir $pwd or error "Could not change dir to: $pwd";
		$$self{pwd} = $pwd;
	}

	# variables
	my @save_env;
	while (my ($env, $val) = each %{$$block[0]{env}}) {
		debug "env $env, val $val";
		push @save_env, [$env, $ENV{$env}];
		$ENV{$env} = $val;
	}
	return [\@save_env, []] unless $$block[0]{fd};

	# redirection
	my @save_fd;
	for my $fd (@{$$block[0]{fd}}) { # FIXME allow for IO objects
		my $newfd;
		$fd =~ m#^(\w*)(\W+)(.*)# or error "wrongly formatted redirection: $fd";
		my ($n, $op, $f) = ($1, $2, $3);
		$n ||= ($op =~ />/) ? 1 : 0;
		if ($op =~ /&=?$/) { # our dupping logic differs from open()
			if (! $f) { $newfd = 1 }
			elsif ($f =~ /^\d+$/) { $newfd = $f }
			else {
				no strict 'refs';
				my $class = $$self{shell}{settings}{perl}{namespace}
					|| 'Zoidberg::Eval';
				$newfd = fileno *{$class.'::'.$f};
				error $f.': no such filehandle' unless $newfd;
			}
		}
		else {
			error 'redirection needs argument' unless $f;
			error $f.': cannot overwrite existing file'
					if $op eq '>'
					and $$self{shell}{settings}{noclobber}
					and -e $f;
			$op = '>' if $op eq '>!';
			debug "redirecting fd $n to $op$f";
			my $fh; # undefined scalar => new anonymous filehandle on open()
			open($fh, $op.$f) || error "Failed to open $op$f";
			($f, $newfd) = ($fh, fileno $fh); # re-using $f to have object in outer scope
		}
		debug "dupping fd $newfd to $n";
		push @save_fd, [POSIX::dup($n), $n];
		POSIX::dup2($newfd, $n) || error "Failed to dup $newfd to $n";
	}

	return [\@save_env, \@save_fd];
}

sub _restore_env {
	my ($save_env, $save_fd) = @{ pop @_ };

	for (@$save_fd) {
		POSIX::dup2(@$_);
		POSIX::close($_->[0]);
	}

	if (my ($PWD) = grep {$$_[0] eq 'PWD'} @$save_env) {
		debug "Changing pwd back to: $$PWD[1]";
		chdir $$PWD[1] or error "Could not change dir to: $$PWD[1]";
	}
	$ENV{$$_[0]} = $$_[1] for @$save_env;
}

# ########### #
# Signal code #
# ########### #

=item fg()

Take terminal control and run this job in the foreground.

=item bg()

Run this job in the background.

=cut

sub fg {
	my $self = shift;

	if ($$self{new}) {
		unshift @_, $self;
		goto &exec;
	}

	message $self->status_string('Running') if $$self{bg};
	$$self{bg} = 0;

	@{$$self{boss}{jobs}} = grep {$_ ne $self} @{$$self{boss}{jobs}};
	$$self{shell}{fg_job} = $self;

	POSIX::tcsetpgrp($self->{shell}{terminal}, $self->{pgid})
		if $self->{shell}{settings}{interactive};

	if ($self->{stopped}) {
		CORE::kill(SIGCONT, -$self->{pgid});
		$self->{stopped} = 0;
	}
	$self->wait_job;

	POSIX::tcsetpgrp($self->{shell}{terminal}, $self->{shell}{pgid})
		if $self->{shell}{settings}{interactive};

	if ($$self{stopped} or $$self{terminated}) {
		if ($$self{stopped} and $$self{shell}{settings}{notify_verbose}) {
			$$self{shell}->jobs();
		}
		else {
			message $self->status_string;
		}
	}

	if ($self->completed()) {
		$$self{shell}->broadcast('envupdate'); # FIXME breaks interface
		$$self{boss}->reinc_job($self) if @{ $$self{tree} };
	}
}

sub bg {
	my $self = shift;
	$self->_register_bg;

	if ($self->{stopped}) {
		CORE::kill(SIGCONT => -$self->{pgid});
		$self->{stopped} = 0;
	}

	message $self->status_string;
}

sub _register_bg { # register oneself as a background job
	my $self = shift;

	unless ($$self{id}) {
		$$_{id} > $$self{id} and $$self{id} = $$_{id} for @{$$self{boss}{jobs}};
		$$self{id}++;
	}

	@{$$self{boss}{jobs}} = grep {$_ ne $self} @{$$self{boss}{jobs}};
	push @{$$self{boss}{jobs}}, $self;

	$self->{bg} = 1;
}

# FIXME wait code when not interactive

sub wait_job {
	my $self = shift;
	while ( ! $self->{stopped} && ! $self->completed ) {
		my $pid;
		until ($pid = waitpid(-$self->{pgid}, WUNTRACED|WNOHANG)) {
			$self->{shell}->broadcast('ipc_poll');
			select(undef, undef, undef, 0.001);
		}
		$self->_update_child($pid, $?);
	}
}

sub update_status {
	my $self = shift;
	return if $$self{new};
	while (my $pid = waitpid(-$self->{pgid}, WUNTRACED|WNOHANG)) {
		$self->_update_child($pid, $?);
		last unless $pid > 0;
	}
}

sub completed { ! grep { ! $$_[0]{completed} } @{$_[0]{procs}} }

sub _update_child {
	my ($self, $pid, $status) = @_;
	return unless $pid; # 0 == all is well
	debug "pid: $pid returned: $status";

	if ($pid == -1) { # -1 == all processes in group ended
		CORE::kill(SIGTERM => -$self->{pgid} ); # just to be sure
		debug "group $$self{pgid} has disappeared:($!)";
		$$_[0]{completed}++ for @{$self->{procs}};
	}
	else {
		my ($child) = grep {$$_[0]{pid} == $pid} @{$$self{procs}};
		bug "Don't know this pid: $pid" unless $child;
		$$child[0]{exit_status} = $status;
		if (WIFSTOPPED($status)) { # STOP TSTP TTIN TTOUT
			$$self{stopped} = 1;
			if ( ! $$self{bg} and (
				WSTOPSIG($status) == SIGTTIN or
				WSTOPSIG($status) == SIGTTOU
			) )  { $self->fg           } # FIXME not sure why but this proves nescessary
			else { $self->_register_bg }
		}
		else {
			$$child[0]{completed} = 1;
			if ($pid == $$self{procs}[-1][0]{pid}) { # the end of the line ..
				$$self{exit_status} = $status;
				if ($status) { # parse error codes
					# bitmasks for return status of system commands
					# exit_value  = $? >> 8;
					# signal_num  = $? & 127;
					# dumped_core = $? & 128;
					my $signal = $status & 127;
					$$self{terminated}++ if $signal; # was terminated by a signal
					$$self{core_dump}++  if $status & 128;
					$$self{error} = bless {
						silent => 1,
						string => $status >> 8,
						exit_value => $status > 8,
						core_dump => $$self{core_dump},
						( $signal ? (signal => $$self{_sighash}{$signal}) : () ),
					}, 'Zoidberg::Utils::Error';
					$$self{shell}{error} = $$self{error} unless $$self{bg};
				}
				unless ($self->completed) { # kill the pipeline
					local $SIG{PIPE} = 'IGNORE'; # just to be sure
					$self->kill(SIGPIPE);
				}
			}
		}
	}
}

# TODO
# don't set shell exitstatus etc. if bg !
# run condition between the clean up and the kill for non interactive mode ?
# job seems not to get reaped whille stopped - should be continued at kill

# ###### #
# OO api #
# ###### #

=item kill($signal, $wipe_list)

Sends $signal (numeric or named) to all child processes belonging to this job;
$signal defaults to SIGTERM.

If the boolean $wipe_list is set all jobs pending in the same logic list are
removed.

=cut

sub kill {
	my ($self, $sig_s, $kill_tree) = @_;
	my $sig = defined($sig_s) ? $$self{shell}->sig_by_spec($sig_s) : SIGTERM;
	error "$sig_s: no such signal" unless $sig;
	@{$$self{tree}} = () if $kill_tree;
	if ($self->{shell}{settings}{interactive}) {
		CORE::kill( $sig => -$$self{pgid} );
	}
	else {
		CORE::kill( $sig => $_ )
			for map { $$_[0]{pid} } @{$$self{procs}};
	}
	$self->update_status();
}

=item env(\%env)

Set local environment for the current job.
Can't be set after the job has started.

=item fd(\@redir)

Set redirections for the current job.
Can't be set after the job has started.

=cut

sub env {
	my $self = shift;
	my $env = ref($_[0]) ? shift : { @_ };
	error "to late to set env, job is already running" unless $$self{new};
	for (@{$$self{procs}}) {
		$$_[0]{env} = $$_[0]{env} ? { %{$$_[0]{env}}, %$env } : $env;
	}
}

sub fd {
	my $self = shift;
	my $fd = ref($_[0]) ? shift : [ @_ ];
	error "to late to set fd, job is already running" unless $$self{new};
	for (@$fd) {
		my $block = /^[0<]/ ? $$self{procs}[0] : $$self{procs}[-1]; # in- or output
		$$block[0]{fd} ||= [];
		push @{$$block[0]{fd}}, $_;
	}
}

sub AUTOLOAD { # autoload signals - bo args
	my $self = shift;
	$AUTOLOAD =~ s/.*:://;
	$self->kill($AUTOLOAD);
}

# ############ #
# Notification #
# ############ #

sub status_string {
	# POSIX: "[%d]%c %s %s\n", , , ,
	my ($self, $status, $list) = @_;

	my $pref = '';
	if ($$self{id}) {
		$pref = "[$$self{id}]" . (
			($self eq $$self{boss}{jobs}[-1]) ? '+ ' :
			($self eq $$self{boss}{jobs}[-2]) ? '- ' : '  ' );
	}

	$status ||=
		$$self{new}        ? 'New'         :
		$$self{stopped}    ? 'Stopped'     :
		$$self{core_dump}  ? 'Core dumped' :
		$$self{terminated} ? 'Terminated'  :
		$$self{completed}  ? 'Done'        : 'Running' ;

	my $string = $$self{string};
	chomp $string;
	$string .= "    \t(pwd: $$self{pwd})"
		if $$self{pwd} and $$self{pwd} ne $ENV{PWD};

	if ($list) { # more verbose output for `jobs --list`
		# FIXME this can no doubt be handled more gracefully
		my ($t, @stack) = ($$self{tree});
		for (my $i = 0; $i < @$t; $i++) {
			my $string;
			until (ref $$t[$i] or $i >= @$t) {
				$string .= $$t[$i] . ' ';
				$i++
			}
			if (ref $$t[$i]) {
				$string .= $$t[$i][0]{string} || $$t[$i][-1];
				chomp $string;
				$string =~ s/\n/\n\t/g;
			}
			else { $string .= $$t[$i] }
			push @stack, $string;
		}

		$string = join "\n\t", $string, grep /\S/, @stack;
		return $pref . $$self{pgid} . " $status\t$string";
	}
	else { return $pref . $status . "\t$string" }
}

package Zoidberg::Job::builtin;

our $VERSION = '0.981';

use strict;
use Zoidberg::Utils;

our @ISA = qw/Zoidberg::Job/;

sub round_up { $_->round_up() for @{$_[0]->{jobs}} }

sub _run { # TODO something about capturing :(
	my $self = shift;
	my $block = $self->{procs}[0];
	$$self{shell}{fg_job} = $self;

	my $saveint = $SIG{INT};
	if ($self->{settings}{interactive}) {
		my $ii = 0;
		$SIG{INT} = sub {
			if (++$ii < 3) { message "[$$self{id}] instruction terminated by SIGINT" }
			else { die "Got SIGINT 3 times, killing native scuddle\n" }
		};
	}
	else { $SIG{INT} = sub { die "[SIGINT]\n" } }

	my $save_capt;
	if ($$self{capture}) {
		debug "trying to capture a builtin";
		$save_capt = $$self{shell}{_builtin_output};
		$$self{shell}{_builtin_output} = [];
	}
	my $save_env = $self->_set_env($block);

	# here we go !
	eval { $$self{shell}->eval_block($block) };
		# FIXME should be hook
       		# VUNZig om hier een eval te moeten gebruiken

	$self->_restore_env($save_env);
	my @re;
	if ($$self{capture}) {
		@re = @{ $$self{shell}{_builtin_output} };
		$$self{shell}{_builtin_output} = $save_capt;
	}

	# restore other stuff
	$SIG{INT} = $saveint;
	$self->{completed}++;

	die if $@;

	return @re;
}

sub kill { error q#Can't kill a builtin# }
sub bg { error q#Can't put builtin in the background# }
sub fg { error q#Can't put builtin in the foreground# }

sub completed { $_[0]->{completed} }

1;

__END__