File Coverage

blib/lib/HTML/LoL.pm

Criterion	Covered	Total	%
statement	107	123	86.9
branch	36	48	75.0
condition	19	36	52.7
subroutine	20	21	95.2
pod	4	11	36.3
total	186	239	77.8

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, "", $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__