File Coverage

blib/lib/Zoidberg/Shell.pm

Criterion	Covered	Total	%
statement	61	137	44.5
branch	21	74	28.3
condition	5	26	19.2
subroutine	13	35	37.1
pod	11	14	78.5
total	111	286	38.8

package Zoidberg::Shell;

our $VERSION = '0.981';

use strict;
use vars qw/$AUTOLOAD/;
use Zoidberg::Utils qw/:error :output path getopt/;
use Exporter::Tidy
	default	=> [qw/AUTOLOAD shell command builtin/],
	command	=> [qw/shell command builtin/],
	jobs    => [qw/job @JOBS/],
	data	=> [qw/alias unalias set setting/],
	other	=> [qw/source readpipe/];

our @JOBS;
tie @JOBS, 'Zoidberg::Shell::JobsArray';

sub new {
	shift; #class
	eval 'use Zoidberg';
	die if $@;

	# reformat some settings
	my %obj = @_;
	my $set = $obj{settings} || {};
	$$set{rcfiles} = [] if exists $$set{norc} and delete $$set{norc};
	$$set{interactive} = (-t STDIN and -t STDOUT)
		unless defined $$set{interactive};
	$obj{settings} = $set;

	Zoidberg->new(%obj);
}

sub current { return $Zoidberg::CURRENT }

sub any {
	goto &new unless $Zoidberg::CURRENT;
	return $Zoidberg::CURRENT;
}

sub _self { ( eval{ $_[0]->isa( __PACKAGE__ ) } ) ? shift : $Zoidberg::CURRENT }

# ################ #
# Parser interface #
# ################ #

sub AUTOLOAD {
	## Code inspired by Shell.pm ##
	my $cmd = (split/::/, $AUTOLOAD)[-1];
	return undef if $cmd eq 'DESTROY';
	shift if ref($_[0]) eq __PACKAGE__;
	debug "Zoidberg::Shell::AUTOLOAD got $cmd";
	@_ = ([{plain_words => 1}, $cmd, @_]); # force words
	goto \&shell;
}

sub shell { # FIXME FIXME should not return after ^Z
	my $self = &_self;
	my $meta = (ref($_[0]) eq 'HASH') ? shift : {};
	my $pipe = ($_[0] =~ /^-\||\|-$/) ? shift : undef ;
	todo 'pipeline syntax' if $pipe;
	my $save_error = $$self{error};
	$$self{fg_job} ||= $self;
	$$meta{capture} = defined wantarray;
	$$meta{wantarray} = wantarray;
	local $$self{_settings}{output}{error} = 'mute'
		if delete $$meta{die_silently};
	my @re;
	if (grep {ref $_} @_) { @re = $$self{fg_job}->shell_list($meta, @_) }
	elsif (@_ > 1)        { @re = $$self{fg_job}->shell_list($meta, \@_) }
	else                  { @re = $self->shell_string($meta, @_) }
	$@ = $$self{error};
	$$self{error} = $save_error;
	_return($@, @re);
}

sub _return { # fairly complex output logic :S
	# the heuristic is that list context is the fastest .. can this be optimised further ?
	my $error = shift() ? 0 : 1;
	unless (@_) { return Zoidberg::Utils::Output::Scalar->new($error, '') }
	elsif (wantarray) {
		return map { # try to do the same list heuristics as utils::output
			(ref($_) eq 'ARRAY' and ! grep ref($_), @$_) ? (@$_) : $_
		} @_;
	}
	elsif (! grep ref($_), @_) { # only strings
		return Zoidberg::Utils::Output::Scalar->new($error, join('', @_)) ;
	}
	else { # one or more refs in @_
		if (@_ == 1) { # must be ref
			return( (ref($_[0]) eq 'ARRAY' and ! grep ref($_), @{$_[0]})
				? Zoidberg::Utils::Output::Scalar->new($error, undef, shift())
				: Zoidberg::Utils::Output::Scalar->new($error, shift()       )  ) ;
		}
		else { # mixed data - hope we get it right
			return Zoidberg::Utils::Output::Scalar->new($error, undef, [ map {
				(ref($_) eq 'ARRAY' and ! grep ref($_), @$_) ? (@$_) : $_
			} @_ ] ) ;
		}
	}
}

sub builtin {
	unshift @_, 'builtin';
	goto \&_shell_cmd;
}

sub command {
	unshift @_, 'system';
	goto \&_shell_cmd;
}

