Test::HTML::Content::NoXPath - HTML::TokeParser fallback for Test::HTML::Content

  # This module is implicitly loaded by Test::HTML::Content
  # if XML::XPath or HTML::Tidy::Simple are unavailable.

    XML::XPath
    HTML::Tidy

package Test::HTML::Content::NoXPath;

require 5.005_62;
use strict;
use File::Spec;
use HTML::TokeParser;

# we want to stay compatible to 5.5 and use warnings if
# we can
eval 'use warnings;' if ($] >= 5.006);
use vars qw( $HTML_PARSER_StripsTags $VERSION @exports );

$VERSION = '0.08';

BEGIN {
  # Check whether HTML::Parser is v3 and delivers the comments starting
  # with the <!--, even though that's implied :
  my $HTML = "<!--Comment-->";
  my $p = HTML::TokeParser->new(\$HTML);
  my ($type,$text) = @{$p->get_token()};
  if ($text eq "<!--Comment-->") {
    $HTML_PARSER_StripsTags = 0
  } else {
    $HTML_PARSER_StripsTags = 1
  };
};

# import what we need
{ no strict 'refs';
  *{$_} = *{"Test::HTML::Content::$_"}
    for qw( __dwim_compare __output_diag __invalid_html );
};

@exports = qw( __match_comment __count_comments __match_text __count_text
               __match __count_tags __match_declaration __count_declarations );

sub __match_comment {
  my ($text,$template) = @_;
  $text =~ s/^<!--(.*?)-->$/$1/ unless $HTML_PARSER_StripsTags;
  unless (ref $template eq "Regexp") {
    $text =~ s/^\s*(.*?)\s*$/$1/;
    $template =~ s/^\s*(.*?)\s*$/$1/;
  };
  return __dwim_compare($text, $template);
};

sub __count_comments {
  my ($HTML,$comment) = @_;
  my $result = 0;
  my $seen = [];

  my $p = HTML::TokeParser->new(\$HTML);
  my $token;
  while ($token = $p->get_token) {
    my ($type,$text) = @$token;
    if ($type eq "C") {
      push @$seen, $token->[1];
      $result++ if __match_comment($text,$comment);
    };
  };

  return ($result, $seen);
};

sub __match_text {
  my ($text,$template) = @_;
  unless (ref $template eq "Regexp") {
    $text =~ s/^\s*(.*?)\s*$/$1/;
    $template =~ s/^\s*(.*?)\s*$/$1/;
  };
  return __dwim_compare($text, $template);
};

sub __count_text {
  my ($HTML,$text) = @_;
  my $result = 0;
  my $seen = [];

  my $p = HTML::TokeParser->new(\$HTML);
  $p->unbroken_text(1);

  my $token;
  while ($token = $p->get_token) {
    my ($type,$foundtext) = @$token;
    if ($type eq "T") {
      push @$seen, $token->[1];
      $result++ if __match_text($foundtext,$text);
    };
  };

  return $result,$seen;
};

sub __match {
  my ($attrs,$currattr,$key) = @_;
  my $result = 1;

  if (exists $currattr->{$key}) {
    if (! defined $attrs->{$key}) {
      $result = 0; # We don't want to see this attribute here
    } else {
      $result = 0 unless __dwim_compare($currattr->{$key}, $attrs->{$key});
    };
  } else {
    if (! defined $attrs->{$key}) {
      $result = 0 if (exists $currattr->{$key});
    } else {
      $result = 0;
    };
  };
  return $result;
};

sub __count_tags {
  my ($HTML,$tag,$attrref) = @_;
  $attrref = {} unless defined $attrref;
  return ('skip','XML::LibXML or XML::XPath not loaded')
    if exists $attrref->{_content};

  my $result = 0;
  $tag = lc $tag;

  my $p = HTML::TokeParser->new(\$HTML);
  my $token;
  my @seen;
  while ($token = $p->get_token) {
    my ($type,$currtag,$currattr,$attrseq,$origtext) = @$token;
    if ($type eq "S" && $tag eq $currtag) {
      my (@keys) = keys %$attrref;
      my $key;
      my $complete = 1;
      foreach $key (@keys) {
        $complete = __match($attrref,$currattr,$key) if $complete;
      };
      $result += $complete;
      # Now munge the thing to resemble what the XPath variant returns :
      push @seen, $token->[4];
    };
  };

  return $result,\@seen;
};

sub __match_declaration {
  my ($text,$template) = @_;
  $text =~ s/^<!(.*?)>$/$1/ unless $HTML_PARSER_StripsTags;
  unless (ref $template eq "Regexp") {
    $text =~ s/^\s*(.*?)\s*$/$1/;
    $template =~ s/^\s*(.*?)\s*$/$1/;
  };
  return __dwim_compare($text, $template);
};

sub __count_declarations {
  my ($HTML,$doctype) = @_;
  my $result = 0;
  my $seen = [];

  my $p = HTML::TokeParser->new(\$HTML);
  my $token;
  while ($token = $p->get_token) {
    my ($type,$text) = @$token;
    if ($type eq "D") {
      push @$seen, $text;
      $result++ if __match_declaration($text,$doctype);
    };
  };

  return $result, $seen;
};

sub import {
  goto &install;
};

sub install {
  for (@exports) {
    no strict 'refs';
    *{"Test::HTML::Content::$_"} = *{"Test::HTML::Content::NoXPath::$_"};
  };
  $Test::HTML::Content::can_xpath = 0;
};

1;

__END__