HTML-Merge

 view release on metacpan or  search on metacpan

private/perl/HTML/Merge/Compile.pm  view on Meta::CPAN

#################################
# 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 <<EOM;
		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') 
			{

private/perl/HTML/Merge/Compile.pm  view on Meta::CPAN

	$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)/<!-- GENERATOR: "Merge v. $VERSION (c) Raz Information systems www.raz.co.il" -->\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;

private/perl/HTML/Merge/Compile.pm  view on Meta::CPAN

	$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/(?<!\\)\$(\d+)/\000$_[$1 - 1]\000/g;

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

1;