#!/usr/bin/perl

# Writen by Peter N Lewis <peter@stairways.com.au>
# Copyright 2002 Peter N Lewis
# This code is placed in the Public Domain.
#     This code may be used, modified, or copied freely without restriction
#
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.

$source = <<'EOM';
if $message_age < 300 then 1 else 0
EOM
#Result: ${if <{$message_age}{300}{1}{0}}

$source = <<'EOM';
if    !def('sender_host_address')  then 0 else 1
EOM
#Result: ${if !def:sender_host_address{0}{1}}

$source = <<'EOM';
if    $header('X-Stairways-Local') eq 'yes'  then 0 else 1
EOM
#Result: ${if eq{$header_X-Stairways-Local:}{yes}{0}{1}}

$source = <<'EOM';
if (($message_age < 300) & (exists('/var/lock/MASTER'))) |
(!defheader('X-delayed') & !(exists('/var/lock/MASTER'))) then 1 else 0
EOM
#Result: ${if or {{and {{<{$message_age}{300}}{exists{/var/lock/MASTER}}}}{and {{!def:header_X-delayed:}{!exists{/var/lock/MASTER}}}}}{1}{0}}

$source = <<'EOM';
if    !def('sender_host_address') 
     | ($sender_host_address eq "127.0.0.1") 
     | ($lc($header('X-Stairways-Local')) eq 'yes') then 0 else 1
EOM
#Result: ${if or {{!def:sender_host_address}{eq{$sender_host_address}{127.0.0.1}}{eq{${lc:$header_X-Stairways-Local:}}{yes}}}{0}{1}}

$source = <<'EOM';
if   (($header('to') mch $local_part) | ($header('cc') mch $local_part))
   & !($sender_address eq '')
   & !($header('precedence') mch '(?i)bulk|list|junk')
   then 1 else 0
EOM
#Result: ${if and {{or {{match{$header_to:}{$local_part}}{match{$header_cc:}{$local_part}}}}{!eq{$sender_address}{}}{!match{$header_precedence:}{(?i)bulk|list|junk}}}{1}{0}}


$source = <<'EOM';
if   defheader('subject') & !($header('subject') mch '\N^\s*$\N') 
   then $quote($escape($length_50($header('subject'))))
   else 'I am on vacation'
EOM
# Need 'VACATION-RE: ' before quote, but I do not support that yet
#Result: ${if and {{def:header_subject:}{!match{$header_subject:}{\N^\s*$\N}}}{${quote:${escape:${length_50:$header_subject:}}}}{I am on vacation}}

$source = <<'EOM';
if   ($message_size > 80000)
   & ($spam_score_int > 50)
   then 1 else 0
EOM
#Result: ${if and {{>{$message_size}{80000}}{>{$spam_score_int}{50}}}{1}{0}}


$source =~ tr/\r\n/  /;


$sourcepos = 0;
$token = '';
GetNextToken();

print STDERR "\nCompile: $source\n";
$result = Compile();
print STDERR "Result: $result\n\n";

sub GetChar {
  my $result;
  if ( $sourcepos < length($source) ) {
    $result = substr( $source, $sourcepos, 1 );
  } else {
    $result = undef;
  }
  return $result;
}


sub GetNextToken {
  $sourcepos++ while ( GetChar() =~ /\s/ );
  
#  print STDERR "Sourcepos: $sourcepos\n";
  $_ = substr( $source, $sourcepos );
#  print STDERR "Examine: $_\n";
  if ($_
      && !s/^(mchlc|mch|eq|<=|<|>=|>|==|=|!=|\|\||&&|\||&|\(|\)|not\s|\!).*/$1/ 
      && !s/^(\$[\w]+).*/$1/
      && !s/^('[^']*').*/$1/
      && !s/^("[^"]*").*/$1/
      && !s/^(\d+[KM]?).*/$1/
      && !s/^(\w+).*/$1/
      ) {
    die "Unknown token at $_";
  }
#  print STDERR "Token2: $token\n";
  $sourcepos = $sourcepos + length($_);
  s/^\|\|$/|/;
  s/^&&$/&/;
  s/^==$/=/;
  s/^not\s$/!/;
  s/^eq$/=s=/;
  s/^mchlc$/=ml=/;
  s/^mch$/=m=/;
  if ( s/^"/'/ ) {
    s/"$/'/;
  }
  $token = $_;
  print STDERR "Token: $token\n";
  
  return $token;
}

sub Compile {
  
  my $result = Expr20();
  Expect( undef );
  return $result;
}

sub Expr20() {

  my $result;
  
  if ( $token eq 'if' ) {
    GetNextToken();
    my $cond = Cond40();
    Expect( 'then' );
    my $then = Expr20();
    my $else;
    if ( $token eq 'else' ) {
      Expect( 'else' );
      $else = Expr20();
    } else {
      undef $else;
    }
    $result = '${if '.$cond.'{'.$then.'}';
    $result .= '{'.$else.'}' if defined($else);
    $result .= '}';
  } else {
    $result = Ident();
  }
  print STDERR "Expr20 returns $result\n";
  return $result;
}

sub Cond40 {
  my $result;
  
  my $left = Cond50();
  if ( $token =~ /^(\||&)$/ ) {
    my $op = $token;
    if ( $token eq '|' ) {
      $result = 'or' 
    } else {
      $result = 'and' 
    }
    $result .= ' {{'.$left.'}';
    while ( $op eq $token ) {
      GetNextToken();
      my $right = Cond50();
       $result .= '{'.$right.'}';
    }
    $result .= '}';
  } else {
    $result = $left;
  }
  print STDERR "Cond40 returns $result\n";
  return $result;
}

