#!/usr/bin/perl use v5.12; use warnings; use HTML::Entities qw/encode_entities/; use Text::ParseWords qw/quotewords/; # 1 Definitions # 1.1 Global program state my $empty = ''; # currently buffered empty lines my $close = ''; # buffered closing tag for currently opened block element my $postclose = ''; # buffered extra closing tag for opened contiguous element my $opel = ''; # currently opened block element # 1.2 Elements # 1.2.1 Contiguous elements my %ctels = ( Qp => '
{', ); # 1.2.2 Block elements my %blels = ( Hh => '%
}
%
', Pr => '%', Sh => '
\\$1
\\$2',
Cs => '',
Da => '',
Em => '\\$3\\$1\\$2',
Hy => '\\$4\\$1\\$3',
Im => '',
It => '\\$3\\$1\\$2',
St => '\\$3\\$1\\$2',
Tt => '\\$3\\$1\\$2',
Ul => '\\$3\\$1\\$2',
);
# 1.3 Subroutines
# 1.3.1 Handle element request
sub request {
my ($el, $args) = @_;
my @argv = quotewords('\s+', 0, $args);
my $n = @argv;
if (exists $blels{$el} or exists $ctels{$el}) {
# Clear empty line buffer
$empty = '';
# Close currently open block element, open new
my ($base, $prestart, $newpostclose) = ('', '', '');
if (exists $ctels{$el}) {
$base = $ctels{$el};
$prestart = prestart($base);
$newpostclose = postclose($base);
$base = inner($base);
} else {
$base = $blels{$el};
}
my $start = start($base);
my $newclose = interpol(_close($base), @argv) . "\n";
print $close;
$close = $newclose;
print $postclose if $el ne $opel;
$postclose = $newpostclose;
print $prestart if $el ne $opel;
print interpol($start, @argv) . "\n";
$opel = $el;
} elsif (exists $inels{$el}) {
print interpol($inels{$el}, @argv) . "\n";
} else {
print STDERR "Error: $el/$n not implemented\n";
exit 1;
}
}
# 1.3.2 Interpolate \$n parameters
sub interpol {
my $s = shift;
no warnings qw/uninitialized/;
$s =~ s/\\\$(\d+)/$_[$1-1]/g;
return $s;
}
# 1.3.3 Retrieve opening tag of block element string
sub start {
return (split '%', shift)[0];
}
# 1.3.4 Retrieve closing tag of block element string
sub _close {
return (split '%', shift)[1];
}
# 1.3.5 Retrieve extra opening tag of block element string
sub prestart {
return (split '{', shift)[0];
}
# 1.3.6 Retrieve extra closing tag of block element string
sub postclose {
return (split '}', shift)[-1];
}
# 1.3.7 Retrieve inner block of contiguous tag
sub inner {
my $s = shift;
$s =~ s/^.*?\{//;
$s =~ s/}.*?$//;
return $s
}
# 2 Program
# 2.1 Translate source text to HTML
while (<>) {
chomp;
if (/^\.([A-Za-z][a-z])\s*(.*)/) {
request($1, $2);
} elsif ($_ eq '') {
$empty .= "\n";
} else {
print $empty; $empty = '';
print encode_entities($_) . "\n";
}
}
# 2.2 Close currently open block element
print $close;