File Coverage

blib/lib/HTML/Merge/Compile.pm

Criterion	Covered	Total	%
statement	19	991	1.9
branch	0	410	0.0
condition	0	46	0.0
subroutine	7	142	4.9
pod	0	134	0.0
total	26	1723	1.5

#####################################
package HTML::Merge::Compile;
#####################################
BEGIN
{
	eval 'use HTML::Merge::Ext;';
}
# Modules ###########################

use strict qw(subs vars);
use vars qw($open %enders %printers %tokenizers $VERSION $DEBUG
		$INTERNAL_DB $INTERNAL_DB_TYPE);
use Carp;
use Config;
use subs qw(quotemeta);

#####################################
$VERSION = '3.54';
#####################################
# Globals ###########################
$open = '\$R';
#my @non_flow = qw(VAR SQL ASSIGN SET PSET PGET PIC STATE INDEX CFG);
#@non_flow{@non_flow} = @non_flow;

my @printers = qw(VERSION VAR SQL GET PGET PVAR INDEX PIC STATE CFG INI LOGIN
	AUTH DECIDE EMPTY DATE DAY MONTH YEAR DATEDIFF LASTDAY ADDDATE
	USER MERGE TEMPLATE TRANSFER DUMP NAME TAG COOKIE SOURCE
	DATE2UTC UTC2DATE ENV DATEF EVAL HOUR MINUTE SECOND);
@printers{@printers} = @printers;

#my @stringers = qw(IF SET PSET SETCFG);
#@stringers{@stringers} = @stringers;

my @tokenizers = qw();
@tokenizers{@tokenizers} = @tokenizers;

%enders = qw(END_IF IF END LOOP END_WHILE WHILE);

$INTERNAL_DB_TYPE='SQLite';

