package HTML::LoL::Special;
sub new {
my($type, $str) = @_;
bless \$str, $type;
}
package HTML::LoL;
use strict;
use base 'Exporter';
use vars qw(@ISA @EXPORT $VERSION);
$VERSION = '1.3';
@EXPORT = qw(hl hl_noquote hl_requote hl_entity hl_bool hl_preserve);
use constant TABWIDTH => 8;
use HTML::Entities;
use HTML::Tagset;
my $hl_bool_yes = new HTML::LoL::Special('bool_yes');
my $hl_bool_no = new HTML::LoL::Special('bool_no');
my $hl_noquote = new HTML::LoL::Special('noquote');
my $hl_requote = new HTML::LoL::Special('requote');
my $hl_preserve = new HTML::LoL::Special('preserve');
sub is_bool_yes {
my $x = shift;
return UNIVERSAL::isa($x, 'HTML::LoL::Special') && ($$x eq 'bool_yes');
}
sub is_bool_no {
my $x = shift;
return UNIVERSAL::isa($x, 'HTML::LoL::Special') && ($$x eq 'bool_no');
}
sub is_noquote {
my $x = shift;
return UNIVERSAL::isa($x, 'HTML::LoL::Special') && ($$x eq 'noquote');
}
sub is_requote {
my $x = shift;
return UNIVERSAL::isa($x, 'HTML::LoL::Special') && ($$x eq 'requote');
}
sub is_preserve {
my $x = shift;
return UNIVERSAL::isa($x, 'HTML::LoL::Special') && ($$x eq 'preserve');
}
# elements inside which it is OK to add whitespace
my %hl_wsok;
map { $hl_wsok{$_} = 1 } qw(area col colgroup frame frameset
head html object table tr);
# elements whose layout should not be altered
my %hl_pre;
map { $hl_pre{$_} = 1 } qw(pre style script textarea);
sub _emit {
my($cb, $str, $columnref) = @_;
my $result = &$cb($str);
if ($str =~ /.*\n([^\n]*)$/s) {
$str = $1;
$$columnref = 0;
}
my @s = split(/\t/, $str);
foreach my $s (@s) {
$$columnref += length($s);
}
if (@s > 1) {
$$columnref += (TABWIDTH * (@s - 1));
$$columnref = int($$columnref / TABWIDTH);
++$$columnref;
$$columnref *= TABWIDTH;
}
return $result;
}
sub _str {
my($cb, $str, $depth, $columnref, $wsokref, $pre, $noquote) = @_;
my $result;
$str = &encode_entities($str) unless $noquote;
if ($pre) {
$result = &_emit($cb, $str, $columnref);
} else {
my $leading_ws = ($str =~ /^\s/s);
my $trailing_ws = ($str =~ /\s$/s);
$str =~ s/^\s+//s;
$str =~ s/\s+$//s;
my @words = split(/\s+/, $str);
if (@words) {
$$wsokref ||= $leading_ws;
foreach my $word (@words) {
if ($$wsokref) {
if (($$columnref > 0)
&& ((1 + length($word) + $$columnref) > 72)) {
$result = &_emit($cb, ("\n" . (' ' x ($depth + 1))), $columnref);
} else {
$result = &_emit($cb, ' ', $columnref);
}
}
$result = &_emit($cb, $word, $columnref);
$$wsokref = 1;
}
} elsif ($leading_ws || $trailing_ws) {
$result = &_emit($cb, ' ', $columnref);
}
$$wsokref = $trailing_ws;
}
return $result;
}
sub _node {
my($cb, $node, $depth, $columnref, $wsokref, $pre, $noquote) = @_;
my $result;
my @node = @$node;
my $tag = $node[0];
my $empty;
if (&is_noquote($tag)) {
$noquote = 1;
undef $tag;
} elsif (&is_requote($tag)) {
$noquote = 0;
undef $tag;
} elsif (&is_preserve($tag)) {
$pre = 1;
undef $tag;
} else {
$tag = lc($tag);
$empty = $HTML::Tagset::emptyElement{$tag};
$pre ||= $hl_pre{$tag};
}
if ($$wsokref && !$pre) {
$result = &_emit($cb, ("\n" . (' ' x $depth)), $columnref);
}
if (defined($tag)) {
$result = &_emit($cb, "<$tag", $columnref);
foreach my $content (@node[1 .. $#node]) {
next unless ref($content) eq 'HASH';
foreach my $hashitem (keys %$content) {
my $val = $content->{$hashitem};
if (&is_bool_yes($val)) {
$result = &_emit($cb, " $hashitem", $columnref);
} elsif (&is_bool_no($val)) {
# do nothing
} elsif (ref($val) eq 'ARRAY') {
# the caller wants the value interpolated literally
$result = &_emit($cb,
sprintf(' %s=%s', $hashitem, $val->[0]),
$columnref);
} else {
$result = &_emit($cb,
sprintf(' %s="%s"', $hashitem,
&encode_entities($val)),
$columnref);
}
}
}
$result = &_emit($cb, ">", $columnref);
$$wsokref = $hl_wsok{$tag};
}
foreach my $content (@node[1 .. $#node]) {
my $ref = ref($content);
next if ($ref eq 'HASH');
if ($ref eq 'ARRAY') {
$result = &_node($cb, $content, $depth + 1, $columnref, $wsokref,
$pre, $noquote);
} else {
$result = &_str($cb, $content, $depth + 1, $columnref, $wsokref,
$pre, $noquote);
}
$$wsokref ||= $hl_wsok{$tag} if defined($tag);
}
if (defined($tag) && !$empty) {
if ($$wsokref) {
$result = &_emit($cb, ("\n" . (' ' x $depth)), $columnref);
}
$result = &_emit($cb, "</$tag>", $columnref);
$$wsokref = 0;
}
return $result;
}
sub hl {
my $cb = $_[0];
my $column = 0;
my $wsok = 0;
my $result;
foreach my $elt (@_[1 .. $#_]) {
if (ref($elt)) {
$result = &_node($cb, $elt, 0, \$column, \$wsok, 0, 0);
} else {
$result = &_str($cb, $elt, 0, \$column, \$wsok, 0, 0);
}
}
return $result;
}
sub hl_noquote { [$hl_noquote => @_]; }
sub hl_requote { [$hl_requote => @_]; }
sub hl_preserve { [$hl_preserve => @_]; }
sub hl_entity { [$hl_noquote => map { "&$_;" } @_]; }
sub hl_bool { $_[0] ? $hl_bool_yes : $hl_bool_no }
1;
__END__
=head1 NAME
HTML::LoL - construct HTML from pleasing Perl data structures
=head1 SYNOPSIS
use HTML::LoL;
&hl(sub { print shift },
[body => {bgcolor => 'white'},
[p => 'Document body', ...], ...]);
See EXAMPLE section below.
=head1 DESCRIPTION
This module allows you to use Perl syntax to express HTML. The function
C<hl()> converts Perl list-of-list structures into HTML strings.
The first argument to C<hl()> is a callback function that's passed one
argument: a fragment of generated HTML. This callback is invoked repeatedly
with successive fragments until all the HTML is generated; the callback is
responsible for assembling the fragments in the desired output location (e.g.,
a string or file).
The remaining arguments to C<hl()> are Perl objects representing HTML,
as follows:
=over 4
=item [B<TAG>, ...]
B<TAG> is a string (the name of an HTML element); remaining list items are any
of the forms described herein. Corresponds to
E<lt>B<TAG>E<gt>...E<lt>/B<TAG>E<gt>. If B<TAG> is an "empty element"
according to C<%HTML::Tagset::emptyElement>, then the E<lt>/B<TAG>E<gt> is
omitted.
=item [B<TAG> => {B<ATTR1> => B<VAL1>, B<ATTR2> => B<VAL2>, ...}, ...]
Corresponds to E<lt>B<TAG> B<ATTR1>="B<VAL1>" B<ATTR2>="B<VAL2>"
...E<gt>...E<lt>/B<TAG>E<gt>.
(As above, E<lt>/B<TAG>E<gt> is omitted if B<TAG> is an "empty element.")
Each B<ATTR> is a string. Each B<VAL> is
either a string, in which case the value gets HTML-entity-encoded when copied
to the output, or a list reference containing a single string (viz. [B<VAL>])
in which case the value is copied literally.
Finally, for boolean-valued attributes, B<VAL> may be C<hl_bool(BOOLEAN)>,
where BOOLEAN is a Perl expression. If BOOLEAN is true, the attribute is
included in the output; otherwise it's omitted.
=item Any string
Strings are copied verbatim to the output after entity-encoding.
=item C<hl_noquote(...)>
Suppresses entity-encoding of its arguments.
=item C<hl_requote(...)>
Reenables entity-encoding of its arguments (use it inside a call to
C<hl_noquote()>).
=item C<hl_preserve(...)>
Normally, HTML::LoL tries to optimize the whitespace in the HTML it emits
(without changing the meaning of the HTML). This suppresses that behavior
within its arguments.
=item C<hl_entity(NAME)>
Includes the HTML character-entity named NAME.
=back
The return value of C<hl()> is the result of the last call to the callback
function. This means it's possible to write
&hl(sub { $accumulator .= shift }, ...)
to have C<hl()> return a string containing the completely rendered HTML.
=head1 EXAMPLE
&hl(sub { print shift },
[table => {border => 2, width => '80%'},
[tr =>
[td => {nowrap => &hl_bool(1)}, 'This & that'],
[td => {nowrap => &hl_bool(0)}, '<b>This is not bold</b>'],
[td => [b => 'But this is']],
[td => &hl_noquote('<b>And so is this</b>')]]]);
prints:
<table width="80%" border="2">
<tr>
<td nowrap>This & that</td>
<td><b>This is not bold</b></td>
<td><b>But this is</b></td>
<td><b>And so is this</b></td>
</tr>
</table>
=head1 SEE ALSO
perllol(1), HTML::Tree(3)
This module was inspired by the C<new_from_lol()> function in the
HTML::Tree package by Gisle Aas and Sean M. Burke.
=head1 COPYRIGHT
Copyright 2000-2002 Bob Glickstein.
This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=head1 AUTHOR
Bob Glickstein - http://www.zanshin.com/bobg/ - bobg@zanshin.com