sub _shell_cmd {
	my $type = shift;
	my $self = &_self;
	my $meta = (ref($_[0]) eq 'HASH') ? shift : {};
	$$meta{capture} = defined wantarray;
	$$meta{wantarray} = wantarray;
	local $$self{_settings}{output}{error} = 'mute'
		if delete $$meta{die_silently};
	my $save_error = $$self{error};
	$$self{fg_job} ||= $self;
	my @re = $$self{fg_job}->shell_job( $meta,
		[{context => 'CMD', cmdtype => $type}, @_] );
	$@ = $$self{error};
	$$self{error} = $save_error;
	_return($@, @re);
}

sub readpipe { # TODO handle STDOUT differently, see perlop
	my $self = &_self;
	my @re = $self->shell_string( {capture => 1}, @_ );
	return wantarray ? @re : join('', @re);
}

sub system {
	# quick parser independent way of calling system commands
	# not exported to avoid conflict with perlfunc system
	my $self = &_self;
	open CMD, '|-', @_ or error "Could not open pipe to: $_[0]";
	my @re = ();
	close CMD;
	return wantarray ? @re : join('', @re);
	# FIXME where does the error code of cmd go?
}

# ############# #
# Some builtins #
# ############# #

sub alias {
	my $self = &_self;
	my (undef, $hash) = getopt '%', @_;
	$$self{aliases}{$_} = $$hash{$_} for keys %$hash;
	# TODO merge code from Commands here
}

sub unalias {
	my $self = &_self;
	my ($opts, $args) = getopt 'all,a @', @_;
	if ($$opts{all}) { %{$$self{aliases}} = () }
	else {
		for (@$args) {
			error "alias: $_: not found"
				unless delete $$self{aliases}{$_};
		}
	}
	# TODO merge code from Commands here
	# use path2hashref
}

sub set {
	# TODO merge code from Commands here
	# use path2hashref
	my $self = &_self;
	if (ref($_[0]) eq 'HASH') { # perl style, merge hashes
		error 'set: only first argument is used' if $#_;
		%{$self->{settings}} = ( %{$self->{settings}}, %{$_[0]} );
	}
	elsif (ref $_[0]) { error 'set: no support for data type'.ref($_[0]) }
	else {  $self->{settings}{$_}++ for @_ }
}

sub setting {
	# use path2hashref
	my $self = &_self;
	my $key = shift;
	return exists($$self{settings}{$key}) ? $$self{settings}{$key}  : undef;
}

sub source {
	my $self = &_self;
	local $Zoidberg::CURRENT = $self;
	for my $file (@_) {
		my $file = path($file);
		error "source: no such file: $file" unless -f $file;
		debug "going to source: $file";
		# FIXME more intelligent behaviour -- see bash man page
		eval q{package Main; our $SCRIPT = $file; do $file; die $@ if $@ };
		# FIXME wipe Main
		complain if $@;
	}
}

sub job { $Zoidberg::CURRENT->job_by_spec(pop @_) }

package Zoidberg::Shell::JobsArray;

our $VERSION = '0.981';

sub TIEARRAY { bless \$Zoidberg::Shell::VERSION, shift } # what else is there to bless ?

sub FETCH { $_[1] ? $Zoidberg::CURRENT->job_by_id($_[1]) : $$Zoidberg::CURRENT{fg_job} }

sub STORE { die "Can't overwrite jobs, try 'push'\n" } # STORE has no meaning for this thing

sub DELETE {
	my $j = $Zoidberg::CURRENT->job_by_id($_[1]);
	return unless $j;
	$j->kill(undef, 'WIPE');
}

sub POP {
	my $last_id;
	$$_{id} > $last_id and $last_id = $$_{id}
		for @{$Zoidberg::CURRENT->{jobs}};
	$_[0]->DELETE($last_id);
}

sub SHIFT { $_[0]->DELETE(1) }

sub PUSH {
	ref($_[1])
		? $Zoidberg::CURRENT->shell_list(   {prepare => 1}, $_[1] )
		: $Zoidberg::CURRENT->shell_string( {prepare => 1}, $_[1] ) ;
}

sub UNSHIFT { die "Can't overwrite jobs, try 'push'\n" }

sub FETCHSIZE { 1 + scalar @{ $Zoidberg::CURRENT->{jobs} } }

sub EXISTS { $Zoidberg::CURRENT->job_by_id($_[1]) }

sub CLEAR { $_->kill(undef, 'WIPE') for @{$Zoidberg::CURRENT->{jobs}} }

sub SPLICE { die "Can't overwrite jobs, try 'delete' or 'push'\n" }

1;

__END__