Perl parsing code

Question

I've extracted a subroutine from some perl code I've written. (I also included the use enum line for easy reference.) Its purpose is to parse the given code, returning a string with an error message if the code is malformed. The purpose of the whole program is to check code for errors, so the 'normal' path where undef is returned is less interesting than the paths where errors are given.

The code passed to this sub is C-like with strings like "First line of string\nSecond line of string" and comments like /* block comment */ and \\ line comments use backslashes. The code comes from a priori untrusted sources and is run in taint mode. (I don't actually expect malicious code -- it's run strictly offline, and with code that has been human-checked -- but if you see any gaping security holes that would be worth pointing out.)

I have two main issues (and any number of subsidiary issues). First, should I be coding this directly or using a module? I looked at various parsing modules like Marpa::R2, Parse-RecDescent, Parse-Yapp, Parser-MGC, Regexp-Grammars, etc., but they all seemed cumbersome and more trouble than just coding a simple parser. Second, a lot of code is repeated here, and I'm not comfortable with that. For example, the four lines with Unbalanced parentheses, ) without matching ( are repeated three times, once for each of Normal, NormalSlash, and NormalBackslash.

Secondary goals include efficiency (each run of the program will require parsing 50,000 to 100,000 blocks of code) and using idiomatic perl code.

Apologies for the poor code formatting -- despite identifying the block as lang-perl it formats // as a comment. (lang-pl does the same.)

use enum qw(Normal NormalSlash NormalBackslash BlockComment BlockCommentStar LineComment String StringEscape);

sub parse {
    my $code = shift;
    my $level = 0; # Depth of nested parentheses
    my $status = Normal;
    for my $c (split //, $code) {
        if ($status == Normal) {
            if ($c eq '/') {
                $status = NormalSlash;
            } elsif ($c eq '\\') {
                $status = NormalBackslash;
            } elsif ($c eq '"') {
                $status = String;
            } elsif ($c eq '(') {
                $level++;
            } elsif ($c eq ')') {
                my $parens = $code;
                $parens =~ tr/()//cd;
                return "Unbalanced parentheses, ) without matching (, had $parens" if $level == 0;
                $level--;
            }
        } elsif ($status == NormalSlash) {
            if ($c eq '*') {
                $status = BlockComment;
            } elsif ($c eq '\\') {
                $status = NormalBackslash;
            } elsif ($c eq '"') {
                $status = String;
            } elsif ($c eq '(') {
                $level++;
                $status = Normal;
            } elsif ($c eq ')') {
                my $parens = $code;
                $parens =~ tr/()//cd;
                return "Unbalanced parentheses, ) without matching (, had $parens" if $level == 0;
                $level--;
                $status = Normal;
            } else {
                $status = Normal;
            }
        } elsif ($status == NormalBackslash) {
            if ($c eq '\\') {
                $status = LineComment;
            } elsif ($c eq '"') {
                $status = String;
            } elsif ($c eq '(') {
                $level++;
                $status = Normal;
            } elsif ($c eq ')') {
                my $parens = $code;
                $parens =~ tr/()//cd;
                return "Unbalanced parentheses, ) without matching (, had $parens" if $level == 0;
                $level--;
                $status = Normal;
            } else {
                $status = Normal;
            }
        } elsif ($status == BlockComment) {
            if ($c eq '*') {
                $status = BlockCommentStar;
            }
        } elsif ($status == BlockCommentStar) {
            if ($c eq '/') {
                $status = Normal;
            } elsif ($c ne '*') {
                $status = BlockComment;
            }
        } elsif ($status == LineComment) {
            if ($c eq '\n') {
                $status = Normal;
            }
        } elsif ($status == String) {
            if ($c eq '"') {
                $status = Normal;
            } elsif ($c eq '\\') {
                $status = StringEscape;
            }
        } elsif ($status == StringEscape) {
            $status = String;
        }
    }
    if ($level > 0) {
        my $parens = $code;
        $parens =~ tr/()//cd;
        return "Unbalanced parentheses, ( without matching ), had $parens";
    }
    return 'Trailing slash' if $status == NormalSlash;
    return 'Trailing backslash' if $status == NormalBackslash;
    return 'Block comment still open' if $status == BlockComment || $status == BlockCommentStar;
    return 'Unterminated string' if $status == String || $status == StringEscape;
    return undef if $status == Normal || $status == LineComment;
    return 'Bug, unknown status';
}

