File Coverage

blib/lib/Psh/Parser.pm

Criterion	Covered	Total	%
statement	6	353	1.7
branch	0	200	0.0
condition	0	117	0.0
subroutine	2	16	12.5
pod	0	12	0.0
total	8	698	1.1

#! /usr/local/bin/perl -w
package Psh::Parser;

use strict;

require Psh::OS;
require Psh::Util;
require Psh::Strategy;

sub T_END() { 0; }
sub T_WORD() { 1; }
sub T_PIPE() { 2; }
sub T_REDIRECT() { 3; }
sub T_BACKGROUND() { 4; }
sub T_OR() { 5; }
sub T_AND() { 6; }

sub T_EXECUTE() { 1; }

# ugly, ugly, but makes things faster

my %quotehash = qw|' ' " " q( ) qw( ) qq( ) ` `|;
my %quotedquotes = ();
my $def_quoteexp;
my $def_tokenizer= '(\\s+|\\|\\||\\&\\&|\||=>|->|;;|;|\\&|>>|>|<<|<|\\(|\\)|\\{|\\}|\\[|\\])';
my $nevermatches = "(?!a)a";


$def_quoteexp = $nevermatches;
foreach my $opener (keys %quotehash) {
	$def_quoteexp .= '|' . quotemeta($opener);
	$quotedquotes{$opener} = quotemeta($quotehash{$opener});
}

my $stdallinall= "^((?:[^\\\\]|\\\\.)*?)(?:$def_tokenizer|($def_quoteexp))(.*)\$";

if ($]>=5.005) {
	eval {
		$stdallinall= qr{$stdallinall}s;
	};
}

sub decompose {
    my ($delimexp,$line,$num,$keep,$unmatched) = @_;
	my @matches;

    if (!defined($delimexp)) { $delimexp = $def_tokenizer; }
	elsif ($delimexp eq ' ') { $delimexp='(\s+)'; }

    if (!defined($num)) { $num = -1; }
    if (!defined($keep)) { $keep = 1; }

    # Remember if delimexp came with any parenthesized subexpr, and
    # arrange for it to have exactly one so we know what each piece in
    # the match below means:

    my $saveDelimiters = 0;
    @matches = ('x' =~ m/$delimexp|(.)/);
    if (@matches > 2) {
		require Carp;
		Carp::carp("Delimiter regexp '$delimexp' in decompose may " .
		  "contain at most 1 ().");
		return undef;
    }
    if (@matches == 2) {
      $saveDelimiters = 1;
    } else {
      $delimexp = "($delimexp)";
    }

	return _decompose($line, "^((?:[^\\\\]|\\\\.)*?)(?:$delimexp|($def_quoteexp))(.*)\$", $keep, $num, $unmatched, $saveDelimiters-1);
}

