File Coverage

lib/HTML/Filter/Callbacks/Tag.pm

Criterion	Covered	Total	%
statement	124	126	98.4
branch	47	60	78.3
condition	21	34	61.7
subroutine	19	19	100.0
pod	15	15	100.0
total	226	254	88.9

package HTML::Filter::Callbacks::Tag;

use strict;
use warnings;
use HTML::Entities;

sub new {
  my ($class, %args) = @_;

  bless {}, $class;
}

sub set {
  my ($self, $tokens, $org, $skipped_text) = @_;

  my ($name, @attrs) = @$tokens;
  if (@attrs >= 2 and $attrs[-1] eq '/' and $attrs[-2] eq '/') {
    splice @attrs, -2, 2;
  }

  %$self = (
    name       => $name,
    attrs      => \@attrs,
    org        => $org,
    skipped    => $skipped_text,
    prepend    => '',
    append     => '',
    is_dirty   => 0,
    is_removed => 0,
    is_end     => (substr($org, 0, 2) eq '
    is_empty   => (substr($org, -2, 2) eq '/>' ? 1 : 0),
  );
}

sub name { shift->{name} }

sub as_string {
  my $self = shift;

  return unless $self->{name};

  my $out = '';
  if (defined $self->{skipped} and length $self->{skipped}) {
    $out .= $self->{skipped};
  }
  if (defined $self->{prepend} and length $self->{prepend}) {
    $out .= $self->{prepend};
  }
  unless ($self->{is_dirty}) {
    $out .= $self->{org};
  }
  else {
    unless ($self->{is_removed}) {
      $out .= '<';
      $out .= '/' if $self->{is_end};
      $out .= $self->{name};
      my @attrs = @{ $self->{attrs} };
      while (my ($key, $value) = splice @attrs, 0, 2) {
        $out .= " $key=$value" unless $key eq '/';
      }
      $out .= ' /' if $self->{is_empty} && substr($self->{name}, -1, 1) ne '/';
      $out .= '>';
    }
  }
  if (defined $self->{append} and length $self->{append}) {
    $out .= $self->{append};
  }
  return $out;
}

sub remove_tag {
  my $self = shift;

  $self->{is_removed} = 1;
  $self->{is_dirty} = 1;
}

sub remove_text_and_tag {
  my $self = shift;

  $self->{is_removed} = 1;
  $self->{skipped} = '';
  $self->{is_dirty} = 1;
}

sub remove_text {
  my $self = shift;

  $self->{skipped} = '';
}

sub remove_attr {
  my ($self, $cond) = @_;

  return unless $self->{attrs};
  return unless defined $cond and length $cond;

  $cond = qr/^$cond$/i unless ref $cond;

  my $offset = scalar @{ $self->{attrs} };
  while ($offset > 0) {
    if ($self->{attrs}->[$offset - 2] =~ /$cond/) {
      splice @{ $self->{attrs} }, $offset - 2, 2;
    }
    $offset -= 2;
  }
  $self->{is_dirty} = 1;
}

sub replace_attr {
  my ($self, $cond, $code_or_value) = @_;

  return unless $self->{attrs};
  return unless defined $cond and length $cond;

  $cond = qr/^$cond$/i unless ref $cond;

  my $offset = scalar @{ $self->{attrs} };
  while ($offset > 0) {
    if ($self->{attrs}->[$offset - 2] =~ /$cond/) {
      my ($value, $quote) = $self->_remove_quote($self->{attrs}->[$offset - 1]);

      if (ref $code_or_value eq 'CODE') {
        local $_ = $value;
        $value = $code_or_value->($_);
      }
      else {
        $value = $code_or_value;
      }
      $value = '' unless defined $value;
      $value = encode_entities($value, q/<>&'"/);
      if ($quote) {
        $value = "$quote$value$quote";
      }
      $self->{attrs}->[$offset - 1] = $value;
    }
    $offset -= 2;
  }
  $self->{is_dirty} = 1;
}

sub replace_tag {
    my ($self, $new_name) = @_;

    $self->{name}     = $new_name;
    $self->{is_dirty} = 1;
}

sub _remove_quote {
  my ($self, $value) = @_;
  my $open  = substr($value,  0, 1);
  my $close = substr($value, -1, 1);
  my $quote;
  if ($open eq $close and ($open eq q/'/ or $open eq q/"/)) {
    $quote = $open;
    $value = substr($value, 1, length($value) - 2);
  }
  $value = decode_entities($value);
  return wantarray ? ($value, $quote) : $value;
}

sub add_attr {
  my ($self, $name, $value) = @_;
  $value = $self->_remove_quote($value);
  $value = encode_entities($value, q/<>&"'/);
  my $offset = scalar @{ $self->{attrs} ||= [] };
  my $replaced;
  while ($offset > 0) {
    if ($self->{attrs}->[$offset - 2] eq $name) {
      $self->{attrs}->[$offset - 1] = qq/"$value"/;
      $replaced = 1;
      last;
    }
    $offset -= 2;
  }
  push @{ $self->{attrs} ||= [] }, $name, qq/"$value"/ unless $replaced;
  $self->{is_dirty} = 1;
}

sub attr {
  my ($self, $name) = @_;

  return unless $self->{attrs};

  $name = lc $name;
  my $offset = scalar @{ $self->{attrs} };
  while ($offset > 0) {
    if (lc $self->{attrs}->[$offset - 2] eq $name) {
      my $value = $self->_remove_quote($self->{attrs}->[$offset - 1]);
      return decode_entities($value);
    }
    $offset -= 2;
  }
  return;
}

sub prepend {
  my ($self, $html) = @_;

  $self->{prepend} = $html;
}

sub append {
  my ($self, $html) = @_;

  $self->{append} = $html;
}

sub text {
  my $self = shift;
  if (@_) {
    $self->{skipped} = shift;
  }
  $self->{skipped};
}

1;

__END__