package mkxhtml;

BEGIN {
	use Exporter   ();
	our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
	$VERSION = 0.05;
	@ISA = qw(Exporter);
	@EXPORT = qw(&parse &parsef);
	@EXPORT_OK = qw(%G $trusted &parsep $O $E);
}

our($trusted,%G,$O,$E);

my $maxdepth = 10;
$trusted = 1;
%G = %ENV;
$G{VERSION} = 'mkXhtml '.$VERSION;
$G{VNUM} = $VERSION;
$G{FILENAME} = undef;

sub mkfileh ;

$O = mkfileh '>-';
$E = mkfileh '>&STDERR';

sub parse;  #parse and print out the argument
sub parsef; #file
sub parsep; #parse paragraph argument

=info


Changelog:

0.05 20051028
	Added error correction in the parse function
	Added $O and $E instead of using STDOUT and STDERR

=cut

sub parset; #parse list

sub mkfileh {
	my $f = shift;
	return $f if ref $f;
	open my $h, $f or die "Cannot open $f: $!";
	return $h;
}

sub comment {
	return if $G{QUIET};
	my @i = @_;
	print $O '<!--';
	s/--/- -/g,print $O $_ for @i;
	print $O '-->';
}

sub error {
	print $E @_,"\n";
	return if $G{QUIET};
	my @i = @_;
	print $O '<!--';
	s/--/- -/g,print $O $_ for @i;
	print $O '-->';			
}

sub sspace {
	local $_ = shift;
	s/ /#7/g;
	$_;
}

sub mktag {
	local $_ = shift;
	s/\\ /#7/g;
	s/(".*?")/sspace $1/eg;
	my ($t,@r) = split / /;
	$t = 'p' unless defined $t && $t ne '';
	my @cls;
	my $o = '<'.$t;
	$o .= ' id="'.(shift @r).'"' if ($r[0] && !($r[0] =~ /^\.|=/));
	for (@r) { 
		if (/=/) {
			$o .= " $_"
		} else {
			s/^\.//;
			push @cls, $_;
		}
	}
	$o .= ' class="'.join(' ',@cls).'"' if @cls;
	(unhash($o),"</$t>");
}

sub parse {
	local $_ = shift;
	s/#/#0/g;
	s/\\\\/#9/g;
	s/\\{/#1/g;
	s/\\;/#2/g;
	s/\\}/#3/g;
	s/\\\[/#4/g;
	s/\\\]/#5/g;
	s/\\\$/#6/g;
	s/\\&/#8/g;
	s/\\>/#a/g;
	s/\\</#b/g;
	my @l = split /([\[\$\]{;}])/;
	comment join '~~', @l if $G{DEBUG_SPLIT};
	parset \@l, @_;
}

sub revhash {
	local $_ = shift;
	s/#1/\\{/g;
	s/#2/\\;/g;
	s/#3/\\}/g;
	s/#4/\\[/g;
	s/#5/\\]/g;
	s/#6/\\\$/g;
	s/#7/\\ /g;
	s/#8/\\&/g;
	s/#9/\\\\/g;
	s/#a/\\>/g;
	s/#b/\\</g;
	s/#0/#/g;
	$_
}

sub unhash {
	local $_ = shift;
	s/#1/{/g;
	s/#2/;/g;
	s/#3/}/g;
	s/#4/[/g;
	s/#5/]/g;
	s/#6/\$/g;
	s/#7/ /g;
	s/#8/&amp;/g;
	s/#9/\\\\/g;
	s/#a/&gt;/g;
	s/#b/&lt;/g;
	s/#0/#/g;
	$_
}

sub safeeval {
	return unless $trusted;
	my $eval = shift;
	local ($_,$/,$|,$\,$,,$.,$[,$],%SIG);
	$eval =~ /^([\0-\xff]*)/;
	comment "perl code $1" if $G{DEBUG_PERL};
	eval $1;
	if ($_ = $@) {
		s/<\$[a-z]+>/'$G{FILENAME}'/;
		print $E $_;
	}
}

