[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / Psh.pm

package Psh;

use vars qw($VERSION);

$VERSION='1.8';

BEGIN {
	require Psh::OS;
}

require Psh::Util;
require Psh::Locale;
require Psh::Strategy;
require Psh::Joblist;
require Psh::Parser;
require Psh::PerlEval;
require Psh::Options;

use strict;

##############################################################################
##############################################################################
##
## Variables
##
##############################################################################
##############################################################################


#
# Private, Lexical Variables:
#


my ($input,$readline_saves_history);
##############################################################################
##############################################################################
##
## SUBROUTINES: Command-line processing
##
##############################################################################
##############################################################################

#
# void handle_message (string MESSAGE, string FROM = 'eval')
#
# handles any message that an eval might have returned. Distinguishes
# internal messages from Psh's signal handlers from all other
# messages. It displays internal messages with print_out or does
# nothing with them if FROM = 'main_loop'. It displays other messages with
# print_error, and if FROM = 'main_loop', psh dies in addition.
#

sub handle_message
{
	my ($message, $from) =  @_;

	if (!defined($from)) { $from = 'eval'; }

	chomp $message;

	if ($message) {
		return if ($from eq 'hide');
		if ($message =~ m/^SECRET $Psh::bin:(.*)$/s) {
			if ($from ne 'main_loop') { Psh::Util::print_out("$1\n"); }
		} else {
			Psh::Util::print_error("$from error ($message)!\n");
			if ($from eq 'main_loop') {
				if( Psh::Options::get_option('ignoredie')) {
					Psh::Util::print_error_i18n('internal_error');
				} else {
					die("Internal psh error.");
				}
			}
		}
	}
}

sub evl {
	my ($line, @use_strats) = @_;

	local @Psh::temp_use_strats;
	push @Psh::temp_use_strats, @use_strats if @use_strats;

	process_variable($line);
	return ($Psh::last_success_code, @Psh::last_result);
}

sub _evl {
	my @elements= @_;
	my @result=();
	my $trace= Psh::Options::get_option('trace');
	while( my $element= shift @elements) {
		my @tmp= @$element;
		my $type= shift @tmp;
		if ($type == Psh::Parser::T_EXECUTE()) {
			if ($trace) {
				for (my $i=1; $i<@tmp; $i++) {
					print STDERR "+ $tmp[$i][4]\n";
				}
			}
			eval {
				@result= Psh::OS::execute_complex_command(\@tmp);
			};
			handle_message($@);
		} elsif ($type == Psh::Parser::T_OR()) {
			return @result if @result and $result[0]; # we already had success
		} elsif ($type == Psh::Parser::T_AND()) {
			return (0) unless @result;
			next if ($result[0]); # we last had success
			return (0);
		} else {
			Psh::Util::print_error("evl: Don't know type $type\n");
		}
	}
	return @result;
}

#
# string read_until(PROMPT_TEMPL, string TERMINATOR, subr GET)
#
# Get successive lines via calls to GET until one of those
# entire lines matches the patterm TERMINATOR. Used to implement
# the `<<EOF` multiline quoting construct and brace matching;
#
# TODO: Undo any side effects of, e.g., m//.
#

sub read_until
{
	my ($prompt_templ, $terminator, $get) = @_;
	my $input;
	my $temp;

	my @input;

	while (1) {
		$temp = $prompt_templ?&$get(Psh::Prompt::prompt_string($prompt_templ),
									1,\&Psh::Prompt::pre_prompt_hook):
									  &$get();
		if (!defined($temp)) {
			Psh::Util::print_error_i18n('input_incomplete',join('',@input),$Psh::bin);
			return '';
		}
		last if $temp =~ m/^$terminator$/;
		push @input, $temp;
	}

	return join('',@input);
}

# string read_until_complete(PROMPT_TEMPL, string SO_FAR, subr GET)
#
# Get successive lines via calls to GET until the cumulative input so
# far is not an incomplete expression according to
# incomplete_expr. Prompting is done with PROMPT_TEMPL.
#

sub read_until_complete
{
	my ($prompt_templ, $sofar, $get) = @_;
	my $temp;
	my @input=();

	while (1) {
		$temp = $prompt_templ?
		  &$get(Psh::Prompt::prompt_string($prompt_templ),1,
				\&Psh::Prompt::pre_prompt_hook):
				  &$get();
		if (!defined($temp)) {
			Psh::Util::print_error_i18n('input_incomplete',$sofar,$Psh::bin);
			return '';
		}
		$sofar .= $temp;
		last if Psh::Parser::incomplete_expr($sofar) <= 0;
	}

	return $sofar;
}


#
# void process(bool Q_PROMPT, subr GET)
#
# Process lines produced by the subroutine reference GET until it
# returns undef. GET must be a reference to a subroutine which takes a
# string argument (the prompt, which may be empty) and returns the
# next line of input, or undef if there is none.
#
# Any output generated is handled by the various print_xxx routines
#
# The prompt is printed only if the Q_PROMPT argument is true.  When
# sourcing files (like .pshrc), it is important to not print the
# prompt string, but for interactive use, it is important to print it.
#
# TODO: Undo any side effects, e.g. done by m//.
#

sub process
{
	my ($q_prompt, $get) = @_;
	local $Psh::cmd;

	my $last_result_array = '';
	my $result_array_ref = \@Psh::val;
	my $result_array_name = 'Psh::val';

	my $control_d_counter=0;

	if ($q_prompt) {
		require Psh::Prompt;
	}

	while (1) {
		if ($q_prompt) {
			$input = &$get(Psh::Prompt::prompt_string(Psh::Prompt::normal_prompt()), 0, \&Psh::Prompt::pre_prompt_hook);
		} else {
			$input = &$get();
		}

		Psh::OS::reap_children(); # Check wether we have dead children
		Psh::OS::check_terminal_size() if $Psh::interactive;

		$Psh::cmd++;

		unless (defined($input)) {
			last unless $Psh::interactive;
			print STDOUT "\n";
			$control_d_counter++;
			my $control_d_max=$ENV{IGNOREEOF}||0;
			if ($control_d_max !~ /^\d$/) {
				$control_d_max=10;
			}
			Psh::OS::exit_psh() if ($control_d_counter>=$control_d_max);
			next;
		}
		$control_d_counter=0;

		next unless $input;
		next if $input=~ m/^\s*$/;

		if ($input =~ m/(.*)<<([a-zA-Z_0-9\-]*)(.*)/) {
			my $pre= $1;
			my $terminator = $2;
			my $post= $3;

			my $continuation = $q_prompt ? Psh::Prompt::continue_prompt() : '';
			$input = join('',$pre,'"',
						  read_until($continuation, $terminator, $get),
						  $terminator,'"',$post,"\n");
		} elsif (Psh::Parser::incomplete_expr($input) > 0) {
			my $continuation = $q_prompt ? Psh::Prompt::continue_prompt() : '';
			$input = read_until_complete($continuation, $input, $get);
		}

		chomp $input;

		my ($success,@result);
		my @elements= eval { Psh::Parser::parse_line($input) };
		Psh::Util::print_debug_class('e',"(evl) Error: $@") if $@;
		if (@elements) {
			my $result;
			($success,$result)= _evl(@elements);
			Psh::Util::print_debug_class('s',"Success: $success\n");
			$Psh::last_success_code= $success;
			if ($result) {
				@Psh::last_result= @result= @$result;
			} else {
				undef @Psh::last_result;
				undef @result;
			}
		} else {
			undef $Psh::last_success_code;
			undef @Psh::last_result;
		}

        next unless $Psh::interactive;

		my $qEcho = 0;
		my $echo= Psh::Options::get_option('echo');

		if (ref($echo) eq 'CODE') {
			$qEcho = &$echo(@result);
		} elsif (ref($echo)) {
			Psh::Util::print_warning_i18n('psh_echo_wrong',$Psh::bin);
		} else {
			if ($echo) { $qEcho = defined_and_nonempty(@result); }
		}

		if ($qEcho) {
		        # Figure out where we'll save the result:
			if ($last_result_array ne $Psh::result_array) {
				$last_result_array = $Psh::result_array;
				my $what = ref($last_result_array);
				if ($what eq 'ARRAY') {
					$result_array_ref = $last_result_array;
					$result_array_name =
						find_array_name($result_array_ref);
					if (!defined($result_array_name)) {
						$result_array_name = 'anonymous';
					}
				} elsif ($what) {
					Psh::Util::print_warning_i18n('psh_result_array_wrong',$Psh::bin);
					$result_array_ref = \@Psh::val;
					$result_array_name = 'Psh::val';
				} else { # Ordinary string
					$result_array_name = $last_result_array;
					$result_array_name =~ s/^\@//;
					$result_array_ref = (Psh::PerlEval::protected_eval("\\\@$result_array_name"))[0];
				}
			}
			if (scalar(@result) > 1) {
				my $n = scalar(@{$result_array_ref});
				push @{$result_array_ref}, \@result;
				if ($Psh::interactive) {
					my @printresult=();
					foreach my $val (@result) {
						if (defined $val) {
							push @printresult,qq['$val'];
						} else {
							push @printresult,qq[undef];
						}
					}
					Psh::Util::print_out("\$$result_array_name\[$n] = [", join(',',@printresult), "]\n");
				}
			} else {
				my $n = scalar(@{$result_array_ref});
				my $res = $result[0];
				push @{$result_array_ref}, $res;
				Psh::Util::print_out("\$$result_array_name\[$n] = \"$res\"\n");
			}
			if (@{$result_array_ref}>100) {
				shift @{$result_array_ref};
			}
		}
	}
}

# string find_array_name ( arrayref REF, string PACKAGE )
#
# If REF is a reference to an array variable in the given PACKAGE or
# any of its subpackages, find the name of that variable and return
# it. PACKAGE defaults to main.

sub find_array_name {
	my ($arref, $pack) = @_;
	if (!defined($pack)) { $pack = "::"; }
	my @otherpacks = ();
	for my $symb ( keys %{$pack} ) {
		if ($symb =~ m/::$/) {
			push @otherpacks, $symb unless ($pack eq 'main::' and $symb eq 'main::');
		}
		elsif (\@{"$pack$symb"} eq $arref) { return "$pack$symb"; }
	}
	for my $subpack (@otherpacks) {
		my $ans = find_array_name($arref,"$pack$subpack");
		if (defined($ans)) { return $ans; }
	}
	return undef;
}

#
# bool defined_and_nonempty(args)
#
# returns true if it has any defined, nonempty args
#

sub defined_and_nonempty
{
	if (!defined(@_))    { return 0; }
	if (scalar(@_) == 0) { return 0; }

	if (scalar(@_) == 1) {
		if (!defined($_[0])) { return 0; }
		if ($_[0] eq '')     { return 0; }

		return 1;
	}

	return 1; # multiple args always true
}


#
# void process_file(string FILENAME)
#
# process() the lines of FILENAME
#

sub process_file
{
	my $path= shift;

	Psh::Util::print_debug("[PROCESSING FILE $path]\n");
	local $Psh::interactive=0;

	if (!-r $path) {
		Psh::Util::print_error_i18n('cannot_read_script',$path,$Psh::bin);
		return;
	}

	local(*FILE);
	unless (open(FILE, "< $path")) {
		Psh::Util::print_error_i18n('cannot_open_script',$path,$Psh::bin);
		return;
	}

	Psh::OS::lock(*FILE);

	if ($Psh::debugging=~ /f/ or
		$Psh::debugging eq '1') {
		process(0, sub {
					my $txt=<FILE>;
					Psh::Util::print_debug_class('f',$txt);
					return $txt;
				}); # don't prompt
	} else {
		process(0, sub { my $txt=<FILE>;$txt });
	}

	Psh::OS::unlock(*FILE);
	close(FILE);

	Psh::Util::print_debug("[FINISHED PROCESSING FILE $path]\n");
}

sub process_variable {
	my $var= shift;
	local $Psh::interactive=0;
	my @lines;
	if (ref $var eq 'ARRAY') {
		@lines=@$var;
	} else {
		@lines= split /\n/, $var;
		@lines= map { $_."\n" } @lines;
	}
	process(0, sub { shift @lines });
}

#
# string iget(string PROMPT [, boolean returnflag [, code prompt_hook]])
#
# Interactive line getting routine. If we have a
# Term::ReadLine instance, use it and record the
# input into the history buffer. Otherwise, just
# grab an input line from STDIN.
#
# If returnflag is true, iget will return after
# the user pressed ^C
#
# readline() returns a line WITHOUT a "\n" at the
# end, and <STDIN> returns one WITH a "\n", UNLESS
# the end of the input stream occurs after a non-
# newline character. So, first we chomp() the
# output of <STDIN> (if we aren't using readline()),
# and then we tack the newline back on in both
# cases. Other code later strips it off if necessary.
#
# iget() uses PROMPT as the prompt; this may be the empty string if no
# prompting is necessary.
#

sub iget
{
	my $prompt = shift;
	my $returnflag= shift;
	my $prompt_hook= shift;

	my $prompt_pre= '';
	my $line;
	my $sigint = 0;
	$Psh::interactive=1;

	# Additional newline handling for prompts as Term::ReadLine::Perl
	# cannot use them properly
	if( $Psh::term->ReadLine eq 'Term::ReadLine::Perl' &&
		$prompt=~ /^(.*\n)([^\n]+)$/) {
		$prompt_pre=$1;
		$prompt=$2;
	}

	Psh::OS::setup_readline_handler();

	LINE: do {
		$sigint= 0 if ($sigint);
		# Trap ^C in an eval.  The sighandler will die which will be
		# trapped.  Then we reprompt
		if ($Psh::term) {
			&$prompt_hook if $prompt_hook;
			print $prompt_pre if $prompt_pre;
			eval { $line = $Psh::term->readline($prompt); };
		} else {
			eval {
				&$prompt_hook if $prompt_hook;
				print $prompt_pre if $prompt_pre;
				print $prompt if $prompt;
				$line = <STDIN>;
			};
		}
		if( $@) {
			if( $@ =~ /Signal INT/) {
				$sigint= 1;
				Psh::Util::print_out_i18n('readline_interrupted');
				if( $returnflag) {
					Psh::OS::remove_readline_handler();
					return undef;
				}
			} else {
				handle_message( $@, 'iget');
			}
		}
	} while ($sigint);

	Psh::OS::remove_readline_handler();
	Psh::OS::reinstall_resize_handler();

	return undef unless defined $line;
	chomp $line;

    add_history($line);
	return $line . "\n";         # This is expected by other code.
}

sub add_history
{
	my $line=shift;
	return if !$line or $line =~ /^\s*$/;
	if (!@Psh::history || $Psh::history[$#Psh::history] ne $line) {
		my $len= Psh::Options::get_option('histsize');
		$Psh::term->addhistory($line) if $Psh::term;
		push(@Psh::history, $line);
		if( @Psh::history>$len) {
			splice(@Psh::history,0,-$len);
		}
	}
}

sub save_history
{
	return unless $Psh::term;
	Psh::Util::print_debug_class('o',"[Saving history]\n");
	if( Psh::Options::get_option('save_history')) {
		my $file= Psh::Options::get_option('history_file');
		return unless $file;
		if ($readline_saves_history) {
			$Psh::term->StifleHistory(Psh::Options::get_option('histsize'));
			$Psh::term->WriteHistory($file);
		} else {
			local(*F_HISTORY);
			if (open(F_HISTORY,">> $file")) {
				Psh::OS::lock(*F_HISTORY, Psh::OS::LOCK_EX());
				foreach (@Psh::history) {
					print F_HISTORY $_;
					print F_HISTORY "\n";
				}
				Psh::OS::unlock(*F_HISTORY);
				close(F_HISTORY);
			}
		}
	}
}

#
# void minimal_initialize()
#
# Initialize just enough to be able to read the .pshrc file; leave
# uncritical user-accessible variables until later in case the user
# sets them in .pshrc.

sub minimal_initialize
{
	$|                           = 1;                # Set output autoflush on

	#
	# Set up accessible psh:: package variables:
	#

	$Psh::eval_preamble          = '';
	$Psh::currently_active       = 0;
	$Psh::result_array           = '';
	$Psh::which_regexp           = '^[-a-zA-Z0-9_.~+]+$'; #'

	if ($]>=5.005) {
		eval {
			$Psh::which_regexp= qr($Psh::which_regexp); # compile for speed reasons
		};
		Psh::Util::print_debug_class('e',"(minimal_init) Error: $@") if $@;
	}

	$Psh::cmd                    = 1;
	my @tmp= Psh::OS::splitdir($0);
	$Psh::bin= pop @tmp;
	Psh::Options::set_option('history_file',
							 Psh::OS::catfile(Psh::OS::get_home_dir(),
											  '.'.$Psh::bin.'_history'));

	$Psh::old_shell = $ENV{SHELL} if $ENV{SHELL};
	$ENV{SHELL} = $0;
	$ENV{OLDPWD}= $ENV{PWD} = Psh::OS::getcwd_psh();

	Psh::OS::inc_shlvl();
	Psh::OS::setup_signal_handlers();

	# The following accessible variables are undef during the
	# .pshrc file:
	undef $Psh::longhost;
	undef $Psh::host;

	@Psh::val = ();
	@Psh::history= ();

	Psh::Strategy::setup_defaults();
}

#
# void finish_initialize()
#
# Set the remaining psh:: package variables if they haven't been set
# in the .pshrc file, and do other "late" initialization steps that
# depend on these variable values.

sub finish_initialize
{
	Psh::OS::setup_sigsegv_handler() if
	  Psh::Options::get_option('ignoresegfault');

	if (!defined($Psh::longhost)) {
		$Psh::longhost                    = $ENV{HOSTNAME}||Psh::OS::get_hostname();
		chomp $Psh::longhost;
	}
	if (!defined($Psh::host)) {
		$Psh::host= $Psh::longhost;
		$Psh::host= $1 if( $Psh::longhost=~ /([^\.]+)\..*/);
	}
	$ENV{HOSTNAME}= $Psh::host;
}

sub initialize_interactive_mode {
	if (-t STDIN) {
		#
		# Set up Term::ReadLine:
		#
		eval { require Term::ReadLine; };
		if ($@) {
			$Psh::term = undef;
			Psh::Util::print_error_i18n('no_readline');
		} else {
			eval { $Psh::term= Term::ReadLine->new('psh'); };
			if( $@) {
				# Try one more time after a second, maybe the tty is
				# not setup
				sleep 1;
				eval { $Psh::term= Term::ReadLine->new('psh'); };
				if( $@) {
					Psh::Util::print_error_i18n('readline_error',$@);
					$Psh::term= undef;
				}
			}
			if( $Psh::term) {
				$Psh::term->MinLine(10000);   # We will handle history adding
				# ourselves (undef causes trouble).
				$Psh::term->ornaments(0);
				Psh::Util::print_debug_class('i','[Using ReadLine: ', $Psh::term->ReadLine(), "]\n");
				if ($Psh::term->ReadLine() eq 'Term::ReadLine::Gnu') {
					$readline_saves_history = 1;
				}
				my $attribs= $Psh::term->Attribs;
				$attribs->{completion_function} =
				  \&completion_dummy;

				my $word_break=" \\\n\t\"&{}('`\$\%\@~<>=;|/";
				$attribs->{special_prefixes}= "\$\%\@\~\&";
				$attribs->{word_break_characters}= $word_break;
				$attribs->{completer_word_break_characters}= $word_break ;
			}
		}

		Psh::OS::install_resize_handler();
		Psh::OS::reinstall_resize_handler();
		# ReadLine objects often mess with the SIGWINCH handler

		setup_term_misc();
	}

	if (defined($Psh::term) and Psh::Options::get_option('save_history')) {
		my $file= Psh::Options::get_option('history_file');
		return unless $file;
		if ($readline_saves_history) {
			$Psh::term->StifleHistory(Psh::Options::get_option('histsize'));
			$Psh::term->ReadHistory($file);
		} else {
			local(*F_HISTORY);
			if (open(F_HISTORY,"< $file")) {
				Psh::OS::lock(*F_HISTORY);
				while (<F_HISTORY>) {
					chomp;
					$Psh::term->addhistory($_);
				}
				Psh::OS::unlock(*F_HISTORY);
				close(F_HISTORY);
			}
		}
	}
}


#
# We're used for the first TAB completion - load
# the real completion module and call it
#
sub completion_dummy {
	my @args= @_;

	require Psh::Completion;
	Psh::Completion::init();
    $Psh::term->Attribs->{completion_function} =
	  \&Psh::Completion::completion;
	return Psh::Completion::completion(@_);
}

sub setup_term_misc {
	return unless $Psh::term;
	if ($Psh::term->can('add_defun')) { # Term::ReadLine::Gnu
		$Psh::term->add_defun('run-help', \&run_help);
		$Psh::term->parse_and_bind("\"\eh\":run-help"); # bind to ESC-h
	}
}

sub run_help {
	require Psh::Builtins::Help;
	my $line= substr($Psh::term->Attribs->{line_buffer},0,
					 $Psh::term->Attribs->{end});
	Psh::Builtins::Help::any_help($line);
}

#
# void process_rc()
#
# Search for and process .pshrc files.
#

sub process_rc
{
	my $opt_f= shift;
	my @rc;

	if ($opt_f) {
		push @rc, $opt_f;
	} else {
		push @rc, Psh::OS::get_rc_files();
	}

	foreach my $rc (@rc) {
		if (-r $rc) {
			Psh::Util::print_debug_class('i',"[PROCESSING $rc]\n");
			process_file($rc);
		}
	}
}


#
# void process_args()
#
# Process files listed on command-line.
#

sub process_args
{
	Psh::Util::print_debug_class('i',"[PROCESSING @ARGV FILES]\n");

	foreach my $arg (@ARGV) {
		if (-r $arg) {
			Psh::Util::print_debug('i',"[PROCESSING $arg]\n");
			process_file($arg);
		}
	}
}


#
# void main_loop()
#
# Determine whether or not we are operating interactively,
# set up the input routine accordingly, and process the
# input.
#

sub main_loop
{
	my $interactive = (-t STDIN) and (-t STDOUT);
	my $get;

	Psh::Util::print_debug_class('i',"[STARTING MAIN LOOP]\n");

	if ($interactive) { $get = \&iget;                  }
	else              { $get = sub { return <STDIN>; }; }

	process($interactive, $get);
}

# bool is_number(ARG)
#
# Return true if ARG is a number
#

sub is_number
{
	my $test = shift;
	return defined($test) && !ref($test) &&
		$test=~/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/o;
}

#
# End of file.
#

1;
Commit	Line	Data
86530b38 AT	1	package Psh;
	2
	3	use vars qw($VERSION);
	4
	5	$VERSION='1.8';
	6
	7	BEGIN {
	8	require Psh::OS;
	9	}
	10
	11	require Psh::Util;
	12	require Psh::Locale;
	13	require Psh::Strategy;
	14	require Psh::Joblist;
	15	require Psh::Parser;
	16	require Psh::PerlEval;
	17	require Psh::Options;
	18
	19	use strict;
	20
	21	##############################################################################
	22	##############################################################################
	23	##
	24	## Variables
	25	##
	26	##############################################################################
	27	##############################################################################
	28
	29
	30	#
	31	# Private, Lexical Variables:
	32	#
	33
	34
	35	my ($input,$readline_saves_history);
	36	##############################################################################
	37	##############################################################################
	38	##
	39	## SUBROUTINES: Command-line processing
	40	##
	41	##############################################################################
	42	##############################################################################
	43
	44	#
	45	# void handle_message (string MESSAGE, string FROM = 'eval')
	46	#
	47	# handles any message that an eval might have returned. Distinguishes
	48	# internal messages from Psh's signal handlers from all other
	49	# messages. It displays internal messages with print_out or does
	50	# nothing with them if FROM = 'main_loop'. It displays other messages with
	51	# print_error, and if FROM = 'main_loop', psh dies in addition.
	52	#
	53
	54	sub handle_message
	55	{
	56	my ($message, $from) = @_;
	57
	58	if (!defined($from)) { $from = 'eval'; }
	59
	60	chomp $message;
	61
	62	if ($message) {
	63	return if ($from eq 'hide');
	64	if ($message =~ m/^SECRET $Psh::bin:(.*)$/s) {
65	if ($from ne 'main_loop') { Psh::Util::print_out("$1\n"); }
66	} else {
67	Psh::Util::print_error("$from error ($message)!\n");
68	if ($from eq 'main_loop') {
69	if( Psh::Options::get_option('ignoredie')) {
70	Psh::Util::print_error_i18n('internal_error');
71	} else {
72	die("Internal psh error.");
73	}
74	}
75	}
76	}
77	}
78
79	sub evl {
80	my ($line, @use_strats) = @_;
81
82	local @Psh::temp_use_strats;
83	push @Psh::temp_use_strats, @use_strats if @use_strats;
84
85	process_variable($line);
86	return ($Psh::last_success_code, @Psh::last_result);
87	}
88
89	sub _evl {
90	my @elements= @_;
91	my @result=();
92	my $trace= Psh::Options::get_option('trace');
93	while( my $element= shift @elements) {
94	my @tmp= @$element;
95	my $type= shift @tmp;
96	if ($type == Psh::Parser::T_EXECUTE()) {
97	if ($trace) {
98	for (my $i=1; $i<@tmp; $i++) {
99	print STDERR "+ $tmp[$i][4]\n";
100	}
101	}
102	eval {
103	@result= Psh::OS::execute_complex_command(\@tmp);
104	};
105	handle_message($@);
106	} elsif ($type == Psh::Parser::T_OR()) {
107	return @result if @result and $result[0]; # we already had success
108	} elsif ($type == Psh::Parser::T_AND()) {
109	return (0) unless @result;
110	next if ($result[0]); # we last had success
111	return (0);
112	} else {
113	Psh::Util::print_error("evl: Don't know type $type\n");
114	}
115	}
116	return @result;
117	}
118
119	#
120	# string read_until(PROMPT_TEMPL, string TERMINATOR, subr GET)
121	#
122	# Get successive lines via calls to GET until one of those
123	# entire lines matches the patterm TERMINATOR. Used to implement
124	# the `<<EOF` multiline quoting construct and brace matching;
125	#
126	# TODO: Undo any side effects of, e.g., m//.
127	#
128
129	sub read_until
130	{
131	my ($prompt_templ, $terminator, $get) = @_;
132	my $input;
133	my $temp;
134
135	my @input;
136
137	while (1) {
138	$temp = $prompt_templ?&$get(Psh::Prompt::prompt_string($prompt_templ),
139	1,\&Psh::Prompt::pre_prompt_hook):
140	&$get();
141	if (!defined($temp)) {
142	Psh::Util::print_error_i18n('input_incomplete',join('',@input),$Psh::bin);
143	return '';
144	}
145	last if $temp =~ m/^$terminator$/;
146	push @input, $temp;
147	}
148
149	return join('',@input);
150	}
151
152	# string read_until_complete(PROMPT_TEMPL, string SO_FAR, subr GET)
153	#
154	# Get successive lines via calls to GET until the cumulative input so
155	# far is not an incomplete expression according to
156	# incomplete_expr. Prompting is done with PROMPT_TEMPL.
157	#
158
159	sub read_until_complete
160	{
161	my ($prompt_templ, $sofar, $get) = @_;
162	my $temp;
163	my @input=();
164
165	while (1) {
166	$temp = $prompt_templ?
167	&$get(Psh::Prompt::prompt_string($prompt_templ),1,
168	\&Psh::Prompt::pre_prompt_hook):
169	&$get();
170	if (!defined($temp)) {
171	Psh::Util::print_error_i18n('input_incomplete',$sofar,$Psh::bin);
172	return '';
173	}
174	$sofar .= $temp;
175	last if Psh::Parser::incomplete_expr($sofar) <= 0;
176	}
177
178	return $sofar;
179	}
180
181
182	#
183	# void process(bool Q_PROMPT, subr GET)
184	#
185	# Process lines produced by the subroutine reference GET until it
186	# returns undef. GET must be a reference to a subroutine which takes a
187	# string argument (the prompt, which may be empty) and returns the
188	# next line of input, or undef if there is none.
189	#
190	# Any output generated is handled by the various print_xxx routines
191	#
192	# The prompt is printed only if the Q_PROMPT argument is true. When
193	# sourcing files (like .pshrc), it is important to not print the
194	# prompt string, but for interactive use, it is important to print it.
195	#
196	# TODO: Undo any side effects, e.g. done by m//.
197	#
198
199	sub process
200	{
201	my ($q_prompt, $get) = @_;
202	local $Psh::cmd;
203
204	my $last_result_array = '';
205	my $result_array_ref = \@Psh::val;
206	my $result_array_name = 'Psh::val';
207
208	my $control_d_counter=0;
209
210	if ($q_prompt) {
211	require Psh::Prompt;
212	}
213
214	while (1) {
215	if ($q_prompt) {
216	$input = &$get(Psh::Prompt::prompt_string(Psh::Prompt::normal_prompt()), 0, \&Psh::Prompt::pre_prompt_hook);
217	} else {
218	$input = &$get();
219	}
220
221	Psh::OS::reap_children(); # Check wether we have dead children
222	Psh::OS::check_terminal_size() if $Psh::interactive;
223
224	$Psh::cmd++;
225
226	unless (defined($input)) {
227	last unless $Psh::interactive;
228	print STDOUT "\n";
229	$control_d_counter++;
230	my $control_d_max=$ENV{IGNOREEOF}\|\|0;
231	if ($control_d_max !~ /^\d$/) {
232	$control_d_max=10;
233	}
234	Psh::OS::exit_psh() if ($control_d_counter>=$control_d_max);
235	next;
236	}
237	$control_d_counter=0;
238
239	next unless $input;
240	next if $input=~ m/^\s*$/;
241
242	if ($input =~ m/(.)<<([a-zA-Z_0-9\-])(.*)/) {
243	my $pre= $1;
244	my $terminator = $2;
245	my $post= $3;
246
247	my $continuation = $q_prompt ? Psh::Prompt::continue_prompt() : '';
248	$input = join('',$pre,'"',
249	read_until($continuation, $terminator, $get),
250	$terminator,'"',$post,"\n");
251	} elsif (Psh::Parser::incomplete_expr($input) > 0) {
252	my $continuation = $q_prompt ? Psh::Prompt::continue_prompt() : '';
253	$input = read_until_complete($continuation, $input, $get);
254	}
255
256	chomp $input;
257
258	my ($success,@result);
259	my @elements= eval { Psh::Parser::parse_line($input) };
260	Psh::Util::print_debug_class('e',"(evl) Error: $@") if $@;
261	if (@elements) {
262	my $result;
263	($success,$result)= _evl(@elements);
264	Psh::Util::print_debug_class('s',"Success: $success\n");
265	$Psh::last_success_code= $success;
266	if ($result) {
267	@Psh::last_result= @result= @$result;
268	} else {
269	undef @Psh::last_result;
270	undef @result;
271	}
272	} else {
273	undef $Psh::last_success_code;
274	undef @Psh::last_result;
275	}
276
277	next unless $Psh::interactive;
278
279	my $qEcho = 0;
280	my $echo= Psh::Options::get_option('echo');
281
282	if (ref($echo) eq 'CODE') {
283	$qEcho = &$echo(@result);
284	} elsif (ref($echo)) {
285	Psh::Util::print_warning_i18n('psh_echo_wrong',$Psh::bin);
286	} else {
287	if ($echo) { $qEcho = defined_and_nonempty(@result); }
288	}
289
290	if ($qEcho) {
291	# Figure out where we'll save the result:
292	if ($last_result_array ne $Psh::result_array) {
293	$last_result_array = $Psh::result_array;
294	my $what = ref($last_result_array);
295	if ($what eq 'ARRAY') {
296	$result_array_ref = $last_result_array;
297	$result_array_name =
298	find_array_name($result_array_ref);
299	if (!defined($result_array_name)) {
300	$result_array_name = 'anonymous';
301	}
302	} elsif ($what) {
303	Psh::Util::print_warning_i18n('psh_result_array_wrong',$Psh::bin);
304	$result_array_ref = \@Psh::val;
305	$result_array_name = 'Psh::val';
306	} else { # Ordinary string
307	$result_array_name = $last_result_array;
308	$result_array_name =~ s/^\@//;
309	$result_array_ref = (Psh::PerlEval::protected_eval("\\\@$result_array_name"))[0];
310	}
311	}
312	if (scalar(@result) > 1) {
313	my $n = scalar(@{$result_array_ref});
314	push @{$result_array_ref}, \@result;
315	if ($Psh::interactive) {
316	my @printresult=();
317	foreach my $val (@result) {
318	if (defined $val) {
319	push @printresult,qq['$val'];
320	} else {
321	push @printresult,qq[undef];
322	}
323	}
324	Psh::Util::print_out("\$$result_array_name\[$n] = [", join(',',@printresult), "]\n");
325	}
326	} else {
327	my $n = scalar(@{$result_array_ref});
328	my $res = $result[0];
329	push @{$result_array_ref}, $res;
330	Psh::Util::print_out("\$$result_array_name\[$n] = \"$res\"\n");
331	}
332	if (@{$result_array_ref}>100) {
333	shift @{$result_array_ref};
334	}
335	}
336	}
337	}
338
339	# string find_array_name ( arrayref REF, string PACKAGE )
340	#
341	# If REF is a reference to an array variable in the given PACKAGE or
342	# any of its subpackages, find the name of that variable and return
343	# it. PACKAGE defaults to main.
344
345	sub find_array_name {
346	my ($arref, $pack) = @_;
347	if (!defined($pack)) { $pack = "::"; }
348	my @otherpacks = ();
349	for my $symb ( keys %{$pack} ) {
350	if ($symb =~ m/::$/) {
351	push @otherpacks, $symb unless ($pack eq 'main::' and $symb eq 'main::');
352	}
353	elsif (\@{"$pack$symb"} eq $arref) { return "$pack$symb"; }
354	}
355	for my $subpack (@otherpacks) {
356	my $ans = find_array_name($arref,"$pack$subpack");
357	if (defined($ans)) { return $ans; }
358	}
359	return undef;
360	}
361
362	#
363	# bool defined_and_nonempty(args)
364	#
365	# returns true if it has any defined, nonempty args
366	#
367
368	sub defined_and_nonempty
369	{
370	if (!defined(@_)) { return 0; }
371	if (scalar(@_) == 0) { return 0; }
372
373	if (scalar(@_) == 1) {
374	if (!defined($_[0])) { return 0; }
375	if ($_[0] eq '') { return 0; }
376
377	return 1;
378	}
379
380	return 1; # multiple args always true
381	}
382
383
384	#
385	# void process_file(string FILENAME)
386	#
387	# process() the lines of FILENAME
388	#
389
390	sub process_file
391	{
392	my $path= shift;
393
394	Psh::Util::print_debug("[PROCESSING FILE $path]\n");
395	local $Psh::interactive=0;
396
397	if (!-r $path) {
398	Psh::Util::print_error_i18n('cannot_read_script',$path,$Psh::bin);
399	return;
400	}
401
402	local(*FILE);
403	unless (open(FILE, "< $path")) {
404	Psh::Util::print_error_i18n('cannot_open_script',$path,$Psh::bin);
405	return;
406	}
407
408	Psh::OS::lock(*FILE);
409
410	if ($Psh::debugging=~ /f/ or
411	$Psh::debugging eq '1') {
412	process(0, sub {
413	my $txt=<FILE>;
414	Psh::Util::print_debug_class('f',$txt);
415	return $txt;
416	}); # don't prompt
417	} else {
418	process(0, sub { my $txt=<FILE>;$txt });
419	}
420
421	Psh::OS::unlock(*FILE);
422	close(FILE);
423
424	Psh::Util::print_debug("[FINISHED PROCESSING FILE $path]\n");
425	}
426
427	sub process_variable {
428	my $var= shift;
429	local $Psh::interactive=0;
430	my @lines;
431	if (ref $var eq 'ARRAY') {
432	@lines=@$var;
433	} else {
434	@lines= split /\n/, $var;
435	@lines= map { $_."\n" } @lines;
436	}
437	process(0, sub { shift @lines });
438	}
439
440	#
441	# string iget(string PROMPT [, boolean returnflag [, code prompt_hook]])
442	#
443	# Interactive line getting routine. If we have a
444	# Term::ReadLine instance, use it and record the
445	# input into the history buffer. Otherwise, just
446	# grab an input line from STDIN.
447	#
448	# If returnflag is true, iget will return after
449	# the user pressed ^C
450	#
451	# readline() returns a line WITHOUT a "\n" at the
452	# end, and <STDIN> returns one WITH a "\n", UNLESS
453	# the end of the input stream occurs after a non-
454	# newline character. So, first we chomp() the
455	# output of <STDIN> (if we aren't using readline()),
456	# and then we tack the newline back on in both
457	# cases. Other code later strips it off if necessary.
458	#
459	# iget() uses PROMPT as the prompt; this may be the empty string if no
460	# prompting is necessary.
461	#
462
463	sub iget
464	{
465	my $prompt = shift;
466	my $returnflag= shift;
467	my $prompt_hook= shift;
468
469	my $prompt_pre= '';
470	my $line;
471	my $sigint = 0;
472	$Psh::interactive=1;
473
474	# Additional newline handling for prompts as Term::ReadLine::Perl
475	# cannot use them properly
476	if( $Psh::term->ReadLine eq 'Term::ReadLine::Perl' &&
477	$prompt=~ /^(.*\n)([^\n]+)$/) {
478	$prompt_pre=$1;
479	$prompt=$2;
480	}
481
482	Psh::OS::setup_readline_handler();
483
484	LINE: do {
485	$sigint= 0 if ($sigint);
486	# Trap ^C in an eval. The sighandler will die which will be
487	# trapped. Then we reprompt
488	if ($Psh::term) {
489	&$prompt_hook if $prompt_hook;
490	print $prompt_pre if $prompt_pre;
491	eval { $line = $Psh::term->readline($prompt); };
492	} else {
493	eval {
494	&$prompt_hook if $prompt_hook;
495	print $prompt_pre if $prompt_pre;
496	print $prompt if $prompt;
497	$line = <STDIN>;
498	};
499	}
500	if( $@) {
501	if( $@ =~ /Signal INT/) {
502	$sigint= 1;
503	Psh::Util::print_out_i18n('readline_interrupted');
504	if( $returnflag) {
505	Psh::OS::remove_readline_handler();
506	return undef;
507	}
508	} else {
509	handle_message( $@, 'iget');
510	}
511	}
512	} while ($sigint);
513
514	Psh::OS::remove_readline_handler();
515	Psh::OS::reinstall_resize_handler();
516
517	return undef unless defined $line;
518	chomp $line;
519
520	add_history($line);
521	return $line . "\n"; # This is expected by other code.
522	}
523
524	sub add_history
525	{
526	my $line=shift;
527	return if !$line or $line =~ /^\s*$/;
528	if (!@Psh::history \|\| $Psh::history[$#Psh::history] ne $line) {
529	my $len= Psh::Options::get_option('histsize');
530	$Psh::term->addhistory($line) if $Psh::term;
531	push(@Psh::history, $line);
532	if( @Psh::history>$len) {
533	splice(@Psh::history,0,-$len);
534	}
535	}
536	}
537
538	sub save_history
539	{
540	return unless $Psh::term;
541	Psh::Util::print_debug_class('o',"[Saving history]\n");
542	if( Psh::Options::get_option('save_history')) {
543	my $file= Psh::Options::get_option('history_file');
544	return unless $file;
545	if ($readline_saves_history) {
546	$Psh::term->StifleHistory(Psh::Options::get_option('histsize'));
547	$Psh::term->WriteHistory($file);
548	} else {
549	local(*F_HISTORY);
550	if (open(F_HISTORY,">> $file")) {
551	Psh::OS::lock(*F_HISTORY, Psh::OS::LOCK_EX());
552	foreach (@Psh::history) {
553	print F_HISTORY $_;
554	print F_HISTORY "\n";
555	}
556	Psh::OS::unlock(*F_HISTORY);
557	close(F_HISTORY);
558	}
559	}
560	}
561	}
562
563	#
564	# void minimal_initialize()
565	#
566	# Initialize just enough to be able to read the .pshrc file; leave
567	# uncritical user-accessible variables until later in case the user
568	# sets them in .pshrc.
569
570	sub minimal_initialize
571	{
572	$\| = 1; # Set output autoflush on
573
574	#
575	# Set up accessible psh:: package variables:
576	#
577
578	$Psh::eval_preamble = '';
579	$Psh::currently_active = 0;
580	$Psh::result_array = '';
581	$Psh::which_regexp = '^[-a-zA-Z0-9_.~+]+$'; #'
582
583	if ($]>=5.005) {
584	eval {
585	$Psh::which_regexp= qr($Psh::which_regexp); # compile for speed reasons
586	};
587	Psh::Util::print_debug_class('e',"(minimal_init) Error: $@") if $@;
588	}
589
590	$Psh::cmd = 1;
591	my @tmp= Psh::OS::splitdir($0);
592	$Psh::bin= pop @tmp;
593	Psh::Options::set_option('history_file',
594	Psh::OS::catfile(Psh::OS::get_home_dir(),
595	'.'.$Psh::bin.'_history'));
596
597	$Psh::old_shell = $ENV{SHELL} if $ENV{SHELL};
598	$ENV{SHELL} = $0;
599	$ENV{OLDPWD}= $ENV{PWD} = Psh::OS::getcwd_psh();
600
601	Psh::OS::inc_shlvl();
602	Psh::OS::setup_signal_handlers();
603
604	# The following accessible variables are undef during the
605	# .pshrc file:
606	undef $Psh::longhost;
607	undef $Psh::host;
608
609	@Psh::val = ();
610	@Psh::history= ();
611
612	Psh::Strategy::setup_defaults();
613	}
614
615	#
616	# void finish_initialize()
617	#
618	# Set the remaining psh:: package variables if they haven't been set
619	# in the .pshrc file, and do other "late" initialization steps that
620	# depend on these variable values.
621
622	sub finish_initialize
623	{
624	Psh::OS::setup_sigsegv_handler() if
625	Psh::Options::get_option('ignoresegfault');
626
627	if (!defined($Psh::longhost)) {
628	$Psh::longhost = $ENV{HOSTNAME}\|\|Psh::OS::get_hostname();
629	chomp $Psh::longhost;
630	}
631	if (!defined($Psh::host)) {
632	$Psh::host= $Psh::longhost;
633	$Psh::host= $1 if( $Psh::longhost=~ /([^\.]+)\..*/);
634	}
635	$ENV{HOSTNAME}= $Psh::host;
636	}
637
638	sub initialize_interactive_mode {
639	if (-t STDIN) {
640	#
641	# Set up Term::ReadLine:
642	#
643	eval { require Term::ReadLine; };
644	if ($@) {
645	$Psh::term = undef;
646	Psh::Util::print_error_i18n('no_readline');
647	} else {
648	eval { $Psh::term= Term::ReadLine->new('psh'); };
649	if( $@) {
650	# Try one more time after a second, maybe the tty is
651	# not setup
652	sleep 1;
653	eval { $Psh::term= Term::ReadLine->new('psh'); };
654	if( $@) {
655	Psh::Util::print_error_i18n('readline_error',$@);
656	$Psh::term= undef;
657	}
658	}
659	if( $Psh::term) {
660	$Psh::term->MinLine(10000); # We will handle history adding
661	# ourselves (undef causes trouble).
662	$Psh::term->ornaments(0);
663	Psh::Util::print_debug_class('i','[Using ReadLine: ', $Psh::term->ReadLine(), "]\n");
664	if ($Psh::term->ReadLine() eq 'Term::ReadLine::Gnu') {
665	$readline_saves_history = 1;
666	}
667	my $attribs= $Psh::term->Attribs;
668	$attribs->{completion_function} =
669	\&completion_dummy;
670
671	my $word_break=" \\\n\t\"&{}('`\$\%\@~<>=;\|/";
672	$attribs->{special_prefixes}= "\$\%\@\~\&";
673	$attribs->{word_break_characters}= $word_break;
674	$attribs->{completer_word_break_characters}= $word_break ;
675	}
676	}
677
678	Psh::OS::install_resize_handler();
679	Psh::OS::reinstall_resize_handler();
680	# ReadLine objects often mess with the SIGWINCH handler
681
682	setup_term_misc();
683	}
684
685	if (defined($Psh::term) and Psh::Options::get_option('save_history')) {
686	my $file= Psh::Options::get_option('history_file');
687	return unless $file;
688	if ($readline_saves_history) {
689	$Psh::term->StifleHistory(Psh::Options::get_option('histsize'));
690	$Psh::term->ReadHistory($file);
691	} else {
692	local(*F_HISTORY);
693	if (open(F_HISTORY,"< $file")) {
694	Psh::OS::lock(*F_HISTORY);
695	while (<F_HISTORY>) {
696	chomp;
697	$Psh::term->addhistory($_);
698	}
699	Psh::OS::unlock(*F_HISTORY);
700	close(F_HISTORY);
701	}
702	}
703	}
704	}
705
706
707	#
708	# We're used for the first TAB completion - load
709	# the real completion module and call it
710	#
711	sub completion_dummy {
712	my @args= @_;
713
714	require Psh::Completion;
715	Psh::Completion::init();
716	$Psh::term->Attribs->{completion_function} =
717	\&Psh::Completion::completion;
718	return Psh::Completion::completion(@_);
719	}
720
721	sub setup_term_misc {
722	return unless $Psh::term;
723	if ($Psh::term->can('add_defun')) { # Term::ReadLine::Gnu
724	$Psh::term->add_defun('run-help', \&run_help);
725	$Psh::term->parse_and_bind("\"\eh\":run-help"); # bind to ESC-h
726	}
727	}
728
729	sub run_help {
730	require Psh::Builtins::Help;
731	my $line= substr($Psh::term->Attribs->{line_buffer},0,
732	$Psh::term->Attribs->{end});
733	Psh::Builtins::Help::any_help($line);
734	}
735
736	#
737	# void process_rc()
738	#
739	# Search for and process .pshrc files.
740	#
741
742	sub process_rc
743	{
744	my $opt_f= shift;
745	my @rc;
746
747	if ($opt_f) {
748	push @rc, $opt_f;
749	} else {
750	push @rc, Psh::OS::get_rc_files();
751	}
752
753	foreach my $rc (@rc) {
754	if (-r $rc) {
755	Psh::Util::print_debug_class('i',"[PROCESSING $rc]\n");
756	process_file($rc);
757	}
758	}
759	}
760
761
762	#
763	# void process_args()
764	#
765	# Process files listed on command-line.
766	#
767
768	sub process_args
769	{
770	Psh::Util::print_debug_class('i',"[PROCESSING @ARGV FILES]\n");
771
772	foreach my $arg (@ARGV) {
773	if (-r $arg) {
774	Psh::Util::print_debug('i',"[PROCESSING $arg]\n");
775	process_file($arg);
776	}
777	}
778	}
779
780
781	#
782	# void main_loop()
783	#
784	# Determine whether or not we are operating interactively,
785	# set up the input routine accordingly, and process the
786	# input.
787	#
788
789	sub main_loop
790	{
791	my $interactive = (-t STDIN) and (-t STDOUT);
792	my $get;
793
794	Psh::Util::print_debug_class('i',"[STARTING MAIN LOOP]\n");
795
796	if ($interactive) { $get = \&iget; }
797	else { $get = sub { return <STDIN>; }; }
798
799	process($interactive, $get);
800	}
801
802	# bool is_number(ARG)
803	#
804	# Return true if ARG is a number
805	#
806
807	sub is_number
808	{
809	my $test = shift;
810	return defined($test) && !ref($test) &&
811	$test=~/^([+-]?)(?=\d\|\.\d)\d(\.\d)?([Ee]([+-]?\d+))?$/o;
812	}
813
814	#
815	# End of file.
816	#
817
818	1;