#!/usr/bin/perl -w
#
# Author: Gary Funck <gary@intrepid.com>
# Date: Jan. 27, 2004
#
# COPYRIGHT: Gary Funck, 2004.  This program is provided free of charge,
# and may be used (and modified) without license or grant.
#
# $Id: expand_regex.pl,v 1.4 2004/01/29 07:16:22 gary Exp gary $
#

use strict;
use Getopt::Long;
use vars qw($opt_v $opt_expand $opt_warn $opt_lint $opt_q);

my $verbose              = 0;
my $quiet                = 0;
my $expand_all           = 0;
my $expand_curly_braces  = 0;
my $expand_digits        = 0;
my $expand_dot           = 0;
my $expand_question_mark = 0;
my $expand_set           = 0;
my $warn_all             = 0;
my $warn_b               = 0;
my $warn_dot             = 0;
my $warn_q               = 0;
my $warn_p               = 0;
my $warn_star            = 0;

		 
GetOptions("v|verbose" => sub { $verbose = 1; $quiet = 0; },
           "q|quiet"   => sub { $quiet = 1; $verbose = 0; },
	   "lint"      => sub { $quiet = 1; $verbose = 0;
	                        process_warn_options("all"); },
           "expand=s"  => sub { process_expand_options ($_[1]); },
           "warn=s"    => sub { process_warn_options ($_[1]); },
	   "h|?|help"  => sub { usage() });
$verbose &&= !$quiet;
$quiet   &&= !$verbose;