sub parset {
	my @l = @{+shift};
	my @ts;
	my $n = 0;

	while ($n < @l) {
		$_ = $l[$n++];
		/{/ ? do {
			my $t = $l[$n++];
		#perl and html do not parse the inside
			if ($t eq 'perl' || $t eq 'html') {
				my $p = '';
				my $s = 1;
				$n++ if $l[$n] eq ';';
				while ($s && $n < $#l) {
					my $c = revhash $l[$n++];
					$s++ if $c eq '{';
					$s-- if $c eq '}';
					comment "$s '$c'" if $G{DEBUG_LITERAL};
					$p .= $c if $s;
				}
				$t eq 'perl' ? safeeval $p,@_ : print $O $p;
				next;
			} 

			my ($o,$c) = $t eq '' ? @ts ? @{$ts[0]}[2,3] : ('<p','</p>') : mktag $t;
			my $tse = [$c,';','<span','</span>'];
			
		#self-closing tags are also an exception
			if ($l[$n] eq '}') {
				print $O "$o />";
				$n++;
				next;
			} 
			$o .= '>';
			if ($t =~ /^ul( |$)/) {
				$o .= '<li>';
				@$tse[0,1] = ('</li></ul>','</li><li>');
			} elsif ($t =~ /^table( |$)/) {
				@$tse[1,2,3] = (';','<tr><td','</td></tr>');
			} elsif ($c eq '</td></tr>') {
				$$tse[1] = '</td><td>';
			} elsif ($t =~ /^img( |$)/) {
				$o =~ s/>$/ src="/;
				@$tse[0,1] = ('" />', '" alt="');
			} elsif ($t eq '!') {
				$o = '<!--';
				$tse = ['-->',';','{','}'];
			}
			print $O $o;
			unshift @ts,$tse;
			$n++ if $l[$n] eq ';';
		}: /[]}]/ ? do {
			my $c = shift @ts;
			print $O $$c[0];
			unless (@ts) {
				my ($N,$nws) = $n;
				while (++$N < @l && !$nws) {
					last if $l[$N] eq '{';
					$nws++ if $l[$N] =~ /\S/;
				}
				if ($nws) {
					error "Syntax Error: extra '}' in $G{FILENAME} chunk $.";
					return;
				}
			}
		}: /\[/ ? do {
			my ($link,$rest) = split /\s+/, $l[$n++], 2;
			if ($l[$n] eq ']') {
				unshift @ts, ["$link</a>"];
				$link =~ s/ //;
				$link =~ y/A-Z/a-z/;
			} else {
				unshift @ts, ['</a>',';','<span','</span>'];
				$n++ if $l[$n] eq ';';
			}
			my ($o,$c) = mktag 'a href="'.$link.'" '.(defined $rest ? $rest : '');
			print $O $o.'>';
		}: /;/ ? do {
			print $O $ts[0][1];
		}: /\$/ ? do {
			if ($l[$n] eq '{') {
				$n++;
				my $v = unhash $l[$n++];
				print $O exists $G{$v} ? $G{$v} : '${'.$v.'}';
				$n++ if $l[$n] eq '}';
			} else {
				$l[$n] =~ s/^([A-Za-z0-9_]+)//;
				print $O exists $G{$1} ? $G{$1} : '$'.$1;
			}
		}: print $O unhash $_;
	}
	defined $$_[0] and print $O $$_[0] for @ts;
}

sub parsep {
	my ($lmode);
	local $_ = shift;
	return if /^#[;!]/;
	if (/^(.*?);/) {
		if ($trusted && $1 eq 'import') {
			/;\s+(.*)\n+$/;
			parsef $1;
			return;
		}
		if ($trusted && $1 eq 'include') {
			/;\s+(.*)\n+$/;
			my $h;
			open $h, $1;
			print <$h>;
			return;
		}
	} else {
		$_ = ';'.$_;
	}
	s/(\n+)$/}$1/;
	parse '{'.$_, @_;
}

sub parsef {
	my $oldf = $G{FILENAME};
	my $f = shift;
	unless ($maxdepth--) {
		error "Maximum import depth reached at file $f included from $G{FILENAME}";
	} else {
		local $/ = '';
		$G{FILENAME} = $f unless ref $f;
		my $fh = mkfileh $f;
		parsep $_, @_ while <$fh>;
	}
	$maxdepth++;
	$G{FILENAME} = $oldf;
}

1;