#####################################
# locate the template from the various paths
sub GetTemplateFromPath
{
	my ($template) = @_;

        my @input = ("$HTML::Merge::Ini::TEMPLATE_PATH/$template",
         	     "$HTML::Merge::Ini::MERGE_ABSOLUTE_PATH/public/template/$template");

        # let lets find the input
        foreach (@input)
        {
                if (-f)
                {
                        return $_;
                }
	}

	return "$HTML::Merge::Ini::TEMPLATE_PATH/$template";
}
#####################################
sub WantPrinter
{
	my ($self, $tag, $dtag, $dline) = @_;

	my $ret = $self->WantTag($tag);
	return $ret if ($printers{$tag});
	my $line = $self->Line;
	$self->Die("$tag is not an output tag, perhaps you forgot to close a string in tag $dtag from line $dline? Output tags are " . join(", ", keys %printers));
}
#####################################
sub Translate
{
	my ($self, $exp) = @_;
	my $result = "\\\\[=\\.]";
	my $i;
	my @fetch;
	my $tail;

	while ($exp =~ s/^(.*?)([QUELD])//i)
	{
		my ($before, $token) = ($1, uc($2));
		$result .= quotemeta(quotemeta($before));

		if ($token eq 'U')
		{
			$result .= '(.*?)';
			$i++;
			push(@fetch, "\$$i");
		}
		elsif ($token eq 'L')
		{
			$result .= '([A-Z])';
			$i++;
			push(@fetch, "\$$i");
		}
		elsif ($token eq 'Q')
		{
			$i++;
			$result .= "\\\\(['\"])(.*?)\\\\\\$i";
			$i++;
			push(@fetch, "\$$i");
		}
		elsif ($token eq 'E')
		{
			$result .= '(?:';
			$tail = ')?' . $tail;
		}
		elsif ($token eq 'D')
		{
			$result .= "\\\\[\\.=]";
		}
		else
		{
			$self->Die("Unknown notator: $token");
		}
	}

	$result .= quotemeta(quotemeta($exp)) . $tail;
	my $fetch = '(' . join(", ", @fetch) . ')';
	($result, $fetch);
}
#################################
# CGI parsing utility		#
#################################
sub ParseForm
{
        my $toParse = shift;
        my ($name , $value , @pairs , $pair , %FORM);
        @pairs = split(/&/, $toParse);
        foreach $pair (@pairs) {
                ($name, $value) = split(/=/, $pair);
                $value =~ tr/+/ /;
                $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
                $FORM{$name} = $value;
                #Debug("kak : $name \=  $value");
        }
        return \%FORM;
}
#####################################
sub CgiParse
{
        my $GFORM =  &ParseForm($ENV{'QUERY_STRING'});
        my $buffer;
        read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
        my $PFORM = &ParseForm($buffer);

        my (%FORM , $key);
        foreach $key(keys %$GFORM){
                $FORM{$key} = $GFORM->{$key};
        }

        foreach $key(keys %$PFORM){
                $FORM{$key} = $PFORM->{$key};
        }
        return \%FORM;
}
#####################################
sub WantTag
{
	my ($self, $tag, $inv) = @_;
	my $candidate = $enders{$tag};
	if ($candidate && !$inv)
	{
		$tag = $candidate;
		$inv = 1;
	}
	my $un = $inv ? "Un" : "";
	my $code = UNIVERSAL::can($self, "Do$un$tag");
	return $code if $code;
	my $macro = UNIVERSAL::can('HTML::Merge::Ext', "MACRO_$tag");
	if ($macro)
	{
		my $proto = prototype("HTML::Merge::Ext::MACRO_$tag");
		my $text = quotemeta(&$macro);
		$proto = " ($proto)" if $proto;

		eval <
		package HTML::Merge::Ext;

		sub API_$tag$proto
		{
			Macro("$text", \@_);
		}
EOM
	}

	foreach my $api (qw(API OUT))
	{
		my $candidate = "RUN${api}_$tag";
		my $code = UNIVERSAL::can('HTML::Merge::Ext', $candidate);
		if ($code)
		{
			my $proto = prototype("HTML::Merge::Ext::$candidate");
			$proto =~ s/;.*$//;
			$self->Die("Prototype for $candidate may include only \$ signs")
			unless ($proto =~ /^\$*$/);
			my $check = "${api}_$tag";
			my $code = UNIVERSAL::can('HTML::Merge::Ext', $check);
			unless ($code)
			{
				my @par;
				my $i = 0;
				foreach (split(//, $proto))
				{
					push(@par, qq{"\$_[$i]"});
					$i++;
				}
				my $pass = join(", ", @par);
				my $text = "package HTML::Merge::Ext;
					sub $check ($proto)
					{
						$candidate($pass);
					}";
				eval $text;
				die $@ if $@;
				last;
			}
		}
	}
	my @options = !$inv ? qw(API OAPI OUT) : qw(CAPI);
	foreach my $api (@options)
	{
		my $candidate = "${api}_$tag";
		$code = UNIVERSAL::can('HTML::Merge::Ext', $candidate);
		if ($code)
		{
			my $ref = ref($self);
			my $proto = prototype("HTML::Merge::Ext::$candidate");
			$proto =~ s/;.*$//;
			$self->Die("Prototype for $candidate may include only \$ signs")
				unless ($proto =~ /^\$*$/);
			my $n = length($proto);
			my $shift = join(", ",
				map {"\$param[$_]";} (0 .. $n - 1));
			my $stack;
			my $scope = lc($tag);
			if ($api eq 'OAPI')
			{
				$stack = qq!\$self->Push('$scope', \$engine);!;
			}
			if ($api eq 'CAPI')
			{
				$stack = qq!\$self->Expect(\$engine, '$scope');!
			}
			my $desc = UNIVERSAL::can('HTML::Merge::Ext',
				"DESC_$tag");
			my $expand;
			unless ($desc)
			{
				$expand = 'my @param = @$param;';
				$tokenizers{$tag} = 1;
			}
			else
			{
				if ($api eq 'CAPI')
				{
					$expand = 'my @param;';
				}
				else
				{
					my $txt = &$desc;
					my ($re, $form) = $self->Translate($txt);
					$expand = <
	unless (\$param =~ /^$re\$/s)
	{
		\$self->Syntax;
	}
	my \@param = $form;
EOM
				}
			}
			my $extend = <
package $ref;
sub Do$un$tag
{
	my (\$self, \$engine, \$param) = \@_;
	$expand
	my \$n = \@param;
	\$self->Die("$n parameters expected for $tag, gotten \$n") unless (\$n == $n);
	$stack
	\$HTML::Merge::Ext::ENGINE = \$engine;
	\$HTML::Merge::Ext::COMPILER = \$self;
	HTML::Merge::Ext::$candidate($shift);
}
EOM
			eval $extend;
			$self->Die($@) if $@;
			$printers{$tag} = ($api eq 'OUT');
			return $self->WantTag($tag, $inv);
		}
	}
	$self->Die("$tag is not a valid Merge tag");
}
#####################################
sub quotemeta {
	my $text = CORE::quotemeta(shift);
	$text =~ s/\\ / /g;
	$text =~ s/\\\t/\t/g;
	$text;
}
#####################################
sub Compile {
	my $self = {'buffer' => '', 'scopes' => []};
	my $class = __PACKAGE__;
	my $in = $HTML::Merge::config;
	$in =~ s|/\w+\.\w+$||;
	$in =~ s|^/*||;
	$in =~ s/[\/\\]/::/g;
	$in =~ tr/A-Za-z0-9_://cd;
	if ($in) {
		my $code =  <
package ${class}::$in;
use strict 'vars';
use vars qw(\@ISA);
\@ISA = qw($class);
EOM
		eval $code;
		die $@ if $@;
		$class .= "::$in";
	}
	bless $self, $class;
	$self->{'source'} = shift;
	$self->{'source'} =~ s/\r\n/\n/g;
	$self->{'save'} = $self->{'source'};
	$self->{'name'} = shift;
	$self->{'template'} = $self->{'name'};
	$self->{'template'} =~ s|^$HTML::Merge::Ini::TEMPLATE_PATH/||;
	$self->{'force line'} = shift;
	$self->Main;
	$self->{'buffer'};
}
#####################################
sub Clone {
	my $self = shift;

	return bless {},ref($self);
}
#####################################
sub Clause {
	my ($self,$text,$in) = @_;

	my $new=$self->Clone();
	my $error;
	my $res;

	$new->{'save'} = $new->{'source'} = "$text>";
	eval{
		$res=$new->EatParam($in);
	};

	if($@){
		$error=$@;
		$error=~ s/ at .* line .*$//;
		$self->Die($error);
	}
	$res=~ s/\n+$//s;

	return $res;
}
#####################################
sub Line {
	my $self = shift;
	my $force = $self->{'force line'};
	return $force if $force;
	my @lines = split(/\n/, $self->{'save'});
	my $left = substr($self->{'save'}, -length($self->{'source'}));
	my @ll = split(/\n/, $left);
	my $this = @lines - @ll + 1;
}
#####################################
sub Mark {
	my $self = shift;
	my $name = $self->{'name'};
	my $this = $self->Line;
	return unless $name;
	$self->{'buffer'} .= "\$HTML::Merge::context = [\"$name\", \"$this\"];\n";
	$self->{'buffer'} .= "#line $this $name\n";
	return;
}
#####################################
sub Die {
	my ($self, $error) = @_;
	my $this = $self->Line;
	my $s = (split(/\n/, $self->{'save'}))[$this - 1];
	my $name = $self->{'name'};
	if ($error < 0) {
		die "Depcrecated: Die(negative)";
	}

	$name =~ s|^.*/||;
	Carp::cluck "Error: $error at $name line $this when doing: $s" if $DEBUG
		|| $ENV{'MERGE_DEBUG'};
	die "Error: $error at $name line $this, when doing: $s";
}
#####################################
sub Main {
	my $self = shift;
	$self->{'source'} =~ s/<(BODY)/\n<$1/i;
	while  ($self->EatOne) {}
	$self->PrePrint($self->{'source'});
	$self->{'source'} = '';
	if (@{$self->{'scopes'}}) {
		my @scopes = map {join("/", @$_);} @{$self->{'scopes'}};
		my $stack = join(", ", @scopes);
		$self->Die("Stack not empty: $stack");
	}
}
#####################################
sub EatOne {
	my $self = shift;
	if ($self->{'source'} =~ s/^(.*?)\<(\/?)$open(\[.+?\]\.)?(\w+)//si) {
		my ($head, $close, $engine, $tag, $param) = ($1, $2, $3, uc($4));
		$engine =~ s/^\[(.*)\]\./$1/;
		$engine= $self->Clause($engine,$tag) if($engine=~ /\<$open/);

		my $code = $self->WantTag($tag, $close);
		$param = $self->EatParam($tag);
		$self->Die("Closing tags may not have parameters") if (($close || $enders{$tag}) && ($param && !ref($param) || ref($param) && $#$param >= 0));
		$self->Mark;
		if ($printers{$tag}) {
			$self->PrePrint($head);
			$self->{'buffer'} .= "print (";
		} else {
			$head =~ s/\s+$//s;
			$self->PrePrint($head);
		}
		$self->{'buffer'} .= &$code($self, $engine, $param);
		if ($printers{$tag}) {
			$self->{'buffer'} .= ");\n";
		}
		return 1;
	}
	undef;
}
#####################################
sub Macro {
	my ($self, $text) = @_;
	my $length = length($self->{'source'});
	my $lennow;

	$self->{'source'} = $text . $self->{'source'};
	for (;;) {
		$lennow = length($self->{'source'});
		last if ($lennow <= $length);
		my $left = $lennow - $length;
		last if $self->{'source'} =~ /^\s{$left}/;

		$self->EatOne || last;
	}
	my $remainder = $lennow - $length;
	$self->Die("macro did not resolve correctly") if ($remainder < 0);
	$self->PrePrint(substr($self->{'source'}, 0, $remainder));
	substr($self->{'source'}, 0, $remainder) = "";
}
#####################################
sub PrePrint {
	my ($self, $string) = @_;
	while ($string =~ s/^(.*?)\0(.*?)\0//) {
		my ($b4, $bt) = ($1, $2);

		$self->Print($b4);
		$self->{'buffer'} .= qq'print "$bt";';
	}
	$self->Print($string) if $string;
}
#####################################
sub Print {
	my ($self, $string) = @_;
	my @lines = split(/\n/, $string);
	my $last = pop @lines;
	foreach (@lines) {
		$self->{'buffer'} .= 'print "' . quotemeta($_) . '\n";' . "\n";
	}
	$self->{'buffer'} .= 'print "' . quotemeta($last) . '";' . "\n";
	$self->{'buffer'} .= 'print "\n";' . "\n" if ($string =~ /\n$/);
}
#####################################
sub EatParam {
	my ($self, $in) = @_;
	my $tokens = $tokenizers{$in};
	my $line = $self->Line;
	my $state = '';
	my $text = '';
	my @tokens;
	for (;;) {
		my $ch;
		if ($self->{'source'} =~ s/^(.)//s) {
			$ch = $1;
		} else {
			$self->Die("Could not close tag $in, probably unbalanced quotes");
		}
		if ($ch eq "\0") {
			unless ($self->{'source'} =~ s/^(.*?)\0//) {
				$self->Die("Unclosed null encpasulation. Check your macro");
			}
			$text .= $1;
			next;
		}
		if ($ch eq "'" && $state ne '"') {
			$text .= "\\'";
			$state = ($state eq "'" ? '' : "'");
			next;
		}
		if ($ch eq '"' && $state ne "'") {
			$text .= "\\\"";
			$state = ($state eq '"' ? '' : '"'); #'"
			next;
		}
		if ($ch eq "\\") {
			$self->{'source'} =~ s/^(.)//s;
			$ch = $1;
			$text .= "\\$ch";
			next;
		}
		if ($ch eq '>' && !$state) {
			$text =~ s/\s+$//;
			return $text unless $tokens;
			return [] unless @tokens;
			my $pre = shift @tokens;
			$self->Die("Illegal prefix $pre") if $pre;
			push(@tokens, $text);
			return \@tokens;
		}
		if ($ch eq '.' && !$state && $tokens) {
			push(@tokens, $text);
			$text = '';
			next;
		}
		if ($ch eq "<") {
			unless ($self->{'source'} =~ s/^$open//) {
				$text .= "<";
				$text .= $self->FindRight if $in eq 'EM';
				next;
			}
			$self->{'source'} =~ s/(\[.+?\]\.)?(\w+)//;
			my $engine = $1;
			my $tag = uc($2);
			$engine =~ s/^\[(.*)\]\./$1/;
			$engine= $self->Clause($engine,$tag) if($engine=~ /\<$open/);
			my $code;
			if ($in ne 'EM') {
				$code = $self->WantPrinter($tag, $in, $line);
			}
			my $sub = $self->EatParam($in eq 'EM' ? 'EM' : $tag);
			if ($in ne 'EM') {
				$text .= '" . (' . &$code($self, $engine, $sub) . ') . "';
			}
		} else {
			$text .= quotemeta($ch);
		}
	}
}
#####################################
sub FindRight {
	my $self = shift;
	my $count = 1;
	my $text;
	while ($self->{'source'} =~ s/^(.*?)([\<\>])//) {
		$text .= "$1$2";
		$count += $2 eq '<' ? 1 : -1;
		return $text unless $count;
	}
	return $text;
}
#####################################
sub Expect {
	my ($self, $engine, @options) = @_;
	my $current = pop @{$self->{'scopes'}};
	my @topt = @options;
	my $last = pop @topt;
	my $expect = join(", ", @topt) . (@topt ? ' or ' : '') . $last;
	$self->Die("Stack underflow - a closing tag without a preceding tag, expecting: $expect. Perhaps you forgot $open in the opening tag?") unless ($current);
	my ($scope, $teng) = @$current;
	$self->Die("Expected engine '$engine', got '$teng'") unless ($teng eq $engine);
	foreach (@options) {
		return if ($_ eq $scope);
	}
	$self->Die("Unexpected scope $scope, expecting: $expect. Perhaps you forgot $open in the opening tag?");
}
#####################################
sub Push {
	my ($self, $scope, $engine) = @_;
	push(@{$self->{'scopes'}}, [$scope, $engine]);
}
#####################################
sub DoLOOP {
	my ($self, $engine, $param) = @_;
	my $limit = undef;
	if ($param =~ s/^\\\.LIMIT\\=((?:\\['"])?)(.+)\1$//s) { #'
		$limit = $2;
	}
	$self->Syntax if $param;
	my $text;
	unless ($limit) {
		$text = <
local (\$_);
for (;;) {
	\$_++;
EOM
	} else {
		$text = <
HTML::Merge::Engine::Force("$limit", 'iu');
foreach (1 .. "$limit") {
EOM
	}
	$text .= <
	last unless (\$engines{"$engine"}->HasQuery);
	last unless (\$engines{"$engine"}->Fetch(1, \$_));
	local (\$_);
EOM
	$self->Push('loop', $engine);
	$text;
}
#####################################

*DoEPEAT = \&DoITERATION;
*DoUnEPEAT = \&DoUnITERATION;

#####################################
sub DoITERATION {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.LIMIT\\=((?:\\['"])?)(.+)\1$/s) { #'
		$self->Syntax;
	}
	my $limit = $2;
	$self->Push('iteration', $engine);
<
HTML::Merge::Engine::Force("$limit", 'ui');
foreach (1 .. "$limit") {
EOM
}
#####################################
sub DoUnITERATION {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'iteration');
	"}\n";
}
#####################################
sub DoBREAK {
	my ($self, $engine, $param) = @_;
	$self->Syntax if ($param);
	"last;";
}

#####################################
sub DoCONT {
	my ($self, $engine, $param) = @_;
	$self->Syntax if ($param);
	"next;";
}
#####################################
sub DoUnLOOP {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'loop');
	"}\n";
}
#####################################
sub DoFETCH {
	my ($self, $engine, $param) = @_;
	$self->Syntax if ($param);
	"\$engines{\"$engine\"}->Fetch(1, 2);";
}
#####################################

*DoENVGET = \&DoENV;

#####################################
sub DoENV {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+)$//s) {
		$self->Syntax;
	}
	return "\$ENV{\"$1\"}";
}
#####################################
sub DoENVSET {
        my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+?)\\=\\(['"])(.*?)\\\2$//s) {
		$self->Syntax;
	}
	"\$ENV{\"$1\"} = eval(\"$3\");\n";
}
#####################################
sub DoCFG {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+)$//s) {
		$self->Syntax;
	}
	"\${\"HTML::Merge::Ini::\"  . \"$1\"}";
}
#####################################

*DoINIGET = *DoINI = *DoCFGGET = \&DoCFG;
*DoINISET = \&DoCFGSET;

#####################################
sub DoCFGSET {
        my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+?)\\=\\(['"])(.*)\\\2$//s) {
		$self->Syntax;
	}
	"\${\"HTML::Merge::Ini::\"  . \"$1\"} = eval(\"$3\");\n";
}
#####################################

*DoVAL = \&DoVAR;

#####################################
sub DoVAR
{
	my ($self, $engine, $param) = @_;

	unless ($param =~ s/^\\\.(.+)$//s)
	{
		$self->Syntax;
	}

	return "\$vars{\"$1\"}";
}
#####################################
sub DoVERSION
{
	my ($self, $engine, $param) = @_;

	return $VERSION;
}
#####################################
sub DoSQL
{
	my ($self, $engine, $param) = @_;

	unless ($param =~ s/^\\\.(.+)$//s)
	{
		$self->Syntax;
	}

	return "\$engines{\"$engine\"}->Var(\"$1\")";
}
#####################################
sub DoIF
{
	my ($self, $engine, $param) = @_;

	unless ($param =~ s/^\\[\.=]\\(['"])(.*)\\\1$//s)
	{
		$self->Syntax;
	}

	my $text = <
HTML::Merge::Error::HandleError('INFO', "$2", 'IF');
my \$__test = eval("$2");
HTML::Merge::Error::HandleError('ERROR', \$@) if (\$@);
if (\$__test) {
EOM
	$self->Push('if', $engine);
	$text;
}
#####################################
sub DoTIF
{
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\[\.=]\\(['"])(.*)\\\1$//s)
	{
		$self->Syntax;
	}

	my $text = <
HTML::Merge::Error::HandleError('INFO', "$2", 'IF');
my \$__test = "$2";
HTML::Merge::Error::HandleError('ERROR', \$@) if (\$@);
if ("$2") {
EOM
	$self->Push('if', $engine);
	$text;
}
#####################################
sub DoUnTIF {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'if', 'else');
	"}\n";
}
#####################################
sub DoELSIF {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\[\.=]\\(['"])(.*)\\\1$//s) {
		$self->Syntax;
	}
	$self->Expect($engine, 'if');
	$self->Push('if', $engine);
	my $text = <
	\$__exit = 0;
} elsif (((HTML::Merge::Error::HandleError('INFO', "$2", 'IF'),
	\$__exit = eval("$2"),
	\$@ && HTML::Merge::Error::HandleError('ERROR', \$@),
	\$__exit))[-1]) {
EOM
	$text;
}


sub DoUnIF {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'if', 'else');
	"}\n";
}

sub DoELSE {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	$self->Expect($engine, 'if');
	$self->Push('else', $engine);
	"} else {\n";
}

sub DoWHILE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\[\.=]\\(['"])(.*)\\\1$//s) {
		$self->Syntax;
	}
	my $cond = quotemeta($2);
	my $text = <
HTML::Merge::Error::HandleError('INFO', "while $2", 'WHILE');
for (;;) {
	my \$__test = eval("$2");
	HTML::Merge::Error::HandleError('ERROR', \$@) if (\$@);
	last unless \$__test;
EOM
	$self->Push('while', $engine);
	$text;
}

sub DoUnWHILE {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'while');
	"}\n";
}

sub DoQ {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\[=\.]\\(['"])(.*)\\\1$//s) {
		$self->Syntax;
	}
	"\$engines{\"$engine\"}->Query(\"$2\");\n";
}

sub DoS {
        my ($self, $engine, $param) = @_;
        unless ($param =~ s/^\\[\.=]\\(['"])(.*)\\\1$//s) {
                $self->Syntax;
        }
        "\$engines{\"$engine\"}->Statement(\"$2\");\n";
}

sub DoEVAL {
        my ($self, $engine, $param) = @_;
        unless ($param =~ s/^\\[\.=]\\(['"])(.*)\\\1$//s) {
                $self->Syntax;
        }
        "eval(\"$2\")";
}
#####################################
sub DoPERL {
        my ($self, $engine, $param) = @_;
	my $type;
	if ($param =~ s/^\\\.([ABC])$//i) {
		$type = uc($1);
	}
	$self->Syntax if $param;
	my $code = "";
	my $line = $self->Line;
	if ($type eq 'B' || $type eq 'C') {
		my $flag;
		while ($self->{'source'} =~ s/^(.*?)\<($open(?:\[.+?\]\.)?\w+|\/${open}PERL\>)//is) {
			my $let = quotemeta($1);
			$code .= qq!"$let" . !;
			my $tag = $2;
			if ($tag =~ m|^/${open}PERL>$|) {
				$flag = 1;
				last;
			}
			$tag =~ s/^$open//;
			my $engine = '';
			if ($tag =~ s/^\[(.+?)\]\.//) {
				$engine = $1;
				$engine= $self->Clause($engine,$tag) if($engine=~ /\<$open/);
			}
			my $coder = $self->WantPrinter($tag, "PERL", $line);
			my $param = $self->EatParam($tag);
			my $codet = &$coder($self, $engine, $param);
			$code .= "$codet . ";
		}
		$self->Die("End of PERL not found") unless $flag;
		$code .= q!""!;
	} else {
		unless ($self->{'source'} =~ s/^(.*?)\<\/${open}PERL\>//is) {
			$self->Die("End of PERL not found");
		}
		$code = '"' . quotemeta($1) . '"';
	}
	my $name = $self->{'name'};
	my $text = <
\$__result = $code;
HTML::Merge::Error::HandleError('INFO', \$__result, 'PERL');
\$__result = eval("\$__result; undef;");
HTML::Merge::Error::HandleError('ERROR', \$@) if \$@;
EOM
	if ($type eq 'A' || $type eq 'C') {
		$line = $self->Line;
		$text .= <
if (\$__result) {
	use HTML::Merge::Compile;
	eval { \$__result = &HTML::Merge::Compile::Compile(\$__result, "$name", $line); };
	HTML::Merge::Error::HandleError('ERROR', \$@) if \$@;
	\$__result = eval(\$__result);
	HTML::Merge::Error::HandleError('ERROR', \$@) if \$@;
}
EOM
	}
	$text;
}
###############################################################
sub DoSET
{
        my ($self, $engine, $param) = @_;

	unless ($param =~ s/^\\\.(.+?)\\=\\(['"])(.*?)\\\2$//s)
	{
		$self->Syntax;
	}

	return "\$vars{\"$1\"} = eval(\"$3\");\n";
}
###############################################################
sub DoASSIGN
{
        my ($self, $engine, $param) = @_;

	unless ($param =~ s/^\\\.(.+?)\\=\\(['"])(.*?)\\\2$//s)
	{
		$self->Syntax;
	}

	return "\$vars{\"$1\"} = \"$3\";\n";
}
###############################################################

sub DoPCLEAR {
        my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	"\$engines{\"$engine\"}->ErasePersistent;\n";
}

sub DoPSET {
        my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+?)\\=\\(['"])(.*?)\\\2$//s) {
		$self->Syntax;
	}
	"\$engines{\"$engine\"}->SetPersistent(\"$1\", eval(\"$3\"));\n";
}

sub DoPGET {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+)$//s) {
		$self->Syntax;
	}
	return "\$engines{\"$engine\"}->GetPersistent(\"$1\")";
}

*DoPVAR = \&DoPGET;
*DoGET = \&DoVAR;

sub DoPIMPORT {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+)$//s) {
		$self->Syntax;
	}
	return "\$hash{\"$1\"} = \$engines{\"$engine\"}->GetPersistent(\"$1\");";
}

sub DoPEXPORT {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.+)$//s) {
		$self->Syntax;
	}
	return "\$engines{\"$engine\"}->SetPersistent(\"$1\", \$hash{\"$1\"});";
}


*DoREM = \&DoEM;
sub DoEM {}

sub DoTRACE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.\\(['"])(.*)\\\1$//s) {
		$self->Syntax;
	}
	my $line = $2;
	<
HTML::Merge::Error::HandleError('INFO', "$line", 'TRACE');
EOM
}
sub DoDIE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.\\(['"])(.*)\\\1$//s) {
		$self->Syntax;
	}
	my $line = $2;
	<
HTML::Merge::Error::HandleError('ERROR', "$line");
EOM
}
#################################################
sub DoINCLUDE
{
	my ($self, $engine, $param) = @_;
	my $inc;
	my $name = $self->{'name'};
	my $text;

	unless ($param =~ s/^\\\.\\(['"])(.*)\\\1$//s)
	{
		$self->Syntax;
	}
	$inc = $2;
	$inc =~ s/\\(.)/$1/g;

##################################################################
#	require Cwd;
#	my $curr = &Cwd::cwd;
#	my @tokens = split(/\//, $self->{'name'});
#	pop @tokens;
#	my $dir = join("/", @tokens);
#	chdir $dir if $dir;
#	open(I, $inc) || $self->Die("Can't open $inc at $dir");
#	my $text = join("", );
#	close(I);
#	chdir $curr;
#	$self->{'source'} = $text . $self->{'source'};
##################################################################

	$text = <
	my \$__input = HTML::Merge::Compile::GetTemplateFromPath("$inc");
	my \$__script = "\$HTML::Merge::Ini::CACHE_PATH/$inc.pli";
	my \$__candidate = "\$HTML::Merge::Ini::PRECOMPILED_PATH/$inc.pli";

	unless (-e \$__candidate)
	{
		#HTML::Merge::Error::DoWarn('NO_TEMPLATE','$inc') unless -e \$__input;
		HTML::Merge::Error::HandleError('ERROR',
			"No template '$inc' found") unless -e \$__input;

		my \$__source = (stat(\$__input))[9];
		my \$__output = (stat(\$__script))[9];
		if (\$__source > \$__output) {
			require HTML::Merge::Compile;
			HTML::Merge::Compile::safecreate(\$__script)
				unless -e \$__script;
			eval '	HTML::Merge::Compile::CompileFile(\$__input, \$__script, 1); ';

			if(\$@)
			{
				# erase the pli file
				unlink(\$__script);
				HTML::Merge::Error::HandleError('ERROR', \$@);
			}
		}
	} else {
		\$__script = \$__candidate;
	}
	HTML::Merge::Error::HandleError('INFO',"$inc",'INCLUDE');
	do \$__script;
	HTML::Merge::Error::HandleError('ERROR', \$@) if \$@;
EOM
	$text;
}
#################################################
sub DoWEBINCLUDE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.\\(['"])(.*)\\\1$//s) {
		$self->Syntax;
	}
	my $url = $2;
<
if (\$HTML::Merge::Ini::WEB) {
	require LWP;
	require HTTP::Request::Common;
	import HTTP::Request::Common;

	my \$__url = "$url";
	\$__url = "http://\$ENV{'SERVER_NAME'}:\$ENV{'SERVER_PORT'}\$__url"
		unless (\$__url =~ m|://|);
	my \$__ua = new LWP::UserAgent;
	my \$__req = GET("$url");
	my \$__resp = \$__ua->request(\$__req);
	if (\$__resp->is_success) {
		print \$__resp->content;
	} else {
		HTML::Merge::Error::HandleError('ERROR', "Web GET to URL $url returned code " . \$__resp->code);
	}
}
EOM
}

sub DoINDEX {
        my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	"\$engines{\"$engine\"}->Index";
}

*DoRERUN = \&DoERUN;

sub DoERUN {
        my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	"\$engines{\"$engine\"}->ReRun;";
}

*EQUEST = \&ENUMREQ;

sub DoENUMREQ {
	my ($self, $engine, $param) = @_;
	$self->Syntax unless ($param =~ /^\\\.(.+?)\\\=(.+)$/s);
	my ($iterator, $getter) = ($1, $2);
	$self->Push('enumreq', $engine);
	qq!foreach (param()) {
		next if (\$_ eq "template");
		\$vars{"$iterator"} = \$_;
		\$vars{"$getter"} = \$vars{\$_};\n!;
}

sub DoUnENUMREQ {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'enumreq');
	"}\n";
}

sub DoENUMQUERY {
	my ($self, $engine, $param) = @_;
	$self->Syntax unless ($param =~ /^\\\.(.+?)\\\=(.+)$/s);
	my ($iterator, $getter) = ($1, $2);
	$self->Push('enumquery', $engine);
	qq!foreach (\$engines{"$engine"}->Columns) {
		\$vars{"$iterator"} = \$_;
		\$vars{"$getter"} = \$engines{"$engine"}->Var(\$_);\n!;
}

sub DoUnENUMQUERY {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'enumquery');
	"}\n";
}

sub DoMULTI {
	my ($self, $engine, $param) = @_;
	$self->Syntax unless ($param =~ /^\\\.(.+?)\\\=(.+)$/s);
	my ($iterator, $getter) = ($1, $2);
	$self->Push('multi', $engine);
	qq!foreach (param("$getter")) {
		\$vars{"$iterator"} = \$_;!;
}

sub DoUnMULTI {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'multi');
	"}\n";
}

sub DoGLOB {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.([DF])\\\.(.+?)\\=\\(['"])(.*)\\\3$/is) {
		$self->Syntax;
	}
	my ($how, $iterator, $mask) = (uc($1), $2, $4);
	$self->Push('glob', $engine);
	my $cond = $how eq 'D' ? 'unless' : 'if';
	qq!\$__x = "$mask";
	\$__x .= "/*" if (-d \$__x);
	foreach (glob(\$__x)) {
		next $cond -d \$_;
		s|^.*/||;
		\$vars{"$iterator"} = \$_;\n!
}

sub DoUnGLOB {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'glob');
	"}\n";
}

sub DoFTS {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.(.+?)\\=\\(['"])(.*)\\\2$/is) {
		$self->Syntax;
	}
	my ($iterator, $base) = ($1, $3);
	$self->Push('fts', $engine);
	<
	use File::Find;
	\@__files = ();
	find(sub {push(\@__files, \$File::Find::name)}, "$base");
	foreach (\@__files) {
		\$vars{"$iterator"} = \$_;
EOM
}

sub DoUnFTS {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'fts');
	"}\n";
}

sub DoCOUNT {
	my ($self, $engine, $param) = @_;
	$self->Syntax unless ($param =~ /^\\\.(.+?)\\\=(.*?)\\\:(.*?)(\\,.*)?$/s);
	my ($var, $from, $to, $step) = ($1, $2, $3, $4);
	$step ||= "\\,1";
	$step =~ s/^\\,//;

	my $i = "\$vars{\"$var\"}";
	$self->Push('count', $engine);
	<
	HTML::Merge::Engine::Force("$from", "n");
	HTML::Merge::Engine::Force("$to", "n");
	HTML::Merge::Engine::Force("$step", "n");
	for ($i = "$from"; $i <= "$to"; $i += "$step") {
EOM
}

sub DoUnCOUNT {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'count');
	"}\n";
}

sub DoPIC {
	my ($self, $engine, $param) = @_;
	my $type;
	unless ($param =~ s/^\\\.([CFRNADX])(.*)$//is) {
		$self->Syntax;
	}
	($type, $param) = (uc($1), $2);
	my $code = &UNIVERSAL::can($self, "Picture$type");
	&$code($self, $param);
}

sub PictureF {
	my ($self, $param) = @_;
	$param =~ s/^\\\((\\?.)\\\)\\\.\\(['"])(.*?)\\\2$/$1\\$2$3\\$2/s;
	unless ($param =~ /^(\\?.)\\(['"])(.*?)\\\2$/s) {
		$self->Syntax;
	}
	my ($ch, $text) = ($1, $3);
	<
"" . (\$__s = "$text", \$__s =~ s/\\s/$ch/g, \$__s)[-1]
EOM
}

sub PictureC {
	my ($self, $param) = @_;
	my @ary;
	my $flag;
	$param =~ s/^\\\((.*)\\\)\\\.\\(['"])(.*?)\\\2$/$1\\.\\$2$3\\$2/s;
	while ($param =~
			s/^\s*\\(['"])(.*?)\\\1\s*\\=\s*\\(['"])(.*?)\\\3\s*//s) {
		push(@ary, [$2, $4]);
		if ($param =~ s/^\\\.//) {
			$flag = 1;
			last;
		}
		unless ($param =~ s/^\\,//) {
			$self->Syntax;
		}
	}
	$self->Die("Syntax error in PIC.C") unless ($flag);
	unless ($param =~ s/^\\(["'])(.*?)\\\1$//s) {
		$self->Syntax;
	}
	my $text = $2;
	my $code = <
"" . (\$__s = "$text",
EOM
	foreach (@ary) {
		my ($from, $to) = @$_;
		$code .= <
\$__s =~ s/^$from\$/$to/g,
EOM
	}
	$code . ", \$__s)[-1]";
}

sub PictureR {
	my ($self, $param) = @_;
	my @ary;
	my $flag;
	$param =~ s/^\\\((.*)\\\)\\\.\\(['"])(.*?)\\\2$/$1\\.\\$2$3\\$2/s;
	while ($param =~
			s/^\s*\\(['"])(.*?)\\\1\s*\\=\s*\\(['"])(.*?)\\\3\s*//s) {
		push(@ary, [$2, $4]);
		if ($param =~ s/^\\\.//) {
			$flag = 1;
			last;
		}
		unless ($param =~ s/^\\,//) {
			$self->Syntax;
		}
	}
	$self->Die("Syntax error in PIC.R") unless ($flag);
	unless ($param =~ s/^\\(["'])(.*?)\\\1$//s) {
		$self->Syntax;
	}
	my $text = $2;
	my $code = <
"" . (\$__s = "$text",
EOM
	foreach (@ary) {
		my ($from, $to) = @$_;
		$code .= <
\$__s =~ s/$from/$to/g,
EOM
	}
	$code . ", \$__s)[-1]";
}

sub PictureN {
	my ($self, $param) = @_;
	my %opts;
	while ($param =~ s/^([ZF])//) {
		$opts{$1}++;
	}
	unless ($param =~ s/^\\\((.*?)\\\)//s) {
		$self->Syntax;
	}
	my $format = $1;
	unless ($param =~ s/^\\\.\\(["'])(.*?)\\\1$//s) {
		$self->Syntax;
	}
	my $text = $2;
	<
"" . (\$__s = "$text" || !"$opts{'Z'}" ? sprintf("%${format}f", "$text") : " ",
	"$opts{'F'}" ? (\$__s =~
	s!(\\d+)!scalar(reverse join(\$HTML::Merge::Ini::THOUSAND_SEPARATOR || ",", (reverse \$1) =~ /(\\d{1,3})/g))!e) : undef,
	\$__s =~ s/\\./\$HTML::Merge::Ini::DECIMAL_SEPARATOR || '.'/e,
	\$__s)[-1]
EOM
}

sub PictureA {
	my ($self, $param) = @_;
	my %opts;
	while ($param =~ s/^([LRCSPWDE])//) {
		$opts{$1}++;
	}
	foreach (qw(SCP DE)) {
		my $count;
		foreach (split(//)) {
			$self->Die("Illegal flag combinations")
				if ($opts{$_} && $count++);
		}
	}
	unless ($param =~ s/^\\\((.*?)\\\)//s) {
		$self->Syntax;
	}
	my $format = $1;
	unless ($param =~ s/^\\\.\\(["'])(.*?)\\\1$//s) {
		$self->Syntax;
	}
	my $text = $2;
	<
"" . (\$__s = "$text",
	"$opts{'C'}" && \$__s =~ tr/a-z/A-Z/,
	"$opts{'S'}" && \$__s =~ tr/A-Z/a-z/,
	"$opts{'P'}" && \$__s =~ s/\\b([a-z]\\S+)/ucfirst(lc(\$1))/egi,
	"$opts{'L'}" && \$__s =~ s/^\\s+//,
	"$opts{'R'}" && \$__s =~ s/\\s+\$//,
	"$opts{'W'}" && \$__s =~ s/\\s{2,}/ /g,
	"$opts{'E'}" && (\$__s =~ s/([^ _A-Za-z0-9-\\/])/sprintf("%%%02X", ord(\$1))/ge, \$__s =~ s/ /+/g),
	"$opts{'D'}" && (\$__s =~ s/\\+/ /g, \$__s =~ s/%(..)/chr(hex(\$1))/ge),
	sprintf("%${format}s", \$__s))[-1]
EOM
}

sub PictureD {
	my ($self, $param) = @_;
	unless ($param =~ s/^\\\((.*?)\\\)//s) {
		$self->Syntax;
	}
	my $format = $1;
	unless ($param =~ s/^\\\.\\(["'])(.*?)\\\1$//s) {
		$self->Syntax;
	}
	my $date = $2;

	<
(require Time::Local,
("$date") =~ /^(\\d{4})(\\d{2})(\\d{2})(\\d{2})(\\d{2})(\\d{2})\$/,
	\$__t = Time::Local::timelocal(\$6, \$5, \$4, \$3, \$2 - 1, \$1 - 1900),
	HTML::Merge::Engine::time2str("$format", \$__t))[-1]

EOM
}

sub PictureX {
	my ($self, $param) = @_;
	unless ($param =~ s/^\\\((.*?)\\\)//s) {
		$self->Syntax;
	}
	my $times = $1;
	unless ($param =~ s/^\\\.\\(["'])(.*?)\\\1$//s) {
		$self->Syntax;
	}
	my $text = $2;
	<
(HTML::Merge::Engine::Force("$times", 'ui'),
	"$text" x "$times")[-1]
EOM
}

sub DoINC {
        my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.(.*?)(\\[+-]\d+)?$/s) {
		$self->Syntax;
	}
	my ($var, $step) = ($1, defined($2) ? $2 : 1);
	<
HTML::Merge::Engine::Force("$step", "n");
HTML::Merge::Engine::Force(\$vars{"$var"}, "n");
\$vars{"$var"} += "$step";
EOM
}

sub DoSTATE {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	"\$engines{\"$engine\"}->State";
}

sub DoEMPTY {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	"\$engines{\"$engine\"}->Empty";
}

sub DoMAIL {
	my ($self, $engine, $param) = @_;
        unless ($param =~ /^\\\.\\(['"])(.*?)\\\1\\([\.,])\\(['"])(.*?)\\\4(.*)$/s) {
		$self->Syntax;
	}
	my $del = quotemeta($3);
	my ($from, $to, $rem, $subject) = ($2, $5, $6);
	if ($rem) {
		unless ($rem =~ /^\\$del\\(['"])(.*?)\\\1$/s) {
			$self->Syntax;
		}
		$subject = $2;
	}
	$self->Push('mail', $engine);
<
	\$__from = "$from";
	\$__from =~ s/^.*\<(.*)\>\$/\$1/;
	\$__from =~ s/^(.*?)\\s+\(\".*\"\)\$/\$1/;
	\$__to = "$to";
	\$__to =~ s/^.*\<(.*)\>\$/\$1/;
	\$__to =~ s/^(.*?)\\s+\(\".*\"\)\$/\$1/;
	use HTML::Merge::Mail;
	eval '\$__mail = OpenMail(\$__from, \$__to, \$HTML::Merge::Ini::SMTP_SERVER);';

	HTML::Merge::Error::HandleError('WARN', 'Mail failed: \$\@') if \$\@;
	\$__prev = select \$__mail;

	print "From: $from\\r\\n";
	print "To: $to\\r\\n";
	print "Subject: $subject\\r\\n";
	print "X-Mailer: Merge v. $VERSION (c) http://www.raz.co.il\\r\\n";
	print "\\r\\n";
EOM
}
sub DoUnMAIL {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'mail');
	<
	eval ' CloseMail(\$__mail); ';
        HTML::Merge::Error::HandleError('WARN', 'Mail failed: \$\@') if \$\@;
	select \$__prev;
EOM
}
#####################################
sub DoDB
{
	my ($self, $engine, $param) = @_;

	my ($type, $db, $host);
	my ($dsn,$dsn1, $user, $pass);

	$INTERNAL_DB="dbname=$HTML::Merge::Ini::MERGE_ABSOLUTE_PATH/merge.db";

	unless ($param =~ /^\\[\.=]\\(['"])(.*?)\\\1$/s)
	{
		$self->Syntax;
	}

	$dsn = $2;
	($dsn1, $user, $pass) = split(/\s*\\,\s*/, $dsn);

	unless ($dsn1)
	{
		$self->Die("DSN not specified");
	}

	for($dsn)
	{
		if(/^SYSTEM$/)
		{
			if($HTML::Merge::Ini::SESSION_DB)
			{
				$type = $HTML::Merge::Ini::DB_TYPE;
				$db = $HTML::Merge::Ini::SESSION_DB;
				$host = $HTML::Merge::Ini::DB_HOST;
				$user = $HTML::Merge::Ini::DB_USER;
				$pass = $HTML::Merge::Ini::DB_PASSWORD;
			}
			else
			{
				$type=$INTERNAL_DB_TYPE;
				$db="$INTERNAL_DB";
			}
			last;
		}
		if(/^DEFAULT$/)
		{
			$type = $HTML::Merge::Ini::DB_TYPE;
			$db = $HTML::Merge::Ini::DB_DATABASE;
			$host = $HTML::Merge::Ini::DB_HOST;
			$user = $HTML::Merge::Ini::DB_USER;
			$pass = $HTML::Merge::Ini::DB_PASSWORD;
			last;
		}
		else
		{
			$dsn1 =~ s/^dbi\\://;
			($type, $db, $host) = split(/\\:/, $dsn1);
			($type, $db) = (undef, $type) unless ($db);
			last;
		}
	}

	<
\$engines{"$engine"}->Preconnect("$type", "$db", "$host", "$user", "$pass");
EOM
}
#####################################
sub DoDISCONNECT {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	qq!delete \$engines{"$engine"};!;
}

sub DoEXIT {
	my ($self, $engine, $param) = @_;
	$self->Die if $param;
	"die 'STOP_ON_ERROR';\n";
}

sub DoLOGIN {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[\.=]\\(['"])(.*?)\\\1\\\,\\(['"])(.*?)\\\3$/s) {
		$self->Syntax;
	}
	my ($user, $pass) = ($2, $4);
	qq!\$engines{"$engine"}->Login("$user", "$pass")!;
}

sub DoCHPASS {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[\.=]\\(['"])(.*?)\\\1$/s) {
		$self->Syntax;
	}
	qq!\$engines{"$engine"}->ChangePassword("$2");!;
}

sub DoAUTH {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*?)\\\1$/s) {
		$self->Syntax;
	}
	qq!\$engines{"$engine"}->HasKey("$2")!;
}

sub DoADDUSER {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[\.=]\\(['"])(.*?)\\\1\\\,\\(['"])(.*?)\\\3$/s) {
		$self->Syntax;
	}
	my ($user, $pass) = ($2, $4);
	qq!\$engines{"$engine"}->AddUser("$user", "$pass");!;
}

sub DoDELUSER {
        my ($self, $engine, $param) = @_;
        unless ($param =~ /^\\[=\.]\\(['"])(.*?)\\\1$/s) {
                $self->Syntax;
        }
        my ($user) = ($2);
	qq!\$engines{"$engine"}->DelUser("$user");!;
}

sub DoJOIN {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[=\.]\\(['"])(.*?)\\\1\\\,\\(['"])(.*?)\\\3$/s) {
		$self->Syntax;
	}
	my ($user, $group) = ($2, $4);
	qq!\$engines{"$engine"}->JoinGroup("$user", "$group");!;
}

sub DoPART {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[=\.]\\(['"])(.*?)\\\1\\\,\\(['"])(.*?)\\\3$/s) {
		$self->Syntax;
	}
	my ($user, $group) = ($2, $4);
	qq!\$engines{"$engine"}->PartGroup("$user", "$group");!;
}

sub DoGRANT {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[=\.]([UG])\\\.\\(['"])(.*?)\\\2\\\,\\(['"])(.*?)\\\4$/si) {
		$self->Syntax;
	}
	my ($how, $who, $realm) = (uc($1), $3, $5);
	if ($how eq 'U') {
		return qq!\$engines{"$engine"}->GrantUser("$who", "$realm");!;
	}
	if ($how eq 'G') {
		return qq!\$engines{"$engine"}->GrantGroup("$who", "$realm");!;
	}
}

*DoREVOKE = \&DoEVOKE;

sub DoEVOKE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[=\.]([UG])\\\.\\(['"])(.*?)\\\2\\\,\\(['"])(.*?)\\\4$/si) {
		$self->Syntax;
	}
	my ($how, $who, $realm) = (uc($1), $3, $5);
	if ($how eq 'U') {
		return qq!\$engines{"$engine"}->RevokeUser("$who", "$realm");!;
	}
	if ($how eq 'G') {
		return qq!\$engines{"$engine"}->RevokeGroup("$who", "$realm");!;
	}
}

sub DoATTACH {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[=\.]\\(['"])(.*?)\\\1\\\,\\(['"])(.*?)\\\3$/s) {
		$self->Syntax;
	}
	my ($template, $subsite) = ($2, $4);
	qq!\$engines{"$engine"}->Attach("$template", "$subsite");!;
}

sub DoDETACH {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[=\.]\\(['"])(.*?)\\\1\\\,\\(['"])(.*?)\\\3$/s) {
		$self->Syntax;
	}
	my ($template, $subsite) = ($2, $4);
	qq!\$engines{"$engine"}->Detach("$template", "$subsite");!;
}


*DoREQUIRE = \&DoEQUIRE;

sub DoEQUIRE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\[=\.]\\(['"])(.*?)\\\1\\\,\\(['"])(.*?)\\\3$/s) {
		$self->Syntax;
	}
	my ($template, $realms) = ($2, $4);
	qq!\$engines{"$engine"}->Require("$template", "$realms");!;
}

sub DoUSER {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	qq!\$engines{"$engine"}->GetUser!;
}

sub DoNAME {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	qq!scalar(\$engines{"$engine"}->GetUserName)!;
}

sub DoTAG {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	qq!(\$engines{"$engine"}->GetUserName)[1]!;
}

sub DoMERGE {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	'"$HTML::Merge::Ini::MERGE_PATH/$HTML::Merge::Ini::MERGE_SCRIPT"';
}

sub DoTEMPLATE {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	qq!\$HTML::Merge::template!;
}

sub DoTRANSFER {
	my ($self, $engine, $param) = @_;
	my $validate;
	unless ($param =~ s/^\\\.(.+)$//s) {
		$self->Syntax;
	}
	qq!qq//!;
}

sub DoSUBMIT {
	my ($self, $engine, $param) = @_;
	my $validate;
	if ($param =~ s/^\\\.\\(["'])(.*)\\\1$//s) {
		$validate = " onSubmit=\"$2\"";
	}
	$self->Syntax if $param;
	$self->Push('submit', $engine);
	<
print qq!
!;
EOM
}

sub DoUnSUBMIT {
	my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'submit');
	qq!print "\\n";!;
}

sub DoDECIDE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*?)\\\1\\\?\\(['"])(.*?)\\\3\\\:\\(['"])(.*?)\\\5$/s) {
		$self->Syntax;
	}
	my ($decision, $true, $false) = ($2, $4, $6);
	<
	(
		(eval("$decision") ? "$true" : "$false"),
		\$@ && HTML::Merge::Error::HandleError('ERROR', \$@)
	)[0]
EOM
}

sub DoDATE {
	my ($self, $engine, $param) = @_;
	my $delta = 0;
	if ($param =~ s/^\\[,\.]((?:\\-)?\d+)$//s) {
		$delta = $1;
	}
	$self->Syntax if $param;
	<
(HTML::Merge::Engine::Force("$delta", 'i'),
	\@__t = localtime(time + "$delta" * 3600 * 24),
	sprintf("%04d" . ("%02d" x 5), \$__t[5] + 1900, \$__t[4] + 1,
		\@__t[reverse (0 .. 3)]))[-1]
EOM
}

sub DoDAY {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	qq{substr("$2", 6, 2) * 1};
}

sub DoMONTH {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	qq{substr("$2", 4, 2) * 1};
}

sub DoYEAR {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	qq{substr("$2", 0, 4)};
}

sub DoMINUTE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	qq{substr("$2", 10, 2) * 1};
}

sub DoHOUR {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	qq{substr("$2", 8, 2) * 1};
}


sub DoSECOND {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	qq{substr("$2", 12, 2) * 1};
}

sub DoDATEDIFF {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.([HSMD])\\\.(\\['"])?(.*)\2\\,(\\['"])?(.*)\4$/s) {
		$self->Syntax;
	}
	my ($how, $before, $now) = ($1, $3, $5);
	my %hash = qw(S 1 M 60 H 3600 D 86400);
	my $div = $hash{$how} || 1;
	<
(require Time::Local,
\$__conv = sub { (shift() =~ /^(\\d{4})(\\d{2})(\\d{2})(\\d{2})(\\d{2})(\\d{2})/);
	Time::Local::timelocal(\$6, \$5, \$4, \$3, \$2 - 1, \$1 - 1900); },
int((&\$__conv("$now") - &\$__conv("$before")) / $div))[-1]
EOM
}

sub DoDATE2UTC {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	<
(require Time::Local,
("$2") =~ /^(\\d{4})(\\d{2})(\\d{2})(\\d{2})(\\d{2})(\\d{2})\$/,
	Time::Local::timelocal(\$6, \$5, \$4, \$3, \$2 - 1, \$1 - 1900))[-1]
EOM
}

sub DoUTC2DATE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/) {
		$self->Syntax if $param;
	}
	<
(HTML::Merge::Engine::Force("$2", 'ui'),
	\@__t = localtime("$2"),
	sprintf("%04d" . ("%02d" x 5), \$__t[5] + 1900, \$__t[4] + 1,
		\@__t[reverse (0 .. 3)]))[-1]
EOM
}

sub DoLASTDAY {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	<
((\$__y, \$__m, \$__d) = ("$2" =~ /^(\\d{4})(\\d{2})(\\d{2})/),
\$__base = (qw(31 28 31 30 31 30 31 31 30 31 30 31))[\$__m - 1],
\$__leap = (\$__y % 4) ? 0
	: ((\$__y % 100) ? 1
		: ((\$__y % 400) ? 0 : 1)
	),
\$__base + (\$__m == 2 ? \$__leap : 0))[-1]
EOM
}

sub DoADDDATE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1\\\,\\(['"])(.*)\\\3\\,\\(['"])(.*)\\\5\\,\\(['"])(.*)\\\7$/s) {
		$self->Syntax;
	}
	my ($date, $d, $m, $y) = ($2, $4, $6, $8);
	<
(require Time::Local,
("$date") =~ /^(\\d{4})(\\d{2})(\\d{2})(\\d{2})(\\d{2})(\\d{2})/,
\$__t = Time::Local::timelocal(\$6, \$5, \$4, \$3, \$2 - 1, \$1 - 1900)
	+ 3600 * 24 * "$d",
\@__t = localtime(\$__t),
\$__t[4] += "$m", \$__t[5] += "$y",
\$__t[5] += int(\$__t[4] / 12), \$__t[4] %= 12,
sprintf("%04d" . ("%02d" x 5), \$__t[5] + 1900, \$__t[4] + 1,
                \@__t[reverse (0 .. 3)]))[-1]
EOM
}

sub DoDIVERT {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	my $fn = $2;
	$self->Push('divert', $engine);
	<
	push(\@__diverts, select);
	use Symbol;
	\$__sym = gensym;
	open(\$__sym, ">>/tmp/merge-\$\$-$fn.divert") || die \$!;
	select \$__sym;
	push(\@HTML::Merge::cleanups, eval qq!sub { unlink "/tmp/merge-\$\$-$fn.divert" }!);
EOM
	# Value of $fn might contain merge variables, that might change
	# until cleanup time. Therefore compile cleanup function
	# with the filename as part of the source.
}

sub DoUnDIVERT {
	my ($self, $engine, $param) = @_;
	$self->Syntax if $param;
	$self->Expect($engine, 'divert');
	<
	\$__sym = select;
	select pop \@__diverts;
	close \$__sym;
EOM
}

sub DoDUMP {
	my ($self, $engine, $param) = @_;
	unless ($param =~ /^\\\.\\(['"])(.*)\\\1$/s) {
		$self->Syntax;
	}
	my $fn = $2;
	<
(open(DIVERT_DUMP, "/tmp/merge-\$\$-$fn.divert") || die(\$!), join("", ),
	close(DIVERT_DUMP))[1]
EOM
}

*DoCGET = *DoCVAR = \&DoCOOKIE;

sub DoCOOKIE {
	my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.*)$//s) {
		$self->Syntax;
	}
	"\$engines{\"$engine\"}->GetCookie(\"$1\")";
}

*DoCSET = \&DoCOOKIESET;

sub DoCOOKIESET {
        my ($self, $engine, $param) = @_;
	unless ($param =~ s/^\\\.(.*?)\\=\\(['"])(.*?)\\\2((?:\\,.*)?)$//s) {
		$self->Syntax;
	}
	my $expire = substr($4, 2);
	"\$engines{\"$engine\"}->SetCookie(\"$1\", eval(\"$3\"), \"$expire\");";
}

sub DoSOURCE {
        my ($self, $engine, $param) = @_;
	my $file = '$HTML::Merge::template';
	if ($param =~ s/^\\\.\\(['"])(.*)\\\1$//s) {
		$file = $2;
	}
	$self->Syntax if $param;
	$self->Push('source', $engine);
	qq!'
1971
	 HTML::Merge::Development::MakeLink('printsource.pl', "template=$file")
		. '" TITLE="view source">'!;
}

sub DoUnSOURCE {
        my ($self, $engine, $param) = @_;
	$self->Expect($engine, 'source');
	qq!""!;
}

sub safecreate {
        my @tokens = split(/\//, shift);
        pop @tokens;
        my $dir;
        foreach (@tokens) {
                $dir .= "/$_";
                mkdir $dir, 0755;
        }
}
#####################################
sub CompileFile
{
	my ($file, $out, $sub) = @_;

	my $tmp;
	open(I, $file) || die "Cannot open $file: $!";
	my $text = join("", );
	close(I);

	open(O, ">$out") || die "Can't write $out: $!";
	my $prev = select O;

	unless ($sub) {
		print $Config{'startperl'}, "\n";
		print <<'EOM';
	use HTML::Merge::Engine;
	use HTML::Merge::Error;
	no strict;
	sub getvar ($) {
		$vars{shift()};
	}
	sub setvar ($$) {
		$vars{$_[0]} = $_[1];
	}
	sub incvar ($$) {
		$vars{$_[0]} += $_[1];
	}
	sub getfield ($;$) {
		my ($field, $engine) = @_;
		$engines{$engine}->Var($field);
	}
	sub merge ($) {
		my $code = shift;
		require HTML::Merge::Compile;
		my $text;
		eval { $text = HTML::Merge::Compile::Compile($code, __FILE__); };
		HTML::Merge::Error::HandleError('ERROR', $@) if $@;
		eval $text;
		HTML::Merge::Error::HandleError('ERROR', $@) if $@;
	}
	sub dbh () {
		$engines{""}->{'dbh'};
	}
	sub register ($) {
		push(@HTML::Merge::cleanups, shift);
	}

	if (tied(%engines)) {
		undef %engines;
		untie %engines;
	}

	tie %engines, HTML::Merge::Engine;
	use CGI qw/:standard/;
	@keys = param();
	%vars = ();
	foreach (@keys) {
		$vars{$_} = param($_);
	}
=line
	$tmp = HTML::Merge::Compile::CgiParse();
	foreach (keys(%$tmp))
	{
		print "$_\t:\t",$tmp->{$_},"\n";
	}

	%vars = %$tmp;
=cut
	unless ($HTML::Merge::Ini::TEMPLATE_CACHE) {

EOM
		print "\t\trequire '$HTML::Merge::config';\n\t}\n";
	}

	eval {
		print &Compile($text, $file);
	};
	my $code = $@;

	unless ($sub) {
		print <<'EOM';
	HTML::Merge::Engine::DumpSuffix;
	untie %engines;

	1;
EOM
	}

	select $prev;
	close(O);
	die $code if $code;
	chmod 0755, $out;

}

sub Syntax {
	my $self = shift;
	&DB::Syntax($self);
}


package DB;

sub Syntax {
	my $self = shift;
	my $step = 0;
	my $sub;
	my $pkg = ref($self);
	for (;;) {
		$step++;
		my @c = caller($step);
		$sub = $c[3];
		last if $sub =~ s/^(.*)::Do// && UNIVERSAL::isa($self, $1);
	}
	$self->Die("Syntax error on $sub: $DB::args[2]");
}


package HTML::Merge::Ext;

sub Macro {
	my $text = shift;
	$text =~ s/(?

	$HTML::Merge::Ext::COMPILER->Macro($text);
	return "";
}

1;