Answer 1

Really, your code is fine. Perl, like most languages, is not Forth and cannot have super-appropriate DSLs without runtime overhead.

With that said, you have a state machine, and you hold its state in a single subroutine's lexical variables. This limits your ability to break out factors from your code. You're faced with these choices:

1. Accept some redundancy, as you do above.
2. Pass state through the factors. Which isn't going to be pretty, but won't be as bad if you put all of your state into a hash and pass a hashref.
3. Change the scope of your variables so that they're shared with any factors. The traditional reasons to oppose this design don't apply to this situation, as you're not recursively calling parse() -- and don't apply to Perl, as any thread-shared state must be explicitly tagged as shared.
4. Put your state in an object and break your factors off into methods of the object. This is basically #2, but might be cleaner in practice.

If you want pretty code and are willing to accept the overhead, #3 is your best bet. As demonstrated:

use enum qw(Normal NormalSlash NormalBackslash BlockComment BlockCommentStar LineComment String StringEscape);
use Try::Tiny;

{
  my $state;
  my @code;
  my $level; # Depth of nested parentheses
  my $parens;

  sub on { $state == $_[0] }
  sub char {
    if (ref $_[0] eq 'Regexp') { return unless $_ =~ /$_[0]/ }
    else { return unless $_ eq $_[0] }

    if (ref $_[1] eq 'CODE') { $_[1]->() }
    else { $state = $_[1] }
  }

  sub unbalanced {
    die "Unbalanced parentheses, ) without matching (, had $parens\n"
      if $level == 0
  }
  sub closing { unbalanced; $level--; $state = Normal }

  sub raw_parse {
    ($parens = $_[0]) =~ tr/()//cd;
    @code = split //, shift;
    $level = 0; 
    $state = Normal;

    while ($_ = shift @code) {
      if (on Normal) {
        char '/', NormalSlash;
        char '\\', NormalBackslash;
        char '"', String;
        char '(', sub { $level++ };
        char ')', \&unbalanced;
      } elsif (on NormalSlash) {
        char '*', BlockComment;
        char '\\', NormalBackslash;
        char '"', String;
        char '(', sub { $level++; $state = Normal };
        char ')', \&closing;
        char qr/[^*\\"()]/, Normal;
      } elsif (on NormalBackslash) {
        char '\\', LineComment;
        char '"', String;
        char '(', sub { $level++; $state = Normal };
        char ')', \&closing;
        char qr/[^\\"()]/, Normal;
      } elsif (on BlockComment) {
        char '*', BlockCommentStar;
      } elsif (on BlockCommentStar) {
        char '/', Normal;
        char qr([^/*]), BlockComment;
      } elsif (on LineComment) {
        char "\n", Normal
      } elsif (on String) {
        char '"', Normal;
        char '\\', StringEscape;
      } elsif (on StringEscape) {
        $state = String
      } else { die "Bug, unknown state\n" }
    }

    die "Unbalanced parentheses, ( without matching ), had $parens\n" if $level > 0;
    die "Trailing slash\n" if on NormalSlash;
    die "Trailing backslash\n" if on NormalBackslash;
    die "Block comment still open\n" if on BlockComment || on BlockCommentStar;
    die "Unterminated string\n" if on String || on StringEscape;
    return if on Normal || on LineComment;
    die "Bug, unknown state\n";
  }

  sub parse {
    my $arg = shift;
    try { raw_parse($arg) }
    catch { chomp; return $_ };
  }
}

Alternately,

sub char {
  if (ref $_[0] eq 'Regexp') { return unless $_ =~ /$_[0]/ }
  else { return unless $_ eq $_[0] }    

  return 1 if @_ == 1;
  $state = $_[1]
}

Would allow code like:

char '"', String;
if (char '(') { $level++ }

This form of char would allow you to cleanly switch back to returning errors instead throwing them with die.