| 1 | #! /usr/local/bin/perl -w |
| 2 | package Psh::Parser; |
| 3 | |
| 4 | use strict; |
| 5 | |
| 6 | require Psh::OS; |
| 7 | require Psh::Util; |
| 8 | require Psh::Strategy; |
| 9 | |
| 10 | sub T_END() { 0; } |
| 11 | sub T_WORD() { 1; } |
| 12 | sub T_PIPE() { 2; } |
| 13 | sub T_REDIRECT() { 3; } |
| 14 | sub T_BACKGROUND() { 4; } |
| 15 | sub T_OR() { 5; } |
| 16 | sub T_AND() { 6; } |
| 17 | |
| 18 | sub T_EXECUTE() { 1; } |
| 19 | |
| 20 | # ugly, ugly, but makes things faster |
| 21 | |
| 22 | my %quotehash = qw|' ' " " q( ) qw( ) qq( ) ` `|; |
| 23 | my %quotedquotes = (); |
| 24 | my $def_quoteexp; |
| 25 | my $def_tokenizer= '(\\s+|\\|\\||\\&\\&|\||=>|->|;;|;|\\&|>>|>|<<|<|\\(|\\)|\\{|\\}|\\[|\\])'; |
| 26 | my $nevermatches = "(?!a)a"; |
| 27 | |
| 28 | |
| 29 | $def_quoteexp = $nevermatches; |
| 30 | foreach my $opener (keys %quotehash) { |
| 31 | $def_quoteexp .= '|' . quotemeta($opener); |
| 32 | $quotedquotes{$opener} = quotemeta($quotehash{$opener}); |
| 33 | } |
| 34 | |
| 35 | my $stdallinall= "^((?:[^\\\\]|\\\\.)*?)(?:$def_tokenizer|($def_quoteexp))(.*)\$"; |
| 36 | |
| 37 | if ($]>=5.005) { |
| 38 | eval { |
| 39 | $stdallinall= qr{$stdallinall}s; |
| 40 | }; |
| 41 | } |
| 42 | |
| 43 | sub decompose { |
| 44 | my ($delimexp,$line,$num,$keep,$unmatched) = @_; |
| 45 | my @matches; |
| 46 | |
| 47 | if (!defined($delimexp)) { $delimexp = $def_tokenizer; } |
| 48 | elsif ($delimexp eq ' ') { $delimexp='(\s+)'; } |
| 49 | |
| 50 | if (!defined($num)) { $num = -1; } |
| 51 | if (!defined($keep)) { $keep = 1; } |
| 52 | |
| 53 | # Remember if delimexp came with any parenthesized subexpr, and |
| 54 | # arrange for it to have exactly one so we know what each piece in |
| 55 | # the match below means: |
| 56 | |
| 57 | my $saveDelimiters = 0; |
| 58 | @matches = ('x' =~ m/$delimexp|(.)/); |
| 59 | if (@matches > 2) { |
| 60 | require Carp; |
| 61 | Carp::carp("Delimiter regexp '$delimexp' in decompose may " . |
| 62 | "contain at most 1 ()."); |
| 63 | return undef; |
| 64 | } |
| 65 | if (@matches == 2) { |
| 66 | $saveDelimiters = 1; |
| 67 | } else { |
| 68 | $delimexp = "($delimexp)"; |
| 69 | } |
| 70 | |
| 71 | return _decompose($line, "^((?:[^\\\\]|\\\\.)*?)(?:$delimexp|($def_quoteexp))(.*)\$", $keep, $num, $unmatched, $saveDelimiters-1); |
| 72 | } |
| 73 | |
| 74 | sub _decompose |
| 75 | { |
| 76 | my ( $line, $regexp, $keep, $num, $unmatched, $saveDelimiters)= @_; |
| 77 | |
| 78 | $saveDelimiters++; |
| 79 | my @pieces = (''); |
| 80 | my $startNewPiece = 0; |
| 81 | my $freshPiece = 1; |
| 82 | my $uquote = 0; |
| 83 | while ($line) { |
| 84 | if ($startNewPiece) { |
| 85 | push @pieces, ''; |
| 86 | $startNewPiece = 0; |
| 87 | $freshPiece = 1; |
| 88 | } |
| 89 | if (@pieces == $num) { last; } |
| 90 | |
| 91 | # $delimexp is unparenthesized below because we have |
| 92 | # already arranged for it to contain exactly one backref () |
| 93 | my ($prefix,$delimiter,$quote,$rest) = |
| 94 | ($line =~ m/$regexp/s); |
| 95 | if (!$keep and defined($prefix)) { |
| 96 | $prefix= remove_backslash($prefix); |
| 97 | } |
| 98 | if (defined($delimiter)) { |
| 99 | $pieces[$#pieces] .= $prefix; |
| 100 | if ($saveDelimiters) { |
| 101 | if (length($pieces[$#pieces]) or !$freshPiece) { |
| 102 | push @pieces, $delimiter; |
| 103 | } else { |
| 104 | $pieces[$#pieces] = $delimiter; |
| 105 | } |
| 106 | $startNewPiece = 1; |
| 107 | } elsif (@pieces > 1 or $pieces[0]) { |
| 108 | $startNewPiece = 1; |
| 109 | } |
| 110 | $line = $rest; |
| 111 | } elsif (defined($quote)) { |
| 112 | my ($restOfQuote,$remainder) = |
| 113 | ($rest =~ m/^((?:[^\\]|\\.)*?)$quotedquotes{$quote}(.*)$/s); |
| 114 | if (defined($restOfQuote)) { |
| 115 | if (!$keep and |
| 116 | $quote ne "\'" and $quote ne 'q(') { |
| 117 | $restOfQuote= remove_backslash($restOfQuote); |
| 118 | } |
| 119 | $pieces[$#pieces]= join('',$pieces[$#pieces],$prefix, |
| 120 | $quote,$restOfQuote, |
| 121 | $quotehash{$quote}); |
| 122 | $line = $remainder; |
| 123 | $freshPiece = 0; |
| 124 | } else { # can't find matching quote, give up |
| 125 | $uquote = 1; |
| 126 | last; |
| 127 | } |
| 128 | } else { # nothing found, so remainder all one unquoted piece |
| 129 | if (!$keep and length($line)) { |
| 130 | $line= remove_backslash($line); |
| 131 | } |
| 132 | last; |
| 133 | } |
| 134 | } |
| 135 | if (length($line)) { $pieces[$#pieces] .= $line; } |
| 136 | if (defined($unmatched)) { ${$unmatched} = $uquote; } |
| 137 | return wantarray?@pieces:\@pieces; |
| 138 | } |
| 139 | |
| 140 | sub incomplete_expr |
| 141 | { |
| 142 | my ($line) = @_; |
| 143 | return 0 unless $line=~/[\[{('"]/s; |
| 144 | |
| 145 | my $unmatch = 0; |
| 146 | my @words= @{scalar(_decompose($line,$stdallinall, 1, undef, \$unmatch))}; |
| 147 | if ($unmatch) { return 2; } |
| 148 | |
| 149 | my @openstack = (':'); # : is used as a bottom marker here |
| 150 | my %open_of_close = qw|) ( } { ] [ " '|; |
| 151 | |
| 152 | foreach my $word (@words) { |
| 153 | next if length($word)!=1; |
| 154 | if ($word eq '[' or $word eq '{' or $word eq '(' or $word eq '"' or |
| 155 | $word eq "\"") { |
| 156 | push @openstack, $word; |
| 157 | } elsif ($word eq ')' or $word eq '}' or $word eq ']' or $word eq '"' or |
| 158 | $word eq "\"") { |
| 159 | my $open= $open_of_close{$word}; |
| 160 | my $curopen = pop @openstack; |
| 161 | if ($open ne $curopen) { |
| 162 | return -1; |
| 163 | } |
| 164 | } |
| 165 | } |
| 166 | if (scalar(@openstack) > 1) { return 1; } |
| 167 | return 0; |
| 168 | } |
| 169 | |
| 170 | # |
| 171 | # glob_expansion() |
| 172 | # |
| 173 | # LINE EXPANSIONS: |
| 174 | # |
| 175 | # If we're going to be a shell, let's act like a shell. The idea here |
| 176 | # is to provide expansion functions that individual evaluation |
| 177 | # strategies can use on the argument list to perform operations |
| 178 | # similar to the ones a shell argument list undergoes. Each of these |
| 179 | # functions should take a reference to an array of "words" and return |
| 180 | # a solid (to be conservative, as opposed to modifying in place) array of |
| 181 | # "expanded words". |
| 182 | # |
| 183 | # Bash defines eight types of expansion in its manpage: brace |
| 184 | # expansion, tilde expansion, parameter and variable expansion, |
| 185 | # command substitution, arithmetic expansion, word splitting, |
| 186 | # pathname expansion, and process expansion. |
| 187 | # |
| 188 | # Of these, arithmetic expansion makes no sense in Perl. Word |
| 189 | # splitting should happen "on the fly", i.e., the array returned by |
| 190 | # one of these functions might have more elements than the argument |
| 191 | # did. Since the perl builtin "glob" handles brace, tilde and pathname |
| 192 | # expansion, here's a glob_expansion function that covers all of |
| 193 | # those. Also a variable_expansion function that handles substituting |
| 194 | # in the values of Perl variables. That leaves only: |
| 195 | # |
| 196 | # TODO: command_expansion (i.e., backticks. For this, |
| 197 | # backticks would have to be added to decompose as a recognized quote |
| 198 | # character), process_expansion |
| 199 | # |
| 200 | # TODO: should some of these line-processing actions happen in a |
| 201 | # uniform way, or should things simply be left to each evaluation strategy |
| 202 | # as psh currently works? |
| 203 | # |
| 204 | # array glob_expansion (arrayref WORDS) |
| 205 | # |
| 206 | # For each element x of the array referred to by WORDS, such that x |
| 207 | # is not quoted, push glob(x) onto an array, and return the collected array. |
| 208 | # |
| 209 | |
| 210 | sub glob_expansion |
| 211 | { |
| 212 | my $arref= shift; |
| 213 | my $join_char= shift; |
| 214 | my @retval = (); |
| 215 | |
| 216 | for my $word (@{$arref}) { |
| 217 | if ($word =~ m/['"']/ # if it contains quotes |
| 218 | or ($word !~ m/{.*}|\[.*\]|[*?~]/)) { # or no globbing characters |
| 219 | push @retval, $word; # don't try to glob it |
| 220 | } else { |
| 221 | # Glob it. If anything happens, quote the |
| 222 | # results so they won't be clobbbered later. |
| 223 | my @results = Psh::OS::glob($word); |
| 224 | if (scalar(@results) == 0) { |
| 225 | @results = ($word); |
| 226 | } elsif (scalar(@results)>1 or $results[0] ne $word) { |
| 227 | foreach (@results) { $_ = "'$_'"; } |
| 228 | } |
| 229 | if( $join_char) { |
| 230 | push @retval, join($join_char, @results); |
| 231 | } else { |
| 232 | push @retval, @results; |
| 233 | } |
| 234 | } |
| 235 | } |
| 236 | |
| 237 | return @retval; |
| 238 | } |
| 239 | |
| 240 | sub unquote { |
| 241 | my $text= shift; |
| 242 | |
| 243 | if (substr($text,0,1) eq '\'' and |
| 244 | substr($text,-1,1) eq '\'') { |
| 245 | $text= substr($text,1,-1); |
| 246 | } elsif ( substr($text,0,1) eq "\"" and |
| 247 | substr($text,-1,1) eq "\"") { |
| 248 | $text= substr($text,1,-1); |
| 249 | } elsif (substr($text,0,1) eq "\\") { |
| 250 | $text= substr($text,1); |
| 251 | } |
| 252 | return $text; |
| 253 | } |
| 254 | |
| 255 | sub remove_backslash { |
| 256 | my $text= shift; |
| 257 | |
| 258 | $text=~ s/\\t/\t/g; |
| 259 | $text=~ s/\\n/\n/g; |
| 260 | $text=~ s/\\r/\r/g; |
| 261 | $text=~ s/\\f/\f/g; |
| 262 | $text=~ s/\\b/\b/g; |
| 263 | $text=~ s/\\a/\a/g; |
| 264 | $text=~ s/\\e/\e/g; |
| 265 | $text=~ s/\\(0[0-7][0-7])/chr(oct($1))/ge; |
| 266 | $text=~ s/\\(x[0-9a-fA-F][0-9a-fA-F])/chr(oct($1))/ge; |
| 267 | $text=~ s/\\(.)/$1/g; |
| 268 | return $text; |
| 269 | } |
| 270 | |
| 271 | sub ungroup { |
| 272 | my $text= shift; |
| 273 | if (substr($text,0,1) eq '(' and |
| 274 | substr($text,-1,1) eq ')') { |
| 275 | return substr($text,1,-1); |
| 276 | } elsif (substr($text,0,1) eq '{' and |
| 277 | substr($text,-1,1) eq '}') { |
| 278 | return substr($text,1,-1); |
| 279 | } |
| 280 | return $text; |
| 281 | } |
| 282 | |
| 283 | sub parse_fileno { |
| 284 | my $tmp= shift; |
| 285 | my $default1= shift; |
| 286 | my $default2= shift; |
| 287 | |
| 288 | my @tmp= split('=', $tmp); # [out=in] - not supported fully yet |
| 289 | if (@tmp>2) { |
| 290 | return undef; |
| 291 | } |
| 292 | if (@tmp<2) { |
| 293 | push @tmp, $default2; |
| 294 | } |
| 295 | if (@tmp==2 && !$tmp[0]) { |
| 296 | $tmp[0]= $default1; |
| 297 | } |
| 298 | my @result=(); |
| 299 | foreach (@tmp) { |
| 300 | no strict 'refs'; |
| 301 | if (lc($_) eq 'all') { |
| 302 | $_=1; |
| 303 | } |
| 304 | if (/^\d+$/) { |
| 305 | push @result, $_+0; |
| 306 | } else { |
| 307 | if (ref *{"$Psh::PerlEval::current_package\:\:$_"}{FILEHANDLE}) { |
| 308 | push @result, fileno(*{"$Psh::PerlEval::current_package\:\:$_"}); |
| 309 | } |
| 310 | } |
| 311 | } |
| 312 | return @result; |
| 313 | } |
| 314 | |
| 315 | sub make_tokens { |
| 316 | my $line= shift; |
| 317 | my $splitonly= shift; |
| 318 | my @tmpparts= @{scalar(_decompose($line,$stdallinall, 0))}; |
| 319 | return @tmpparts if $splitonly; |
| 320 | |
| 321 | # Walk through parts and combine parenthesized parts properly |
| 322 | my @parts=(); |
| 323 | my $nestlevel=0; |
| 324 | my @tmp=(); |
| 325 | foreach (@tmpparts) { |
| 326 | if (length($_)==1) { |
| 327 | if ($_ eq '[' or $_ eq '(' or $_ eq '{') { |
| 328 | $nestlevel++; |
| 329 | } elsif ($_ eq '}' or $_ eq ')' or $_ eq ']') { |
| 330 | $nestlevel--; |
| 331 | } |
| 332 | } |
| 333 | if ($nestlevel) { |
| 334 | push @tmp, $_; |
| 335 | } elsif (@tmp) { |
| 336 | push @parts,join('',@tmp,$_); |
| 337 | @tmp=(); |
| 338 | } else { |
| 339 | push @parts, $_; |
| 340 | } |
| 341 | } |
| 342 | |
| 343 | my @tokens= (); |
| 344 | my @t=(); |
| 345 | my $tmp; |
| 346 | while( defined($tmp= shift @parts)) { |
| 347 | if ($tmp eq '||' or $tmp eq '&&') { |
| 348 | push @t, @tokens; |
| 349 | push @t, [T_END],[$tmp eq '||'?T_OR:T_AND]; |
| 350 | @tokens=(); |
| 351 | } |
| 352 | elsif ($tmp eq ';;') { |
| 353 | push @tokens, [T_WORD,';']; |
| 354 | } |
| 355 | elsif( $tmp eq '|') { |
| 356 | my @fileno=(1,0); |
| 357 | if (@parts>0) { |
| 358 | my $tmp= shift @parts; |
| 359 | if ($tmp=~/^\[(.+?)\]$/) { |
| 360 | my $tmp2= $1; |
| 361 | if (lc($tmp2) eq 'all') { |
| 362 | push @tokens, [T_REDIRECT, '>&', 2, 1]; |
| 363 | } |
| 364 | @fileno= parse_fileno($tmp2,1,0); |
| 365 | if (!@fileno) { |
| 366 | print STDERR "Illegal syntax\n"; ## FIXME |
| 367 | return undef; |
| 368 | } |
| 369 | } else { |
| 370 | unshift @parts, $tmp; |
| 371 | } |
| 372 | } |
| 373 | push @t, [T_REDIRECT, '>&', $fileno[0], 'chainout']; # needs to come first |
| 374 | push @t, @tokens; |
| 375 | push @t, [T_PIPE]; |
| 376 | @tokens=( [T_REDIRECT, '<&', $fileno[1], 'chainin']); |
| 377 | } elsif( $tmp =~ /^(>>?)$/) { |
| 378 | my $tmp= $1; |
| 379 | |
| 380 | my $file; |
| 381 | my @fileno=(1,0); |
| 382 | my $allflag=0; |
| 383 | if (@parts>0) { |
| 384 | my $tmp= shift @parts; |
| 385 | if ($tmp=~/^\[(.+?)\]$/) { |
| 386 | my $tmp2= $1; |
| 387 | if (lc($tmp2) eq 'all') { |
| 388 | $allflag=1; |
| 389 | } |
| 390 | @fileno= parse_fileno($tmp2,1,0); |
| 391 | if (!@fileno) { |
| 392 | print STDERR "Illegal syntax\n"; ## FIXME |
| 393 | return undef; |
| 394 | } |
| 395 | } else { |
| 396 | unshift @parts, $tmp; |
| 397 | } |
| 398 | } |
| 399 | if ($fileno[1]==0) { |
| 400 | while( @parts>0) { |
| 401 | $file= shift @parts; |
| 402 | last if( $file !~ /^\s+$/); |
| 403 | $file=''; |
| 404 | } |
| 405 | if( !$file or substr($file,0,1) eq '&') { |
| 406 | Psh::Util::print_error_i18n('redirect_file_missing', |
| 407 | $tmp,$Psh::bin); |
| 408 | return undef; |
| 409 | } |
| 410 | push @tokens, [T_REDIRECT,$tmp,$fileno[0],unquote($file)]; |
| 411 | } else { |
| 412 | push @tokens, [T_REDIRECT, '>&', @fileno]; |
| 413 | } |
| 414 | if ($allflag) { |
| 415 | push @tokens, [T_REDIRECT, '>&', 2, 1]; |
| 416 | } |
| 417 | } elsif( $tmp eq '<') { |
| 418 | my $file; |
| 419 | my @fileno=(0,0); |
| 420 | if (@parts>0) { |
| 421 | my $tmp= shift @parts; |
| 422 | if ($tmp=~/^\[(.+?)\]$/) { |
| 423 | @fileno= parse_fileno($1,0,0); |
| 424 | if (!@fileno) { |
| 425 | print STDERR "Illegal syntax\n"; ## FIXME |
| 426 | return undef; |
| 427 | } |
| 428 | } |
| 429 | else { |
| 430 | unshift @parts, $tmp; |
| 431 | } |
| 432 | } |
| 433 | if ($fileno[0]==0) { |
| 434 | while( @parts>0) { |
| 435 | $file= shift @parts; |
| 436 | last if( $file !~ /^\s+$/); |
| 437 | $file=''; |
| 438 | } |
| 439 | if( !$file or substr($file,0,1) eq '&') { |
| 440 | Psh::Util::print_error_i18n('redirect_file_missing', |
| 441 | $tmp,$Psh::bin); |
| 442 | return undef; |
| 443 | } |
| 444 | push @tokens, [T_REDIRECT,'<',$fileno[1],unquote($file)]; |
| 445 | } else { |
| 446 | push @tokens, [T_REDIRECT,'<&',$fileno[1],$fileno[0]]; |
| 447 | } |
| 448 | } elsif( $tmp eq '&') { |
| 449 | push @t, @tokens; |
| 450 | push @t, [T_BACKGROUND],[T_END]; |
| 451 | @tokens=(); |
| 452 | } elsif( $tmp eq ';') { |
| 453 | push @t, @tokens; |
| 454 | push @t, [T_END]; |
| 455 | @tokens= (); |
| 456 | } elsif ($tmp eq '`') { |
| 457 | my $tmp=''; |
| 458 | while ( (my $tmp2= shift @parts) ne '`' ) { |
| 459 | $tmp.=' '.$tmp2; |
| 460 | } |
| 461 | $tmp= Psh::OS::backtick($tmp); |
| 462 | $tmp=~ s/\\/\\\\/g; |
| 463 | $tmp=~ s/\"/\\\"/g; |
| 464 | $tmp=~ s/\n/\\n/g; |
| 465 | $tmp=~ s/\$/\\\$/g; |
| 466 | $tmp=~ s/\@/\\\@/g; |
| 467 | push @tokens, [T_WORD, join('','"', $tmp,'"')]; |
| 468 | } elsif( $tmp=~ /^\s+$/) { |
| 469 | } else { |
| 470 | push @tokens, [T_WORD,$tmp]; |
| 471 | } |
| 472 | } |
| 473 | push @t, @tokens; |
| 474 | return @t; |
| 475 | } |
| 476 | |
| 477 | sub parse_line { |
| 478 | my $line= shift; |
| 479 | my (@use_strats) = @_; |
| 480 | |
| 481 | return () if substr($line,0,1) eq '#'; |
| 482 | |
| 483 | my ($lvl1,$lvl2,$lvl3); |
| 484 | if (@use_strats) { |
| 485 | ($lvl1,$lvl2,$lvl3)= Psh::Strategy::parser_return_objects(@use_strats); |
| 486 | } elsif (@Psh::temp_use_strats) { |
| 487 | ($lvl1,$lvl2,$lvl3)= Psh::Strategy::parser_return_objects(@Psh::temp_use_strats); |
| 488 | } else { |
| 489 | ($lvl1,$lvl2,$lvl3)= Psh::Strategy::parser_strategy_list(); |
| 490 | } |
| 491 | |
| 492 | if (@$lvl1) { |
| 493 | foreach my $strategy (@$lvl1) { |
| 494 | my $how= eval { |
| 495 | $strategy->applies(\$line); |
| 496 | }; |
| 497 | if ($@) { |
| 498 | print STDERR $@; |
| 499 | } elsif ($how) { |
| 500 | my $name= $strategy->name; |
| 501 | Psh::Util::print_debug_class('s', |
| 502 | "[Using strategy $name: $how]\n"); |
| 503 | return ([ T_EXECUTE, 1, [$strategy, $how, [], [$line], $line ]]); |
| 504 | } |
| 505 | } |
| 506 | } |
| 507 | if (@$lvl2) { |
| 508 | die "Level 2 Strategies currently not supported!"; |
| 509 | } |
| 510 | if (@$lvl3) { |
| 511 | my @tokens= make_tokens( $line); |
| 512 | my @elements=(); |
| 513 | my $element; |
| 514 | while( @tokens > 0) { |
| 515 | $element=parse_complex_command(\@tokens,$lvl3); |
| 516 | return undef if ! defined( $element); # TODO: Error handling |
| 517 | push @elements, $element; |
| 518 | if (@tokens > 0) { |
| 519 | if ($tokens[0][0] == T_END) { |
| 520 | shift @tokens; |
| 521 | } |
| 522 | if (@tokens > 0) { |
| 523 | if ($tokens[0][0] == T_AND) { |
| 524 | shift @tokens; |
| 525 | push @elements, [ T_AND ]; |
| 526 | } elsif ($tokens[0][0] == T_OR) { |
| 527 | shift @tokens; |
| 528 | push @elements, [ T_OR ]; |
| 529 | } |
| 530 | } |
| 531 | } |
| 532 | } |
| 533 | return @elements; |
| 534 | } |
| 535 | } |
| 536 | |
| 537 | sub parse_complex_command { |
| 538 | my $tokens= shift; |
| 539 | my $strategies= shift; |
| 540 | my $piped= 0; |
| 541 | my $foreground = 1; |
| 542 | return [ T_EXECUTE, $foreground, _subparse_complex_command($tokens,$strategies,\$piped,\$foreground,{})]; |
| 543 | } |
| 544 | |
| 545 | sub _subparse_complex_command { |
| 546 | my ($tokens,$use_strats,$piped,$foreground,$alias_disabled)=@_; |
| 547 | my @simplecommands= parse_simple_command($tokens,$use_strats, $piped,$alias_disabled,$foreground); |
| 548 | |
| 549 | while (@$tokens > 0 && $tokens->[0][0] == T_PIPE) { |
| 550 | shift @$tokens; |
| 551 | $$piped= 1; |
| 552 | push @simplecommands, parse_simple_command($tokens,$use_strats,$piped,$alias_disabled,$foreground); |
| 553 | } |
| 554 | |
| 555 | if (@$tokens > 0 && $tokens->[0][0] == T_BACKGROUND) { |
| 556 | shift @$tokens; |
| 557 | $$foreground = 0; |
| 558 | } |
| 559 | return @simplecommands; |
| 560 | } |
| 561 | |
| 562 | sub parse_simple_command { |
| 563 | my ($tokens,$use_strats,$piped,$alias_disabled,$foreground)=@_; |
| 564 | my (@words,@options,@savetokens,@precom); |
| 565 | my $opt={}; |
| 566 | |
| 567 | my $firstwords=1; |
| 568 | while (@$tokens > 0 and |
| 569 | ($tokens->[0][0] == T_WORD or |
| 570 | $tokens->[0][0] == T_REDIRECT)) { |
| 571 | my $token = shift @$tokens; |
| 572 | if ($token->[0] == T_WORD) { |
| 573 | if ($firstwords and |
| 574 | ($token->[1] eq 'noglob' or |
| 575 | $token->[1] eq 'noexpand' or |
| 576 | $token->[1] eq 'noalias')) { |
| 577 | push @precom, $token; |
| 578 | $opt->{$token->[1]}=1; |
| 579 | } else { |
| 580 | $firstwords=0; |
| 581 | push @savetokens,$token; |
| 582 | push @words, $token->[1]; |
| 583 | } |
| 584 | } elsif ($token->[0] == T_REDIRECT) { |
| 585 | push @options, $token; |
| 586 | } else { |
| 587 | } |
| 588 | } |
| 589 | |
| 590 | if (%Psh::Support::Alias::aliases and |
| 591 | !$opt->{noalias} and |
| 592 | $Psh::Support::Alias::aliases{$words[0]} and |
| 593 | !$alias_disabled->{$words[0]}) { |
| 594 | my $alias= $Psh::Support::Alias::aliases{$words[0]}; |
| 595 | $alias =~ s/\'/\\\'/g; |
| 596 | $alias_disabled->{$words[0]}=1; |
| 597 | my @tmp= make_tokens($alias); |
| 598 | unshift @tmp, @precom; |
| 599 | shift @savetokens; |
| 600 | push @tmp, @savetokens; |
| 601 | push @tmp, @options; |
| 602 | return _subparse_complex_command(\@tmp,$use_strats,$piped,$foreground,$alias_disabled); |
| 603 | } elsif (substr($words[0],0,1) eq "\\") { |
| 604 | $words[0]=substr($words[0],1); |
| 605 | } |
| 606 | |
| 607 | my $line= join ' ', @words; |
| 608 | local $Psh::current_options= $opt; |
| 609 | foreach my $strat (@$use_strats) { |
| 610 | my $how= eval { |
| 611 | $strat->applies(\$line,\@words,$$piped); |
| 612 | }; |
| 613 | if ($@) { |
| 614 | print STDERR $@; |
| 615 | } |
| 616 | elsif ($how) { |
| 617 | my $name= $strat->name; |
| 618 | Psh::Util::print_debug_class('s', |
| 619 | "[Using strategy $name: $how]\n"); |
| 620 | return [ $strat, $how, \@options, \@words, $line, $opt]; |
| 621 | } |
| 622 | } |
| 623 | Psh::Util::print_error_i18n('clueless',$line,$Psh::bin); |
| 624 | die ''; |
| 625 | } |
| 626 | |
| 627 | # TODO: right now this is pretty much of a hack. Could it be improved? |
| 628 | # For example, 'print hello \n' on the command line gets double |
| 629 | # quotes around hello and \n, so that it ends up doing |
| 630 | # print("hello","\n") which looks nice but is a surprise to |
| 631 | # bash users. Perhaps backslash escapes simply shouldn't be OK? |
| 632 | |
| 633 | sub needs_double_quotes |
| 634 | { |
| 635 | my ($word) = @_; |
| 636 | |
| 637 | return if !defined($word) or !$word; |
| 638 | |
| 639 | if ($word =~ m/[a-zA-Z]/ # if it has some letters |
| 640 | and $word =~ m!^(\\.|[$.:a-zA-Z0-9/.])*$!) { # and only these characters |
| 641 | return 1; # then double-quote it |
| 642 | } |
| 643 | |
| 644 | return 0; |
| 645 | } |
| 646 | |
| 647 | |
| 648 | |
| 649 | |
| 650 | 1; |
| 651 | __END__ |
| 652 | |
| 653 | =head1 NAME |
| 654 | |
| 655 | Psh::Parser - Perl Shell Parser |
| 656 | |
| 657 | =head1 SYNOPSIS |
| 658 | |
| 659 | use Psh::Parser; |
| 660 | |
| 661 | =head1 DESCRIPTION |
| 662 | |
| 663 | =over 4 |
| 664 | |
| 665 | =item * |
| 666 | |
| 667 | array decompose(regexp DELIMITER, string LINE, int PIECES, |
| 668 | bool KEEP, hashref QUOTINGPAIRS, |
| 669 | scalarref UNMATCHED_QUOTE) |
| 670 | |
| 671 | decompose is a cross between split() and |
| 672 | Text::ParseWords::parse_line: it breaks LINE into at most PIECES |
| 673 | pieces separated by DELIMITER, except that the hash given by the |
| 674 | reference QUOTINGPAIRS specifies pairs of quotes (each key is an |
| 675 | open quote which matches the corresponding value) which prevent |
| 676 | splitting on internal instances of DELIMITER, and negate the effect |
| 677 | of other quotes. The quoting characters are retained if KEEP is |
| 678 | true, discarded otherwise. Matches to the regexp METACHARACTERS |
| 679 | (outside quotes) are their own words, regardless of being delimited. |
| 680 | Backslashes escape the meanings of characters that might match |
| 681 | delimiters, quotes, or metacharacters. Initial unquoted empty |
| 682 | pieces are suppressed. |
| 683 | |
| 684 | The regexp DELIMITER may contain a single back-reference parenthesis |
| 685 | construct, in which case the matches to the parenthesized |
| 686 | subexpression are also placed among the pieces, as with the |
| 687 | built-in split. METACHARACTERS may not contain any parenthesized |
| 688 | subexpression. |
| 689 | |
| 690 | decompose returns the array of pieces. If UNMATCHED_QUOTE is |
| 691 | specified, 1 will be placed in the scalar referred to if LINE |
| 692 | contained an unmatched quote, 0 otherwise. |
| 693 | |
| 694 | If PIECES is undefined, as many pieces as |
| 695 | necessary are used. KEEP defaults to 1. If QUOTINGPAIRS is |
| 696 | undefined, {"'" => "'", "\"" => "\""} is used, i.e. single and |
| 697 | double quotes are recognized. Supply a reference to an empty hash to |
| 698 | have no quoting characters. METACHARACTERS defaults to a regexp that |
| 699 | never matches. |
| 700 | |
| 701 | EXAMPLE: if $line is exactly |
| 702 | |
| 703 | echo fred(joe, "Happy Days", ' steve"jan ', "\"Oh, no!\"") |
| 704 | |
| 705 | then decompose(' ', $line) should break it at the |
| 706 | following places marked by vertical bars: |
| 707 | |
| 708 | echo|fred(joe,|"Happy Days",|' steve"jan',|"\"Oh, no!\"") |
| 709 | |
| 710 | =item * |
| 711 | |
| 712 | int incomplete_expr(string LINE) |
| 713 | |
| 714 | Returns 2 if LINE has unmatched quotations. Returns -1 if LINE has |
| 715 | mismatched parens. Otherwise, returns 1 if LINE has an unmatched |
| 716 | open brace, parenthesis, or square bracket and 0 in all other |
| 717 | cases. Summing up, negative is a mismatch, 0 is all OK, and positive |
| 718 | is unfinished business. (Reasonably good, can be fooled with some |
| 719 | effort. I therefore have deliberately not taken comments into |
| 720 | account, which means you can use them to "unfool" this function, but |
| 721 | also that unmatched stuff in comments WILL fool this function.) |
| 722 | |
| 723 | =item * |
| 724 | |
| 725 | string unquote( string word) |
| 726 | |
| 727 | Removes quotes from a word and backslash escapes |
| 728 | |
| 729 | =item * |
| 730 | |
| 731 | bool needs_double_quotes (string WORD) |
| 732 | |
| 733 | Returns true if WORD needs double quotes around it to be interpreted |
| 734 | in a "shell-like" manner when passed to eval. This covers barewords, |
| 735 | expressions that just have \-escapes and $variables in them, and |
| 736 | filenames. |
| 737 | |
| 738 | =back |
| 739 | |
| 740 | =head1 AUTHOR |
| 741 | |
| 742 | Various |
| 743 | |
| 744 | =cut |