sub Cond50 {
  my $result;
  
  if ( $token =~ /^(\(|\))$/ ) {
    GetNextToken();
    $result = Cond40();
    Expect( ')' );
  } elsif ( $token =~ /^(!)$/ ) {
    GetNextToken();
    my $right = Cond50();
    $result = '!'.$right;
    $result =~ s/^!!//;
  } else {
    $result = Cond60();
  }
  print STDERR "Cond50 returns $result\n";
  return $result;
}

sub Cond60 {
  my $result;
  
  if ( $token =~ /^\w/ ) {
    my $op = $token;
    my $savedsourcepos = $sourcepos;
    GetNextToken();
    if ( $op eq 'def' ) {
      Expect( '(' );
      my $name = ExpectString();
      Expect( ')' );
      $result = $op.':'.$name;
    } elsif ( $op eq 'defheader' ) { # Special case
      Expect( '(' );
      my $name = ExpectString();
      Expect( ')' );
      $result = 'def:header_'.$name.':';
    } elsif ( $op =~ /^(first_delivery|queue_running)$/ ) { # zero strings
      if ( $token eq '(' ) {
        Expect( '(' );
        Expect( ')' );
      }
      $result = $op;
    } elsif ( $op =~ /^(exists|ldapauth|radius)$/ ) { # one string
      Expect( '(' );
      my $name = Expr20();
      Expect( ')' );
      $result = $op.'{'.$name.'}';
    } elsif ( $op =~ /^(crypteq|eq|match|)$/ ) { # two strings
      Expect( '(' );
      my $left = Expr20();
      Expect( ',' );
      my $right = Expr20();
      Expect( ')' );
      $result = $op.'{'.$left.'}'.'{'.$right.'}';
    } else {
      $sourcepos = $savedsourcepos;
      ExpectDie( 'CONDITION FUNCTION' );
    }
  } else {
    my $left = Expr20();
    if ( $token =~ /^(<=|<|>=|>|=|!=)$/ ) {
      CheckNumber( $left );
      my $op = $token;
      GetNextToken();
      my $right = Expr20();
      CheckNumber( $right );
      $result = $op.'{'.$left.'}{'.$right.'}';
    } elsif ( $token =~ /^(=s=)$/ ) {
      GetNextToken();
      my $right = Expr20();
      $result = 'eq{'.$left.'}{'.$right.'}';
    } elsif ( $token =~ /^(=m=)$/ ) {
      GetNextToken();
      my $right = Expr20();
      $result = 'match{'.$left.'}{'.$right.'}';
    } elsif ( $token =~ /^(=ml=)$/ ) {
      GetNextToken();
      my $right = Expr20();
      $result = 'match{${lc:'.$left.'}}{'.$right.'}';
    } else {
      Expect( 'CONDITION' );
    }
  }
  print STDERR "Cond60 returns $result\n";
  return $result;
}

sub Ident {
  my $result;
  
  if ( $token =~ /^(\(|\))$/ ) {
    GetNextToken();
    $result = Expr20();
    Expect( ')' );
  } elsif ( $token =~ /^\$/ ) {
    my $op = $token;
    GetNextToken();
    if ( $token eq '(' ) {
      $op =~ s/^\$//;
      Expect( '(' );
      if ( $op eq 'header' ) {
        my $name = ExpectString();
        Expect( ')' );
        $result = '$header_'.$name.':';
      } elsif ( $op =~ /^(address|domain|escape|expand|lc|local_part|md5|quote|rxquote|uc)$/
          || $op =~ /^(hash_\d+_\d+|length_\d+|mask|substr_\d+_\d+)$/ ) {
        # one string
        my $param = Expr20();
        Expect( ')' );
        $result = '${'.$op.':'.$param.'}';
      } elsif ( $op =~ /^(base62)$/ ) {
        # one number
        my $param = $token;
        CheckNumber( $param );
        Expect( ')' );
        $result = '${'.$op.':'.$param.'}';
      } else {
        Expect( 'STRING FUNCTION' );
      }
    } else {
      $result = $op;
    }
  } elsif ( $token =~ /^\d/ ) {
    $result = $token;
    GetNextToken();
  } elsif ( $token =~ /^'/ ) {
    $result = ExpectString();
  } else {
    ExpectDie( 'IDENT' );
  }
  print STDERR "Ident returns $result\n";
  return $result;
}

sub ExpectString {
  my $result;

  ExpectDie( 'STRING' ) unless $token =~ /^'/;
  my $result = $token;
  $result =~ s/^'(.*)'$/$1/ or die "String?";
  GetNextToken();

  return $result;
}

sub Expect {
  local( $what ) = @_;
  ExpectDie( $what ) unless $token eq $what;
  GetNextToken();
}

sub ExpectDie {
  local( $what ) = @_;
  die "Expected $what, got $token, at ".substr($source,$sourcepos-length($token));
}

sub CheckNumber {
  local( $what ) = @_;
  
  if ( $what =~ /^\w*$/ && $what !~ /^\d+[KM]?$/ ) {
    die "Expected NUMBER, got $what, before ".substr($source,$sourcepos-length($token));
  }
}