File Coverage

blib/lib/HTML/Element/Tiny.pm

Criterion	Covered	Total	%
statement	218	239	91.2
branch	57	74	77.0
condition	25	38	65.7
subroutine	60	67	89.5
pod	18	18	100.0
total	378	436	86.7

use strict;
local $^W = 1;

package HTML::Element::Tiny;

use vars qw($VERSION %HAS @TAGS %DEFAULT_CLOSED %DEFAULT_NEWLINE %TAG_CLASS);
$VERSION = '0.006';
use 5.004;
BEGIN {
#  @TAGS =
#      qw( a abbr acronym address area b base bdo big blockquote body br
#      button caption cite code col colgroup dd del div dfn dl dt em
#      fieldset form frame frameset h1 h2 h3 h4 h5 h6 head hr html i
#      iframe img input ins kbd label legend li link map meta noframes
#      noscript object ol optgroup option p param pre q samp script select
#      small span strong style sub sup table tbody td textarea tfoot th
#      thead title tr tt ul var );
  %DEFAULT_CLOSED = map { $_ => 1 }
    qw( area base br col frame hr img input meta param link );
  %DEFAULT_NEWLINE = map { $_ => 1 }
    qw( html head body div p tr table );
  use vars qw(%_modver);
  %_modver = (
    Clone => '0.28',
  );
  for my $module (qw(HTML::Entities Clone)) {
    my $modver = $_modver{$module} || 0;
    $HAS{$module} = eval "use $module $modver (); 1"
      unless defined $HAS{$module};
  }
}

use Scalar::Util ();
use Carp ();

#use overload (
#  q{""} => 'as_string',
#  q{0+} => sub { Scalar::Util::refaddr($_[0]) },
#  fallback => 1,
#);

sub TAG      () { 0 }
sub ID       () { 1 }
sub CLASS    () { 2 }
sub ATTR     () { 3 }
sub CHILDREN () { 4 }

%TAG_CLASS = (
  -text    => "-Text",
  -base    => 'HTML::Element::Tiny',
  -default => 'HTML::Element::Tiny',
);

sub _tag_class {
  my ($class, $tag) = @_;
  my $tag_lookup;
  {
    no strict 'refs';
    if (exists ${$class . '::'}{TAG_CLASS}
      and *{${$class . '::'}{TAG_CLASS}}{HASH}) {
      $tag_lookup = \%{$class . '::TAG_CLASS'};
      # XXX should this really be the case? it seems like a very sane default.
      $tag_lookup->{-base}    ||= $class;
      $tag_lookup->{-default} ||= $class;
    } else {
      $tag_lookup = {};
    }
  }
  my $tag_class;
  for my $href ($tag_lookup, \%TAG_CLASS) {
    if ($tag_class = $href->{$tag}) {
      $tag_class =~ s/^-/$href->{-base}::/;
      last;
    }
  }
  $tag_class ||= $tag_lookup->{-default} || $TAG_CLASS{-default};

  return $tag_class;
}

sub new {
  my ($class, $arg, $extra) = @_;
  unless (ref $arg) {
    return bless \$arg => _tag_class($class, '-text');
  }
  Carp::confess "no tag: @$arg" unless @$arg;
  my $tag = shift @$arg;
  my $attr = ref $arg->[0] eq 'HASH' ? shift @$arg : {};
  @{$attr}{keys %$extra} = (values %$extra) if $extra;
  my $self = bless [
    $tag,
    delete $attr->{id},
    [ split /\s+/, delete $attr->{class} || '' ],
    $attr,
    [ ],
  ] => _tag_class($class, $tag);
  Scalar::Util::weaken($self->[ATTR]->{-parent})
    if $self->[ATTR]->{-parent};
  @{$self->[CHILDREN]} = map { $class->new($_, { -parent => $self }) } @$arg;
  return $self;
}

sub children { @{$_[0]->[CHILDREN]} }
sub parent   { $_[0]->[ATTR]->{-parent} }
sub tag      { $_[0]->[TAG] }
sub id       { $_[0]->[ID] }
sub class    { join " ", @{$_[0]->[CLASS]} }
sub classes  { @{$_[0]->[CLASS]} }