my ($rule_type,$rule_name,$rule_pat);
my @c = ();
while (<>)
{
  chomp;
  next unless m<^(?:(uri|body|rawbody)\s+(\w+)\s+(/.*))>i
       || m<^(header)\s+(\w+)\s+\S+\s*(?:=~|!~)\s+(/.*)
            (?: \s*\[if-.*\]\s*)$>ix;
  print "$_\n" if ($verbose);
  $rule_type="$1"; $rule_name = "$2"; $rule_pat="$3";
  $_ = $rule_pat;
  print "---- expansion ----\n" if ($verbose);
  # Do the warnings before making any transformations.
  if ($warn_dot && /(?<!\\) \. (?! \{ | \? )/x)
  {
    print "Warning: bare '.' seen in rule $rule_name\n";
  }
  if ($warn_star && /(?<!\\) \* (?! \{ | \? )/x)
  {
    print "Warning: bare '\*' used instead of preferred" .
          " bounded .{0,n} notation in rule $rule_name\n";
  }
  if ($warn_q && /[[:alnum:]]\?/)
  {
    print "Warning: bare '?' follows letter or digit" .
	  " in rule $rule_name\n";
  }
  if ($warn_p && /(?<! \\ ) \( (?! \? :)/x )
  {
    print "Warning: bare '(' is not in preferred '(?:' form" .
          " in rule $rule_name.\n";
  }
  if ($warn_b && ! m{^/\\b.*/[smxi]*\s*$})
  {
    print "Warning: pattern does not begin and end with '\\b'" .
          " in rule $rule_name.\n";
  }
  # clean up the regex
  s=^/==;
  s'[smxi]*\s*$'';
  s=/$==;
  s'\\b''g;
  # change the '(?:' form into '(' for readability.
  s'\(\?:'('g;
  # Now expand the selected patterns
  if ($expand_question_mark
      && /(?<!  \\ | (?<! \\) \( ) \? (?! \?)/x )
  {
    $_ = rewrite_previous_regex($_, '?');
  }
  if ($expand_digits)
  {
    # rewrite \d into (0|1...|9)
    s/\\d/'(' . join('|',('0'..'9')) . ')'/gex;
  }
  if ($expand_dot && /(?<!\\)\./)
  {
    # rewrite . into (a|b|..z|0|1..|9)
    s/(?<!\\)\./'(' . join('|',('a'..'z','0'..'9')) . ')'/gex;
  }
  if ($expand_set)
  {
    # rewrite [ABC] into equiv. (A|B|C)
    s<\[([^\]]+)]><my $chars = join('',('a'..'z','A'..'Z',
                                        '0'..'9','._-@'));
		   my $pat = "[^$1]";
		   $chars =~ s/$pat//g; # get the chars matched
		   '(' . join('|',split(//,$chars)) . ')'>gex;
  }
  if ($expand_curly_braces && /(?<!\\)\{/)
  {
    # rewrite <regex>{min,max} into equivalent (<regex><regex>(|<regex)) form
    $_ = rewrite_previous_regex($_, '{');
  }
  # Perform the expansion.
  @c = split('');
  my $ri = 0;
  my @result = expand_pat([''], \$ri);
  if (!$quiet)
  {
    for (@result)
    {
      # Remove some back slashes for readability.
      s<\\([[:punct:]])><$1>g;
      print "$_\n";
    }
  }
  print "---------------------\n" if ($verbose);
}

sub expand_pat
{
  my ($so_far, $ix) = @_;
  my @this_part = ();
  my @alt_part = ('');
  my @result = ();
  my $s = '';
  for (my $i = ${$ix}; $i < @c; )
  {
    my $prevc = defined ($c[$i-1]) ? $c[$i-1] : '';
    my $ch    = $c[$i++];
    if ($ch eq '(' && $prevc ne '\\')
    {
      @alt_part = map { $_ .= $s } @alt_part;
      @alt_part = expand_pat (\@alt_part, \$i);
      $s = '';
    }
    elsif ($ch eq ')' && $prevc ne '\\')
    {
      @alt_part = map { $_ .= $s } @alt_part;
      push @this_part, @alt_part;
      ${$ix} = $i;
      @result = map {my $this_s = $_;
                        map { $this_s . $_; } @this_part } @{$so_far};
      return @result;
    }
    elsif ($ch eq '|' && $prevc ne '\\')
    {
      @alt_part = map { $_ .= $s } @alt_part;
      push @this_part, @alt_part;
      @alt_part = ('');
      $s = '';
    }
    else
    {
      # Remove leading '\', if this is an escaped '(' or ')' or '|'
      $s =~ s/.$// if ($ch =~ /[(|)]/);
      $s .= $ch;
    }
  }
  @alt_part = map { $_ .= $s } @alt_part;
  push @this_part, @alt_part;
  @result = map {my $this_s = $_;
		    map { $this_s . $_; } @this_part } @{$so_far};
  return @result;
}

sub rewrite_previous_regex
{
  my $regex       = $_[0];
  my $expand_spec = $_[1];
  # early exit, if called with a spec. we can't handle
  return $regex unless ($expand_spec eq '?' || $expand_spec eq '{');
  my @rx = split('',$regex);
  for (my $i = 0; $i < @rx; ++$i)
  {
    my $ppch   = defined($rx[$i-2]) ? $rx[$i-2] : '';
    my $pch    = defined($rx[$i-1]) ? $rx[$i-1] : '';
    my $ch     = $rx[$i];
    my $nch    = defined($rx[$i+1]) ? $rx[$i+1] : '';
    if (($expand_spec eq '?' && $ch eq '?'
          && ($pch ne '\\' && $nch ne '?')
	  && !($pch eq '(' && $ppch ne '\\'))
        || ($expand_spec eq '{' && $ch eq '{' && $pch ne '\\'))
    {
      my $rlast   = ($i - 1);
      my $rfirst  = $rlast;
      my $rlen;
      if (($pch eq ')' || $pch eq ']') && $ppch ne '\\')
      {
         my $bracket_level = 1;
	 my $bracket = $pch;
         my $matching_bracket = ($pch eq ')') ? '(' : '[';
         do
	 {
	   --$rfirst;
	   ++$bracket_level if (($rx[$rfirst] eq $bracket)
	                         && (!$rfirst || ($rx[$rfirst-1] ne '\\')));
	   --$bracket_level if (($rx[$rfirst] eq $matching_bracket)
	                         && (!$rfirst || ($rx[$rfirst-1] ne '\\')));
	 } until (!($rfirst && $bracket_level));
      }
      else
      {
        # accommodate \d, etc.
        $rfirst-- if ($ppch eq '\\');
      }
      # preceding regex is in $rx[$rfirst..$rlast]
      if ($expand_spec eq '?')
      {
	# Convert <regex>? into (|<regex>)
        $rlen = $i - $rfirst + 1;
	splice @rx, $rfirst, $rlen, ('(','|',@rx[$rfirst..$rlast], ')');
	# We added three chars, and deleted one (the '?').
	# Adjust the current scan index accordingly.
	$i += 2;
      }
      elsif ($expand_spec eq '{')
      {
	do {
	  ++$i;
	} until ($i >= @rx || $rx[$i] eq '}');
	my $rpt_factor = join('',@rx[($rlast+2)..($i-1)]);
	my ($lo,$hi) = split(/\s*,\s*/,$rpt_factor);
	$lo ||=   0;  # lo defaults to  0 if not present
	$hi ||= $lo;  # hi defaults to lo
	# initialize repeated 're' part with initial number of reps.
	my @re_unit = @rx[$rfirst..$rlast];
	my @rpt_re  = ((@re_unit) x $lo);
	my @re = ('(', @rpt_re);
        for (($lo+1)..$hi)
	{
	  push @rpt_re, @re_unit;
	  push @re, ('|', @rpt_re);
	}
	push @re, ')';
	# rewrite <regex>{lo,hi} into repeated increasing
	# alternative sequences of <regex>.
        $rlen = $i - $rfirst + 1;
	splice @rx, $rfirst, $rlen, @re;
	# advance scan pointer to account for rewrite
	$i += scalar(@re) - $rlen;
      }
    }
  }
  my $result = join('',@rx);
  return $result;
}

sub process_expand_options
{
  my $opts = $_[0];
  $expand_all             = (lc $opts eq 'all');
  $expand_curly_braces  ||= ($opts =~ /\{/) || $expand_all;
  $expand_digits        ||= ($opts =~ /d/)  || $expand_all;
  $expand_question_mark ||= ($opts =~ /\?/) || $expand_all;
  $expand_dot           ||= ($opts =~ /\./) || $expand_all;
  $expand_set           ||= ($opts =~ /\[/) || $expand_all;
}

sub process_warn_options
{
  my $opts = $_[0];
  $warn_all   = (lc $opts eq 'all');
  $warn_dot  ||= ($opts =~ /\./) || $warn_all;
  $warn_q    ||= ($opts =~ /\?/) || $warn_all;
  $warn_p    ||= ($opts =~ /\(/) || $warn_all;
  $warn_star ||= ($opts =~ /\*/) || $warn_all;
  # -warn=b isn't for everyone; leave it out of 'all'.
  $warn_b    ||= ($opts =~ /b/);
}

sub usage
{
print <<EOF_HELP ;
usage: expand_regex [-help] [-v] [-q] [-lint] 
       [-expand=\<expand_options>\] [-warn=\<warn_options>\]
        -v      (verbose) prints rule name and other info
        -q      (quiet) disables output of expanded rules
        -lint   lint mode (equivalent to '-q -warn=all')
        <expand_options> is one or more of:
        d       digits (ie, \\d)
        ?       question mark (ie, zero or one occurrence)
        .       dot (ie, any single character)
                (note: any single character is equivalent to [a-z0-9])
        {       curly braces (ie, {n,n})
        [       sets (ie, [])
        all     all of the above
        <warn_options> is one or more of:
        .       warn about unescaped '.'s
        ?       warn about '?'s following alphanumeric characters
        (       warn about '('s not written in preferred '(:?' style
	*       warn about '*'s used instead of bounded .{0,n} notation
        b       warn about patterns that don't begin and end with \\b
        all     all of the above (except 'b')
EOF_HELP
exit 1;
}
