| # Copyright (c) 2021-2022 Eric Sunshine <sunshine@sunshineco.com> | |
| # | |
| # Shared shell script parser for test lint tools. Provides Lexer, | |
| # ShellParser, and ScriptParser. Subclass ScriptParser and override | |
| # check_test() to implement lint checks. | |
| use strict; | |
| use warnings; | |
| # Lexer tokenizes POSIX shell scripts. It is roughly modeled after section 2.3 | |
| # "Token Recognition" of POSIX chapter 2 "Shell Command Language". Although | |
| # similar to lexical analyzers for other languages, this one differs in a few | |
| # substantial ways due to quirks of the shell command language. | |
| # | |
| # For instance, in many languages, newline is just whitespace like space or | |
| # TAB, but in shell a newline is a command separator, thus a distinct lexical | |
| # token. A newline is significant and returned as a distinct token even at the | |
| # end of a shell comment. | |
| # | |
| # In other languages, `1+2` would typically be scanned as three tokens | |
| # (`1`, `+`, and `2`), but in shell it is a single token. However, the similar | |
| # `1 + 2`, which embeds whitepaces, is scanned as three token in shell, as well. | |
| # In shell, several characters with special meaning lose that meaning when not | |
| # surrounded by whitespace. For instance, the negation operator `!` is special | |
| # when standing alone surrounded by whitespace; whereas in `foo!uucp` it is | |
| # just a plain character in the longer token "foo!uucp". In many other | |
| # languages, `"string"/foo:'string'` might be scanned as five tokens ("string", | |
| # `/`, `foo`, `:`, and 'string'), but in shell, it is just a single token. | |
| # | |
| # The lexical analyzer for the shell command language is also somewhat unusual | |
| # in that it recursively invokes the parser to handle the body of `$(...)` | |
| # expressions which can contain arbitrary shell code. Such expressions may be | |
| # encountered both inside and outside of double-quoted strings. | |
| # | |
| # The lexical analyzer is responsible for consuming shell here-doc bodies which | |
| # extend from the line following a `<<TAG` operator until a line consisting | |
| # solely of `TAG`. Here-doc consumption begins when a newline is encountered. | |
| # It is legal for multiple here-doc `<<TAG` operators to be present on a single | |
| # line, in which case their bodies must be present one following the next, and | |
| # are consumed in the (left-to-right) order the `<<TAG` operators appear on the | |
| # line. A special complication is that the bodies of all here-docs must be | |
| # consumed when the newline is encountered even if the parse context depth has | |
| # changed. For instance, in `cat <<A && x=$(cat <<B &&\n`, bodies of here-docs | |
| # "A" and "B" must be consumed even though "A" was introduced outside the | |
| # recursive parse context in which "B" was introduced and in which the newline | |
| # is encountered. | |
| package Lexer; | |
| sub new { | |
| my ($class, $parser, $s) = @_; | |
| bless { | |
| parser => $parser, | |
| buff => $s, | |
| lineno => 1, | |
| heretags => [] | |
| } => $class; | |
| } | |
| sub scan_heredoc_tag { | |
| my $self = shift @_; | |
| ${$self->{buff}} =~ /\G(-?)/gc; | |
| my $indented = $1; | |
| my $token = $self->scan_token(); | |
| return "<<$indented" unless $token; | |
| my $tag = $token->[0]; | |
| $tag =~ s/['"\\]//g; | |
| $$token[0] = $indented ? "\t$tag" : "$tag"; | |
| push(@{$self->{heretags}}, $token); | |
| return "<<$indented$tag"; | |
| } | |
| sub scan_op { | |
| my ($self, $c) = @_; | |
| my $b = $self->{buff}; | |
| return $c unless $$b =~ /\G(.)/sgc; | |
| my $cc = $c . $1; | |
| return scan_heredoc_tag($self) if $cc eq '<<'; | |
| return $cc if $cc =~ /^(?:&&|\|\||>>|;;|<&|>&|<>|>\|)$/; | |
| pos($$b)--; | |
| return $c; | |
| } | |
| sub scan_sqstring { | |
| my $self = shift @_; | |
| ${$self->{buff}} =~ /\G([^']*'|.*\z)/sgc; | |
| my $s = $1; | |
| $self->{lineno} += () = $s =~ /\n/sg; | |
| return "'" . $s; | |
| } | |
| sub scan_dqstring { | |
| my $self = shift @_; | |
| my $b = $self->{buff}; | |
| my $s = '"'; | |
| while (1) { | |
| # Slurp non-special characters; count newlines here because | |
| # newlines inside $() are already counted by the recursive parse. | |
| if ($$b =~ /\G([^"\$\\]+)/gc) { | |
| $s .= $1; | |
| $self->{lineno} += $1 =~ tr/\n//; | |
| } | |
| # handle special characters | |
| last unless $$b =~ /\G(.)/sgc; | |
| my $c = $1; | |
| $s .= '"', last if $c eq '"'; | |
| $s .= '$' . $self->scan_dollar(), next if $c eq '$'; | |
| if ($c eq '\\') { | |
| $s .= '\\', last unless $$b =~ /\G(.)/sgc; | |
| $c = $1; | |
| $self->{lineno}++, next if $c eq "\n"; # line splice | |
| # backslash escapes only $, `, ", \ in dq-string | |
| $s .= '\\' unless $c =~ /^[\$`"\\]$/; | |
| $s .= $c; | |
| next; | |
| } | |
| die("internal error scanning dq-string '$c'\n"); | |
| } | |
| return $s; | |
| } | |
| sub scan_balanced { | |
| my ($self, $c1, $c2) = @_; | |
| my $b = $self->{buff}; | |
| my $depth = 1; | |
| my $s = $c1; | |
| while ($$b =~ /\G([^\Q$c1$c2\E]*(?:[\Q$c1$c2\E]|\z))/gc) { | |
| $s .= $1; | |
| $depth++, next if $s =~ /\Q$c1\E$/; | |
| $depth--; | |
| last if $depth == 0; | |
| } | |
| $self->{lineno} += () = $s =~ /\n/sg; | |
| return $s; | |
| } | |
| sub scan_subst { | |
| my $self = shift @_; | |
| my @tokens = $self->{parser}->parse(qr/^\)$/); | |
| $self->{parser}->next_token(); # closing ")" | |
| return @tokens; | |
| } | |
| sub scan_dollar { | |
| my $self = shift @_; | |
| my $b = $self->{buff}; | |
| return $self->scan_balanced('(', ')') if $$b =~ /\G\((?=\()/gc; # $((...)) | |
| return '(' . join(' ', map {$_->[0]} $self->scan_subst()) . ')' if $$b =~ /\G\(/gc; # $(...) | |
| return $self->scan_balanced('{', '}') if $$b =~ /\G\{/gc; # ${...} | |
| return $1 if $$b =~ /\G(\w+)/gc; # $var | |
| return $1 if $$b =~ /\G([@*#?$!0-9-])/gc; # $*, $1, $$, etc. | |
| return ''; | |
| } | |
| sub swallow_heredocs { | |
| my $self = shift @_; | |
| my $b = $self->{buff}; | |
| my $tags = $self->{heretags}; | |
| while (my $tag = shift @$tags) { | |
| my $start = pos($$b); | |
| my $indent = $$tag[0] =~ s/^\t// ? '\\s*' : ''; | |
| $$b =~ /(?:\G|\n)$indent\Q$$tag[0]\E(?:\n|\z)/gc; | |
| if (pos($$b) > $start) { | |
| my $body = substr($$b, $start, pos($$b) - $start); | |
| $self->{parser}->{heredocs}->{$$tag[0]} = { | |
| content => substr($body, 0, length($body) - length($&)), | |
| start_line => $self->{lineno}, | |
| }; | |
| $self->{lineno} += () = $body =~ /\n/sg; | |
| next; | |
| } | |
| push(@{$self->{parser}->{problems}}, ['HEREDOC', $tag]); | |
| $$b =~ /(?:\G|\n).*\z/gc; # consume rest of input | |
| my $body = substr($$b, $start, pos($$b) - $start); | |
| $self->{lineno} += () = $body =~ /\n/sg; | |
| last; | |
| } | |
| } | |
| sub scan_token { | |
| my $self = shift @_; | |
| my $b = $self->{buff}; | |
| my $token = ''; | |
| my ($start, $startln); | |
| RESTART: | |
| $startln = $self->{lineno}; | |
| $$b =~ /\G[ \t]+/gc; # skip whitespace (but not newline) | |
| $start = pos($$b) || 0; | |
| $self->{lineno}++, return ["\n", $start, pos($$b), $startln, $startln] if $$b =~ /\G#[^\n]*(?:\n|\z)/gc; # comment | |
| while (1) { | |
| # slurp up non-special characters | |
| $token .= $1 if $$b =~ /\G([^\\;&|<>(){}'"\$\s]+)/gc; | |
| # handle special characters | |
| last unless $$b =~ /\G(.)/sgc; | |
| my $c = $1; | |
| pos($$b)--, last if $c =~ /^[ \t]$/; # whitespace ends token | |
| pos($$b)--, last if length($token) && $c =~ /^[;&|<>(){}\n]$/; | |
| $token .= $self->scan_sqstring(), next if $c eq "'"; | |
| $token .= $self->scan_dqstring(), next if $c eq '"'; | |
| $token .= $c . $self->scan_dollar(), next if $c eq '$'; | |
| $self->{lineno}++, $self->swallow_heredocs(), $token = $c, last if $c eq "\n"; | |
| $token = $self->scan_op($c), last if $c =~ /^[;&|<>]$/; | |
| $token = $c, last if $c =~ /^[(){}]$/; | |
| if ($c eq '\\') { | |
| $token .= '\\', last unless $$b =~ /\G(.)/sgc; | |
| $c = $1; | |
| $self->{lineno}++, next if $c eq "\n" && length($token); # line splice | |
| $self->{lineno}++, goto RESTART if $c eq "\n"; # line splice | |
| $token .= '\\' . $c; | |
| next; | |
| } | |
| die("internal error scanning character '$c'\n"); | |
| } | |
| return length($token) ? [$token, $start, pos($$b), $startln, $self->{lineno}] : undef; | |
| } | |
| # ShellParser parses POSIX shell scripts (with minor extensions for Bash). It | |
| # is a recursive descent parser very roughly modeled after section 2.10 "Shell | |
| # Grammar" of POSIX chapter 2 "Shell Command Language". | |
| package ShellParser; | |
| sub new { | |
| my ($class, $s) = @_; | |
| my $self = bless { | |
| buff => [], | |
| stop => [], | |
| output => [], | |
| heredocs => {}, | |
| insubshell => 0, | |
| } => $class; | |
| $self->{lexer} = Lexer->new($self, $s); | |
| return $self; | |
| } | |
| sub next_token { | |
| my $self = shift @_; | |
| return pop(@{$self->{buff}}) if @{$self->{buff}}; | |
| return $self->{lexer}->scan_token(); | |
| } | |
| sub untoken { | |
| my $self = shift @_; | |
| push(@{$self->{buff}}, @_); | |
| } | |
| sub peek { | |
| my $self = shift @_; | |
| my $token = $self->next_token(); | |
| return undef unless defined($token); | |
| $self->untoken($token); | |
| return $token; | |
| } | |
| sub stop_at { | |
| my ($self, $token) = @_; | |
| return 1 unless defined($token); | |
| my $stop = ${$self->{stop}}[-1] if @{$self->{stop}}; | |
| return defined($stop) && $token->[0] =~ $stop; | |
| } | |
| sub expect { | |
| my ($self, $expect) = @_; | |
| my $token = $self->next_token(); | |
| return $token if defined($token) && $token->[0] eq $expect; | |
| push(@{$self->{output}}, "?!ERR?! expected '$expect' but found '" . (defined($token) ? $token->[0] : "<end-of-input>") . "'\n"); | |
| $self->untoken($token) if defined($token); | |
| return (); | |
| } | |
| sub optional_newlines { | |
| my $self = shift @_; | |
| my @tokens; | |
| while (my $token = $self->peek()) { | |
| last unless $token->[0] eq "\n"; | |
| push(@tokens, $self->next_token()); | |
| } | |
| return @tokens; | |
| } | |
| sub parse_group { | |
| my $self = shift @_; | |
| return ($self->parse(qr/^}$/), | |
| $self->expect('}')); | |
| } | |
| sub parse_subshell { | |
| my $self = shift @_; | |
| $self->{insubshell}++; | |
| my @tokens = ($self->parse(qr/^\)$/), | |
| $self->expect(')')); | |
| $self->{insubshell}--; | |
| return @tokens; | |
| } | |
| sub parse_case_pattern { | |
| my $self = shift @_; | |
| my @tokens; | |
| while (defined(my $token = $self->next_token())) { | |
| push(@tokens, $token); | |
| last if $token->[0] eq ')'; | |
| } | |
| return @tokens; | |
| } | |
| sub parse_case { | |
| my $self = shift @_; | |
| my @tokens; | |
| push(@tokens, | |
| $self->next_token(), # subject | |
| $self->optional_newlines(), | |
| $self->expect('in'), | |
| $self->optional_newlines()); | |
| while (1) { | |
| my $token = $self->peek(); | |
| last unless defined($token) && $token->[0] ne 'esac'; | |
| push(@tokens, | |
| $self->parse_case_pattern(), | |
| $self->optional_newlines(), | |
| $self->parse(qr/^(?:;;|esac)$/)); # item body | |
| $token = $self->peek(); | |
| last unless defined($token) && $token->[0] ne 'esac'; | |
| push(@tokens, | |
| $self->expect(';;'), | |
| $self->optional_newlines()); | |
| } | |
| push(@tokens, $self->expect('esac')); | |
| return @tokens; | |
| } | |
| sub parse_for { | |
| my $self = shift @_; | |
| my @tokens; | |
| push(@tokens, | |
| $self->next_token(), # variable | |
| $self->optional_newlines()); | |
| my $token = $self->peek(); | |
| if (defined($token) && $token->[0] eq 'in') { | |
| push(@tokens, | |
| $self->expect('in'), | |
| $self->optional_newlines()); | |
| } | |
| push(@tokens, | |
| $self->parse(qr/^do$/), # items | |
| $self->expect('do'), | |
| $self->optional_newlines(), | |
| $self->parse_loop_body(), | |
| $self->expect('done')); | |
| return @tokens; | |
| } | |
| sub parse_if { | |
| my $self = shift @_; | |
| my @tokens; | |
| while (1) { | |
| push(@tokens, | |
| $self->parse(qr/^then$/), # if/elif condition | |
| $self->expect('then'), | |
| $self->optional_newlines(), | |
| $self->parse(qr/^(?:elif|else|fi)$/)); # if/elif body | |
| my $token = $self->peek(); | |
| last unless defined($token) && $token->[0] eq 'elif'; | |
| push(@tokens, $self->expect('elif')); | |
| } | |
| my $token = $self->peek(); | |
| if (defined($token) && $token->[0] eq 'else') { | |
| push(@tokens, | |
| $self->expect('else'), | |
| $self->optional_newlines(), | |
| $self->parse(qr/^fi$/)); # else body | |
| } | |
| push(@tokens, $self->expect('fi')); | |
| return @tokens; | |
| } | |
| sub parse_loop_body { | |
| my $self = shift @_; | |
| return $self->parse(qr/^done$/); | |
| } | |
| sub parse_loop { | |
| my $self = shift @_; | |
| return ($self->parse(qr/^do$/), # condition | |
| $self->expect('do'), | |
| $self->optional_newlines(), | |
| $self->parse_loop_body(), | |
| $self->expect('done')); | |
| } | |
| sub parse_func { | |
| my $self = shift @_; | |
| return ($self->expect('('), | |
| $self->expect(')'), | |
| $self->optional_newlines(), | |
| $self->parse_cmd()); # body | |
| } | |
| sub parse_bash_array_assignment { | |
| my $self = shift @_; | |
| my @tokens = $self->expect('('); | |
| while (defined(my $token = $self->next_token())) { | |
| push(@tokens, $token); | |
| last if $token->[0] eq ')'; | |
| } | |
| return @tokens; | |
| } | |
| my %compound = ( | |
| '{' => \&parse_group, | |
| '(' => \&parse_subshell, | |
| 'case' => \&parse_case, | |
| 'for' => \&parse_for, | |
| 'if' => \&parse_if, | |
| 'until' => \&parse_loop, | |
| 'while' => \&parse_loop); | |
| sub parse_cmd { | |
| my $self = shift @_; | |
| my $cmd = $self->next_token(); | |
| return () unless defined($cmd); | |
| return $cmd if $cmd->[0] eq "\n"; | |
| my $token; | |
| my @tokens = $cmd; | |
| if ($cmd->[0] eq '!') { | |
| push(@tokens, $self->parse_cmd()); | |
| return @tokens; | |
| } elsif (my $f = $compound{$cmd->[0]}) { | |
| push(@tokens, $self->$f()); | |
| } elsif (defined($token = $self->peek()) && $token->[0] eq '(') { | |
| if ($cmd->[0] !~ /\w=$/) { | |
| push(@tokens, $self->parse_func()); | |
| return @tokens; | |
| } | |
| my @array = $self->parse_bash_array_assignment(); | |
| $tokens[-1]->[0] .= join(' ', map {$_->[0]} @array); | |
| $tokens[-1]->[2] = $array[$#array][2] if @array; | |
| } | |
| while (defined(my $token = $self->next_token())) { | |
| $self->untoken($token), last if $self->stop_at($token); | |
| push(@tokens, $token); | |
| last if $token->[0] =~ /^(?:[;&\n|]|&&|\|\|)$/; | |
| } | |
| push(@tokens, $self->next_token()) if $tokens[-1]->[0] ne "\n" && defined($token = $self->peek()) && $token->[0] eq "\n"; | |
| return @tokens; | |
| } | |
| sub accumulate { | |
| my ($self, $tokens, $cmd) = @_; | |
| push(@$tokens, @$cmd); | |
| } | |
| sub parse { | |
| my ($self, $stop) = @_; | |
| push(@{$self->{stop}}, $stop); | |
| goto DONE if $self->stop_at($self->peek()); | |
| my @tokens; | |
| while (my @cmd = $self->parse_cmd()) { | |
| $self->accumulate(\@tokens, \@cmd); | |
| last if $self->stop_at($self->peek()); | |
| } | |
| DONE: | |
| pop(@{$self->{stop}}); | |
| return @tokens; | |
| } | |
| # ScriptParser is a subclass of ShellParser which identifies individual test | |
| # definitions within test scripts and passes each test body to check_test(). | |
| # ScriptParser detects test definitions not only at the top-level of test | |
| # scripts but also within compound commands such as loops and function | |
| # definitions. | |
| package ScriptParser; | |
| our @ISA = ('ShellParser'); | |
| sub new { | |
| my $class = shift @_; | |
| my $self = $class->SUPER::new(@_); | |
| $self->{ntests} = 0; | |
| $self->{nerrs} = 0; | |
| return $self; | |
| } | |
| # extract the raw content of a token, which may be a single string or a | |
| # composition of multiple strings and non-string character runs; for instance, | |
| # `"test body"` unwraps to `test body`; `word"a b"42'c d'` to `worda b42c d` | |
| sub unwrap { | |
| my $token = (@_ ? shift @_ : $_)->[0]; | |
| # simple case: 'sqstring' or "dqstring" | |
| return $token if $token =~ s/^'([^']*)'$/$1/; | |
| return $token if $token =~ s/^"([^"]*)"$/$1/; | |
| # composite case | |
| my ($s, $q, $escaped); | |
| while (1) { | |
| # slurp up non-special characters | |
| $s .= $1 if $token =~ /\G([^\\'"]*)/gc; | |
| # handle special characters | |
| last unless $token =~ /\G(.)/sgc; | |
| my $c = $1; | |
| $q = undef, next if defined($q) && $c eq $q; | |
| $q = $c, next if !defined($q) && $c =~ /^['"]$/; | |
| if ($c eq '\\') { | |
| last unless $token =~ /\G(.)/sgc; | |
| $c = $1; | |
| $s .= '\\' if $c eq "\n"; # preserve line splice | |
| } | |
| $s .= $c; | |
| } | |
| return $s | |
| } | |
| sub check_test { | |
| # no-op; subclass and override to implement lint checks | |
| } | |
| sub parse_cmd { | |
| my $self = shift @_; | |
| my @tokens = $self->SUPER::parse_cmd(); | |
| return @tokens unless @tokens && $tokens[0]->[0] =~ /^test_expect_(?:success|failure)$/; | |
| my $n = $#tokens; | |
| $n-- while $n >= 0 && $tokens[$n]->[0] =~ /^(?:[;&\n|]|&&|\|\|)$/; | |
| my $herebody; | |
| if ($n >= 2 && $tokens[$n-1]->[0] eq '-' && $tokens[$n]->[0] =~ /^<<-?(.+)$/) { | |
| $herebody = $self->{heredocs}->{$1}; | |
| $n--; | |
| } | |
| $self->check_test($tokens[1], $tokens[2], $herebody) if $n == 2; # title body | |
| $self->check_test($tokens[2], $tokens[3], $herebody) if $n > 2; # prereq title body | |
| return @tokens; | |
| } | |
| 1; |