# _match needs to use accessors despite being internal because it may touch
# non-arrayref subclasses like -Text
sub _match {
  my ($self, $spec) = @_;
  return (
    (defined $spec->{id}  ? $spec->{id}  eq ($self->id || '') : 1) &&
    ($spec->{-tag} ? $spec->{-tag} eq ($self->tag)      : 1) &&
    ($spec->{class} ? (
      # 'there are no parts of $spec->{class} that do not have a matching
      # entry in $self->classes' -- easier than saying all/all
      ! grep {
        my $c = $_;
        ! grep { $_ eq $c } $self->classes
      } split /\s+/, $spec->{class}
    ) : 1) &&
    (! grep {
      $_ ne 'id' and $_ ne '-tag' and $_ ne 'class' and
      $spec->{$_} ne ($self->attr($_) || '')
    } keys %$spec)
  );
}

sub _spec_to_str {
  my $spec = shift;
  return join " ", map { "$_=$spec->{$_}" } sort keys %$spec;
}

sub _iter (&) { bless $_[0] => 'HTML::Element::Tiny::Iterator' }
sub _coll (@) { HTML::Element::Tiny::Collection->new(@_) }

sub find_iter {
  my ($self, $spec) = @_;
  my $iter = $self->iter;
  return _iter {
    {
      return unless defined(my $next = $iter->next);
      redo unless $next->_match($spec);
      return $next;
    }
  };
}

sub find {
  my ($self, $spec) = @_;
  # id should short-circuit
  return grep( { defined && length } $spec->{id} )
    ? _coll($self->find_iter($spec)->next)
    : $self->all->filter($spec);
}

sub find_one {
  my ($self, $spec) = @_;
  my $iter = $self->find_iter($spec);
  my $elem = $iter->next;
  unless ($elem) {
    Carp::croak "no element found for " . _spec_to_str($spec);
  }
  if (my $next = $iter->next) {
    Carp::croak "not exactly one element: found $elem, $next";
  }
  return $elem;
}

sub all {
  return _coll($_[0]->_all);
}

sub _all {
  my $self = shift;
  return $self, map({ $_->_all } $self->children );
}

sub iter {
  my $self = shift;
  my @queue = $self;
  return _iter {
    return unless @queue;
    my $next = shift @queue;
    unshift @queue, $next->children;
    return $next;
  };
}

sub attr {
  my ($self, $arg) = @_;
  if (ref $arg eq 'HASH') {
    while (my ($k, $v) = each %$arg) {
      if ($k eq 'id')       { $self->[ID] = $v }
      elsif ($k eq 'class') { @{$self->[CLASS]} = split /\s+/, $v; }
      else                  { $self->[ATTR]->{$k} = $v; }
    }
    return $self;
  } elsif (not ref $arg) {
    return $self->[ID]  if $arg eq 'id';
    return $self->class if $arg eq 'class';
    return $self->[ATTR]->{$arg};
  }
  Carp::croak "invalid argument to attr(): '$arg' (must be hashref or scalar)";
}

sub _Clone_clone {
  my ($self, $extra) = @_;
  my $clone = Clone::clone($self);
  delete $clone->[ATTR]->{-parent};
  $clone->attr($extra) if $extra and %$extra;
  return $clone;
}

sub _my_clone {
  my ($self, $extra) = @_;
  my %attr = %{$self->[ATTR]};
  delete $attr{-parent};
  my $clone = bless [
    $self->[TAG],
    $self->[ID],
    [ $self->classes ],
    { %attr, %{$extra || {}} },
    [],
  ] => ref $self;
  $clone->append($self->children);
  return $clone;
}

my $clone_type = sprintf "_%s_clone", (grep { $HAS{$_} } qw(Clone))[0] || 'my';
sub clone {
  my ($self, $extra) = @_;
  my $clone = do { no strict 'refs'; &$clone_type($self, $extra) };

  Scalar::Util::weaken($clone->[ATTR]->{-parent})
    if $clone->[ATTR]->{-parent};
  return $clone;
}

sub _new_children {
  my $self = shift;
  return map {
    Scalar::Util::blessed($_)
      ? $_->parent
        ? $_->clone({ -parent => $self })
        : $_->attr({ -parent => $self })
      : ref($self)->new($_, { -parent => $self })
  } @_;
}

sub prepend {
  my $self = shift;
  unshift @{ $self->[CHILDREN] }, $self->_new_children(@_);
}

