Commit | Line | Data |
---|---|---|
86530b38 AT |
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 |