sub _decompose
{
	my ( $line, $regexp, $keep, $num, $unmatched, $saveDelimiters)= @_;

	$saveDelimiters++;
    my @pieces = ('');
    my $startNewPiece = 0;
    my $freshPiece = 1;
    my $uquote = 0;
    while ($line) {
		if ($startNewPiece) {
			push @pieces, '';
		    $startNewPiece = 0;
		    $freshPiece = 1;
	    }
	    if (@pieces == $num) { last; }

	    # $delimexp is unparenthesized below because we have
	    # already arranged for it to contain exactly one backref ()
		my ($prefix,$delimiter,$quote,$rest) =
	      ($line =~ m/$regexp/s);
	    if (!$keep and defined($prefix)) {
			$prefix= remove_backslash($prefix);
	    }
	    if (defined($delimiter)) {
		    $pieces[$#pieces] .= $prefix;
		    if ($saveDelimiters) {
				if (length($pieces[$#pieces]) or !$freshPiece) {
					push @pieces, $delimiter;
				} else {
					$pieces[$#pieces] = $delimiter;
				}
			    $startNewPiece = 1;
		    } elsif (@pieces > 1 or $pieces[0]) {
		  	    $startNewPiece = 1;
		    }
		    $line = $rest;
	    } elsif (defined($quote)) {
			my ($restOfQuote,$remainder) =
			  ($rest =~ m/^((?:[^\\]|\\.)*?)$quotedquotes{$quote}(.*)$/s);
			if (defined($restOfQuote)) {
				if (!$keep and
				    $quote ne "\'" and $quote ne 'q(') {
					$restOfQuote= remove_backslash($restOfQuote);
				}
				$pieces[$#pieces]= join('',$pieces[$#pieces],$prefix,
										$quote,$restOfQuote,
										$quotehash{$quote});
				$line = $remainder;
				$freshPiece = 0;
			} else { # can't find matching quote, give up
				$uquote = 1;
				last;
			}
	    } else { # nothing found, so remainder all one unquoted piece
			if (!$keep and length($line)) {
				$line= remove_backslash($line);
		    }
		    last;
	    }
    }
    if (length($line)) { $pieces[$#pieces] .= $line; }
    if (defined($unmatched)) { ${$unmatched} = $uquote; }
    return wantarray?@pieces:\@pieces;
}

sub incomplete_expr
{
    my ($line) = @_;
	return 0 unless $line=~/[\[{('"]/s;

    my $unmatch = 0;
	my @words= 	@{scalar(_decompose($line,$stdallinall, 1, undef, \$unmatch))};
    if ($unmatch) { return 2; }

    my @openstack = (':'); # : is used as a bottom marker here
    my %open_of_close = qw|) ( } { ] [ " '|;

    foreach my $word (@words) {
		next if length($word)!=1;
		if ($word eq '[' or $word eq '{' or $word eq '(' or $word eq '"' or
		    $word eq "\"") {
			push @openstack, $word;
		} elsif ($word eq ')' or $word eq '}' or $word eq ']' or $word eq '"' or
				 $word eq "\"") {
			my $open= $open_of_close{$word};
			my $curopen = pop @openstack;
			if ($open ne $curopen) {
				return -1;
			}
		}
    }
    if (scalar(@openstack) > 1) { return 1; }
    return 0;
}

#
# glob_expansion()
#
# LINE EXPANSIONS:
#
# If we're going to be a shell, let's act like a shell. The idea here
# is to provide expansion functions that individual evaluation
# strategies can use on the argument list to perform operations
# similar to the ones a shell argument list undergoes. Each of these
# functions should take a reference to an array of "words" and return
# a solid (to be conservative, as opposed to modifying in place) array of
# "expanded words".
#
# Bash defines eight types of expansion in its manpage: brace
# expansion, tilde expansion, parameter and variable expansion,
# command substitution, arithmetic expansion, word splitting,
# pathname expansion, and process expansion.
#
# Of these, arithmetic expansion makes no sense in Perl. Word
# splitting should happen "on the fly", i.e., the array returned by
# one of these functions might have more elements than the argument
# did. Since the perl builtin "glob" handles brace, tilde and pathname
# expansion, here's a glob_expansion function that covers all of
# those. Also a variable_expansion function that handles substituting
# in the values of Perl variables. That leaves only:
#
# TODO: command_expansion (i.e., backticks. For this,
# backticks would have to be added to decompose as a recognized quote
# character), process_expansion
#
# TODO: should some of these line-processing actions happen in a
# uniform way, or should things simply be left to each evaluation strategy
# as psh currently works?
#
# array glob_expansion (arrayref WORDS)
#
# For each element x of the array referred to by WORDS, such that x
# is not quoted, push glob(x) onto an array, and return the collected array.
#

sub glob_expansion
{
	my $arref= shift;
	my $join_char= shift;
	my @retval  = ();

	for my $word (@{$arref}) {
		if ($word =~ m/['"']/ # if it contains quotes
			or ($word !~ m/{.*}|\[.*\]|[*?~]/)) { # or no globbing characters
			push @retval, $word;  # don't try to glob it
		} else {
			# Glob it. If anything happens, quote the
			# results so they won't be clobbbered later.
			my @results = Psh::OS::glob($word);
			if (scalar(@results) == 0) {
				@results = ($word);
			} elsif (scalar(@results)>1 or $results[0] ne $word) {
				foreach (@results) { $_ = "'$_'"; }
			}
			if( $join_char) {
				push @retval, join($join_char, @results);
			} else {
				push @retval, @results;
			}
		}
	}

	return @retval;
}

sub unquote {
	my $text= shift;

	if (substr($text,0,1) eq '\'' and
	    substr($text,-1,1) eq '\'') {
		$text= substr($text,1,-1);
	} elsif ( substr($text,0,1) eq "\"" and
			 substr($text,-1,1) eq "\"") {
		$text= substr($text,1,-1);
	} elsif (substr($text,0,1) eq "\\") {
		$text= substr($text,1);
	}
	return $text;
}

sub remove_backslash {
	my $text= shift;

	$text=~ s/\\t/\t/g;
	$text=~ s/\\n/\n/g;
	$text=~ s/\\r/\r/g;
	$text=~ s/\\f/\f/g;
	$text=~ s/\\b/\b/g;
	$text=~ s/\\a/\a/g;
	$text=~ s/\\e/\e/g;
	$text=~ s/\\(0[0-7][0-7])/chr(oct($1))/ge;
	$text=~ s/\\(x[0-9a-fA-F][0-9a-fA-F])/chr(oct($1))/ge;
	$text=~ s/\\(.)/$1/g;
	return $text;
}

sub ungroup {
	my $text= shift;
	if (substr($text,0,1) eq '(' and
	    substr($text,-1,1) eq ')') {
		return substr($text,1,-1);
	} elsif (substr($text,0,1) eq '{' and
			substr($text,-1,1) eq '}') {
		return substr($text,1,-1);
	}
	return $text;
}

sub parse_fileno {
	my $tmp= shift;
	my $default1= shift;
	my $default2= shift;

	my @tmp= split('=', $tmp);   # [out=in] - not supported fully yet
	if (@tmp>2) {
		return undef;
	}
	if (@tmp<2) {
		push @tmp, $default2;
	}
	if (@tmp==2 && !$tmp[0]) {
		$tmp[0]= $default1;
	}
	my @result=();
	foreach (@tmp) {
		no strict 'refs';
		if (lc($_) eq 'all') {
			$_=1;
		}
		if (/^\d+$/) {
			push @result, $_+0;
		} else {
			if (ref *{"$Psh::PerlEval::current_package\:\:$_"}{FILEHANDLE}) {
				push @result, fileno(*{"$Psh::PerlEval::current_package\:\:$_"});
			}
		}
	}
	return @result;
}

sub make_tokens {
	my $line= shift;
	my $splitonly= shift;
	my @tmpparts= @{scalar(_decompose($line,$stdallinall, 0))};
	return @tmpparts if $splitonly;

	# Walk through parts and combine parenthesized parts properly
	my @parts=();
	my $nestlevel=0;
	my @tmp=();
	foreach (@tmpparts) {
		if (length($_)==1) {
			if ($_ eq '[' or $_ eq '(' or $_ eq '{') {
				$nestlevel++;
			} elsif ($_ eq '}' or $_ eq ')' or $_ eq ']') {
				$nestlevel--;
			}
		}
		if ($nestlevel) {
			push @tmp, $_;
		} elsif (@tmp) {
			push @parts,join('',@tmp,$_);
			@tmp=();
		} else {
			push @parts, $_;
		}
	}

	my @tokens= ();
	my @t=();
	my $tmp;
	while( defined($tmp= shift @parts)) {
		if ($tmp eq '||' or $tmp eq '&&') {
			push @t, @tokens;
			push @t, [T_END],[$tmp eq '||'?T_OR:T_AND];
			@tokens=();
		}
		elsif ($tmp eq ';;') {
			push @tokens, [T_WORD,';'];
		}
		elsif( $tmp eq '|') {
			my @fileno=(1,0);
			if (@parts>0) {
				my $tmp= shift @parts;
				if ($tmp=~/^\[(.+?)\]$/) {
					my $tmp2= $1;
					if (lc($tmp2) eq 'all') {
						push @tokens, [T_REDIRECT, '>&', 2, 1];
					}
					@fileno= parse_fileno($tmp2,1,0);
					if (!@fileno) {
						print STDERR "Illegal syntax\n"; ## FIXME
						return undef;
					}
				} else {
					unshift @parts, $tmp;
				}
			}
			push @t, [T_REDIRECT, '>&', $fileno[0], 'chainout']; # needs to come first
			push @t, @tokens;
			push @t, [T_PIPE];
			@tokens=( [T_REDIRECT, '<&', $fileno[1], 'chainin']);
		} elsif( $tmp =~ /^(>>?)$/) {
			my $tmp= $1;

			my $file;
			my @fileno=(1,0);
			my $allflag=0;
			if (@parts>0) {
				my $tmp= shift @parts;
				if ($tmp=~/^\[(.+?)\]$/) {
					my $tmp2= $1;
					if (lc($tmp2) eq 'all') {
						$allflag=1;
					}
					@fileno= parse_fileno($tmp2,1,0);
					if (!@fileno) {
						print STDERR "Illegal syntax\n"; ## FIXME
						return undef;
					}
				} else {
					unshift @parts, $tmp;
				}
			}
			if ($fileno[1]==0) {
				while( @parts>0) {
					$file= shift @parts;
					last if( $file !~ /^\s+$/);
						$file='';
				}
				if( !$file or substr($file,0,1) eq '&') {
					Psh::Util::print_error_i18n('redirect_file_missing',
												$tmp,$Psh::bin);
					return undef;
				}
				push @tokens, [T_REDIRECT,$tmp,$fileno[0],unquote($file)];
				} else {
					push @tokens, [T_REDIRECT, '>&', @fileno];
				}
			if ($allflag) {
				push @tokens, [T_REDIRECT, '>&', 2, 1];
			}
		} elsif( $tmp eq '<') {
			my $file;
			my @fileno=(0,0);
			if (@parts>0) {
				my $tmp= shift @parts;
				if ($tmp=~/^\[(.+?)\]$/) {
					@fileno= parse_fileno($1,0,0);
					if (!@fileno) {
						print STDERR "Illegal syntax\n"; ## FIXME
						return undef;
					}
				}
				else {
					unshift @parts, $tmp;
				}
			}
			if ($fileno[0]==0) {
				while( @parts>0) {
					$file= shift @parts;
					last if( $file !~ /^\s+$/);
					$file='';
				}
				if( !$file or substr($file,0,1) eq '&') {
					Psh::Util::print_error_i18n('redirect_file_missing',
												$tmp,$Psh::bin);
					return undef;
				}
				push @tokens, [T_REDIRECT,'<',$fileno[1],unquote($file)];
			} else {
				push @tokens, [T_REDIRECT,'<&',$fileno[1],$fileno[0]];
			}
		} elsif( $tmp eq '&') {
			push @t, @tokens;
			push @t, [T_BACKGROUND],[T_END];
			@tokens=();
		} elsif( $tmp eq ';') {
			push @t, @tokens;
			push @t, [T_END];
			@tokens= ();
		} elsif ($tmp eq '`') {
			my $tmp='';
			while ( (my $tmp2= shift @parts) ne '`' ) {
				$tmp.=' '.$tmp2;
			}
			$tmp= Psh::OS::backtick($tmp);
			$tmp=~ s/\\/\\\\/g;
			$tmp=~ s/\"/\\\"/g;
			$tmp=~ s/\n/\\n/g;
			$tmp=~ s/\$/\\\$/g;
			$tmp=~ s/\@/\\\@/g;
			push @tokens, [T_WORD, join('','"', $tmp,'"')];
		} elsif( $tmp=~ /^\s+$/) {
		} else {
			push @tokens, [T_WORD,$tmp];
		}
	}
    push @t, @tokens;
	return @t;
}

sub parse_line {
	my $line= shift;
	my (@use_strats) = @_;

	return () if substr($line,0,1) eq '#';

	my ($lvl1,$lvl2,$lvl3);
	if (@use_strats) {
		($lvl1,$lvl2,$lvl3)= Psh::Strategy::parser_return_objects(@use_strats);
	} elsif (@Psh::temp_use_strats) {
		($lvl1,$lvl2,$lvl3)= Psh::Strategy::parser_return_objects(@Psh::temp_use_strats);
	} else {
		($lvl1,$lvl2,$lvl3)= Psh::Strategy::parser_strategy_list();
	}

	if (@$lvl1) {
		foreach my $strategy (@$lvl1) {
			my $how= eval {
				$strategy->applies(\$line);
			};
			if ($@) {
				print STDERR $@;
			} elsif ($how) {
				my $name= $strategy->name;
				Psh::Util::print_debug_class('s',
											 "[Using strategy $name: $how]\n");
				return ([ T_EXECUTE, 1, [$strategy, $how, [], [$line], $line ]]);
			}
		}
	}
	if (@$lvl2) {
		die "Level 2 Strategies currently not supported!";
	}
	if (@$lvl3) {
		my @tokens= make_tokens( $line);
		my @elements=();
		my $element;
		while( @tokens > 0) {
			$element=parse_complex_command(\@tokens,$lvl3);
			return undef if ! defined( $element); # TODO: Error handling
			push @elements, $element;
			if (@tokens > 0) {
				if ($tokens[0][0] == T_END) {
					shift @tokens;
				}
				if (@tokens > 0) {
					if ($tokens[0][0] == T_AND) {
						shift @tokens;
						push @elements, [ T_AND ];
					} elsif ($tokens[0][0] == T_OR) {
						shift @tokens;
						push @elements, [ T_OR ];
					}
				}
			}
		}
		return @elements;
	}
}

sub parse_complex_command {
	my $tokens= shift;
	my $strategies= shift;
	my $piped= 0;
	my $foreground = 1;
	return [ T_EXECUTE, $foreground, _subparse_complex_command($tokens,$strategies,\$piped,\$foreground,{})];
}

sub _subparse_complex_command {
	my ($tokens,$use_strats,$piped,$foreground,$alias_disabled)=@_;
	my @simplecommands= parse_simple_command($tokens,$use_strats, $piped,$alias_disabled,$foreground);

	while (@$tokens > 0 && $tokens->[0][0] == T_PIPE) {
		shift @$tokens;
		$$piped= 1;
		push @simplecommands, parse_simple_command($tokens,$use_strats,$piped,$alias_disabled,$foreground);
	}

	if (@$tokens > 0 && $tokens->[0][0] == T_BACKGROUND) {
		shift @$tokens;
		$$foreground = 0;
	}
	return @simplecommands;
}

sub parse_simple_command {
	my ($tokens,$use_strats,$piped,$alias_disabled,$foreground)=@_;
	my (@words,@options,@savetokens,@precom);
	my $opt={};

	my $firstwords=1;
	while (@$tokens > 0 and
		   ($tokens->[0][0] == T_WORD or
			$tokens->[0][0] == T_REDIRECT)) {
		my $token = shift @$tokens;
		if ($token->[0] == T_WORD) {
			if ($firstwords and
			    ($token->[1] eq 'noglob' or
				 $token->[1] eq 'noexpand' or
				 $token->[1] eq 'noalias')) {
				push @precom, $token;
				$opt->{$token->[1]}=1;
			} else {
				$firstwords=0;
				push @savetokens,$token;
				push @words, $token->[1];
			}
		} elsif ($token->[0] == T_REDIRECT) {
			push @options, $token;
		} else {
		}
	}

	if (%Psh::Support::Alias::aliases and
		!$opt->{noalias} and
	    $Psh::Support::Alias::aliases{$words[0]} and
	    !$alias_disabled->{$words[0]}) {
		my $alias= $Psh::Support::Alias::aliases{$words[0]};
		$alias =~ s/\'/\\\'/g;
		$alias_disabled->{$words[0]}=1;
		my @tmp= make_tokens($alias);
		unshift @tmp, @precom;
		shift @savetokens;
		push @tmp, @savetokens;
		push @tmp, @options;
		return _subparse_complex_command(\@tmp,$use_strats,$piped,$foreground,$alias_disabled);
	} elsif (substr($words[0],0,1) eq "\\") {
		$words[0]=substr($words[0],1);
	}

	my $line= join ' ', @words;
	local $Psh::current_options= $opt;
	foreach my $strat (@$use_strats) {
		my $how= eval {
			$strat->applies(\$line,\@words,$$piped);
		};
		if ($@) {
			print STDERR $@;
		}
		elsif ($how) {
			my $name= $strat->name;
			Psh::Util::print_debug_class('s',
										 "[Using strategy $name: $how]\n");
			return [ $strat, $how, \@options, \@words, $line, $opt];
		}
	}
	Psh::Util::print_error_i18n('clueless',$line,$Psh::bin);
	die '';
}

# TODO: right now this is pretty much of a hack. Could it be improved?
#        For example, 'print hello \n' on the command line gets double
#        quotes around hello and \n, so that it ends up doing
#        print("hello","\n") which looks nice but is a surprise to
#        bash users. Perhaps backslash escapes simply shouldn't be OK?

sub needs_double_quotes
{
	my ($word) = @_;

	return if !defined($word) or !$word;

	if ($word =~ m/[a-zA-Z]/                     # if it has some letters
		and $word =~ m!^(\\.|[$.:a-zA-Z0-9/.])*$!) { # and only these characters
		return 1;                                # then double-quote it
	}

	return 0;
}




1;
__END__