#!/usr/bin/perl
#
# p4, the Perl based macro processor v0.2                     vim:sw=2:sts=2:et:
#
# Copyright (C) 2008 James E. Klicman <james at klicman dot org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#

package p4;
#
# Note: expressions are eval()ed inside the p4 package namespace.
#

#
# public macros for p4 scripts
#
sub include {
  my $file = $_[0];
  open(F,"<$file") || die "can't open $file: $!";
  my $rs = $/;
  $/ = undef;
  my $include = <F>;
  $/ = $rs;
  close(F);
  return &main::process($include);
}
# end public macros for p4 scripts

#
# eval or die.
#
sub _eval {
  my $expr = $_[0];
  if ($expr =~ /^\\(.*)/s) {
    return $1;
  } else {
    my $retval = 1;
    if ($expr =~ /^&([({])/) {
      $retval = ($1 eq '(');
      $expr =~ s/^&[({]|[)}]$//g;
    }
    my $r = eval($expr);
    die "$expr : $@" if $@;
    return ($retval ? $r : undef);
  }
}


package main;

# Until Perl 5.10 (which supports recursive patterns) is widely distributed,
# generate nested regexs for backward compatibility. $RERE_LEVELS changes the
# level of recursive regexs that can be generated. 10 levels are more than
# enough for my current needs. Increase $RERE_LEVELS as needed by setting the
# environment variable P4_RERE_LEVELS.
my $RERE_LEVELS = defined $ENV{'P4_RERE_LEVELS'} ? $ENV{'P4_RERE_LEVELS'} : 10;

#
# rere: create recursive regexp
#
sub rere {
  my($BE,$level,$ts) = @_;
  my $be = $BE;
  my($b,$e) = split(//,$be);
  # escape special characters
  $be =~ s/[\]]/\\$&/g;
  $b =~ s/[(){}[\]]/\\$&/g;
  $e =~ s/[(){}[\]]/\\$&/g;
  my $t = (!defined $ts ? '' : "$ts\t\t");
  return "$t$b\n$t\t(?:\n$t\t\t(?> [^$be]* )\n$t\t|\n" .
      ($level > 0 ? &rere($BE,$level-1,$t)
          : "$t\t\t$b\n$t\t\t\t[^$be]*\n$t\t\t$e\n") .
      "$t\t)*\n$t$e\n";
}

my $name = '[A-Za-z_][0-9A-Za-z_:]*';
my $braces = &rere('{}',$RERE_LEVELS);
my $parens = &rere('()',$RERE_LEVELS);
my $brackets = &rere('[]',$RERE_LEVELS);

sub process {
  my $data = $_[0];

  $data =~ s/
    (?<!\\)
      (?:
        \$(?:
          $name (?: $braces | $brackets )?
        |
          $braces
        )
      |
        &(?:
          $name (?: $parens )?
        |
          $parens
        |
          $braces
        )
      )
    |
      \\[\$\&]
  /&p4::_eval($&)/gex;

  return $data;
}

#
# main
#
my $rs = $/;
$/ = undef;
while (<>) {
  $/ = $rs;
  print &process($_);
  $rs = $/;
  $/ = undef;
}