sub append {
  my $self = shift;
  push @{ $self->[CHILDREN] }, $self->_new_children(@_);
}

sub remove_child {
  my $self = shift;
  my (%idx, %obj);
  for (@_) {
    if (Scalar::Util::blessed($_)) {
      $obj{Scalar::Util::refaddr($_)}++;
    } else {
      $idx{$_}++;
    }
  }
  my @children;
  my @removed;
  for my $i (0..$#{$self->[CHILDREN]}) {
    my $child = $self->[CHILDREN]->[$i];
    if ($idx{$i} or $obj{Scalar::Util::refaddr($child)}) {
      $child->attr({ -parent => undef });
      push @removed, $child;
    } else {
      push @children, $child;
    }
  }
  $self->[CHILDREN] = \@children;
  return _coll(@removed);
}

sub as_HTML {
  my ($self, $arg) = @_;
  $arg ||= {};
  my $str = "<$self->[TAG]";
  for ( sort grep { !/^-/ } keys %{$self->[ATTR]}, qw(id class) ) {
    my $val = $self->attr($_);
    $str .= qq{ $_="} . $self->attr($_) . qq{"}
      if defined $val and ($_ ne 'class' or length($val));
  }
#  $str .= qq{ id="$self->[ID]"} if $self->[ID];
#  $str .= qq{ class="} . $self->class . qq{"} if @{$self->classes};
#  $str .= qq{ $_="$self->[ATTR]->{$_}"}
#    for sort grep { !/^-/ } keys %{$self->[ATTR]};
  if ($DEFAULT_CLOSED{$self->[TAG]}) {
    $str .= ' />';
  } else {
    $str .= '>' . join("", map { $_->as_HTML } $self->children);
    $str .= "[TAG]>";
  }
  $str .= "\n" if $DEFAULT_NEWLINE{$self->[TAG]};
  return $str;
}

#sub as_string {
#  my ($self) = @_;
#  my $str = $self->tag;
#  $str .= qq{ id="} . $self->id . q{"} if $self->id;
#  $str .= qq{ class="} . $self->class . q{"} if $self->classes;
#  return "<$str>";
#}

package HTML::Element::Tiny::Text;

BEGIN { use vars qw(@ISA); @ISA = 'HTML::Element::Tiny' }

sub children { return () }
sub _all     { return $_[0] }
sub tag      { '-text' }
sub parent   { return () }
sub id       { return }
sub class    { return }
sub classes  { return () }
sub attr     { return ref $_[1] ? $_[0] : (); }
sub clone    { return $_[0] }
sub append   { die "unimplemented" }
sub remove_child { die "unimplemented" }

my %ENT_MAP = (
  '&' => '&',
  '<' => '<',
  '>' => '>',
  '"' => '"',
  "'" => ''',
);

sub as_HTML {
  return HTML::Entities::encode_entities(${$_[0]})
    if $HTML::Element::Tiny::HAS_HTML_ENTITIES;
  my $str = ${$_[0]};
  $str =~ s/([<>&'"])/$ENT_MAP{$1}/eg;
  return $str;
}

package HTML::Element::Tiny::Iterator;

sub next { $_[0]->() }

package HTML::Element::Tiny::Collection;

sub new {
  my $class = shift;
  my $self = bless [ @_ ] => ref $class || $class;
  return wantarray ? @$self : $self;
}

sub size { scalar @{$_[0]} }

sub each {
  my ($self, $code) = @_;
  for (@$self) { $code->() }
  return $self;
}

sub one {
  my $self = shift;
  Carp::croak "not exactly one element (@$self)" unless @$self == 1;
  return $self->[0];
}

sub all { @{$_[0]} }

sub map {
  my ($self, $code) = @_;
  return map { $code->() } @$self;
}

sub filter {
  my ($self, $spec) = @_;
  return $self->new(grep { $_->_match($spec) } @$self);
}

BEGIN { *grep = \&filter }

sub not {
  my ($self, $spec) = @_;
  return $self->new(grep { ! $_->_match($spec) } @$self);
}

sub attr {
  my ($self, $arg) = @_;
  return ref $arg
    ? $self->each(sub { $_->attr($arg) })
    : $self->map(sub { grep { defined && length } $_->attr($arg) })
  ;
}

1;
__END__