Test-HTML-Content-0.12/ 0000755 0001750 0001750 00000000000 14457155523 014104 5 ustar corion corion Test-HTML-Content-0.12/MANIFEST.SKIP 0000755 0001750 0001750 00000000370 14457155521 016003 0 ustar corion corion ^\.prove
^\.github
^blib/
^Makefile$
^Makefile\.old$
^pm_to_blib$
^\.lwpcookies$
CVS/.*
,v$
^tmp/
\.old$
\.bak$
~$
^#
\.shar$
\.tar$
\.tgz$
\.tar\.gz$
\.zip$
_uu$
\.cvsignore$
^\.releaserc$
^Test-HTML-Content-.*/
.*\.db$
^cvstest$
^MYMETA.*
^.git/
Test-HTML-Content-0.12/Makefile.PL 0000755 0001750 0001750 00000016413 14457155521 016064 0 ustar corion corion # -*- mode: perl; c-basic-offset: 4; indent-tabs-mode: nil; -*-
use strict;
use 5.006000;
use ExtUtils::MakeMaker qw(WriteMakefile);
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
# Normalize version strings like 6.30_02 to 6.3002,
# so that we can do numerical comparisons on it.
my $eumm_version = $ExtUtils::MakeMaker::VERSION;
$eumm_version =~ s/_//;
our $have_xml_libxml;
our @libxml;
BEGIN {
eval { require XML::LibXML;
$have_xml_libxml = $XML::LibXML::VERSION };
undef $@;
if ($have_xml_libxml) {
push @libxml, "XML::LibXML" => '2.0133'; # a random recent-ish version
};
};
my $module = 'Test::HTML::Content';
(my $main_file = "lib/$module.pm" ) =~ s!::!/!g;
(my $distbase = $module) =~ s!::!-!g;
my $distlink = $distbase;
my @tests = map { glob $_ } 't/*.t', 't/*/*.t';
my %module = (
NAME => $module,
AUTHOR => q{Max Maischein },
VERSION_FROM => $main_file,
ABSTRACT_FROM => $main_file,
META_MERGE => {
"meta-spec" => { version => 2 },
resources => {
repository => {
web => "https://github.com/Corion/$distlink",
url => "git://github.com/Corion/$distlink.git",
type => 'git',
},
bugtracker => {
web => "https://github.com/Corion/$distbase/issues",
# mailto => 'meta-bugs@example.com',
},
license => "https://dev.perl.org/licenses/",
},
dynamic_config => 0, # we promise to keep META.* up-to-date
x_static_install => 1, # we are pure Perl and don't do anything fancy
},
MIN_PERL_VERSION => '5.006', # I use // in some places
'LICENSE'=> 'perl',
PL_FILES => {},
BUILD_REQUIRES => {
'ExtUtils::MakeMaker' => 0,
},
PREREQ_PM => {
'Test::Builder' => 0,
'Test::More' => 0,
'HTML::TokeParser' => 0,
@libxml,
},
TEST_REQUIRES => {
'Test::More' => 0,
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
clean => { FILES => "$distbase-*" },
test => { TESTS => join( ' ', @tests ) },
);
# This is so that we can do
# require 'Makefile.PL'
# and then call get_module_info
sub get_module_info { %module }
if( ! caller ) {
# I should maybe use something like Shipwright...
regen_README($main_file);
regen_EXAMPLES() if -d 'examples';
WriteMakefile1(get_module_info);
};
1;
sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade.
my %params=@_;
my $eumm_version=$ExtUtils::MakeMaker::VERSION;
$eumm_version=eval $eumm_version;
die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
die "License not specified" if not exists $params{LICENSE};
if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) {
#EUMM 6.5502 has problems with BUILD_REQUIRES
$params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} };
delete $params{BUILD_REQUIRES};
}
if ($params{TEST_REQUIRES} and $eumm_version < 6.64) {
$params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{TEST_REQUIRES}} };
delete $params{TEST_REQUIRES};
}
delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48;
delete $params{META_MERGE} if $eumm_version < 6.46;
delete $params{META_ADD} if $eumm_version < 6.46;
delete $params{LICENSE} if $eumm_version < 6.31;
delete $params{AUTHOR} if $] < 5.005;
delete $params{ABSTRACT_FROM} if $] < 5.005;
delete $params{BINARY_LOCATION} if $] < 5.005;
WriteMakefile(%params);
}
sub regen_README {
# README is the short version that just tells people what this is
# and how to install it
eval {
# Get description
my $readme = join "\n",
pod_section($_[0], 'NAME', 'no heading' ),
pod_section($_[0], 'DESCRIPTION' ),
<new();
# Read POD from Module.pm and write to README
$parser->parse_from_file($_[0]);
my $readme_mkdn = <as_markdown;
[](https://github.com/Corion/$distbase/actions?query=workflow%3Awindows)
[](https://github.com/Corion/$distbase/actions?query=workflow%3Amacos)
[](https://github.com/Corion/$distbase/actions?query=workflow%3Alinux)
STATUS
update_file( 'README.mkdn', $readme_mkdn );
};
}
sub pod_section {
my( $filename, $section, $remove_heading ) = @_;
open my $fh, '<', $filename
or die "Couldn't read '$filename': $!";
my @section =
grep { /^=head1\s+$section/.../^=/ } <$fh>;
# Trim the section
if( @section ) {
pop @section if $section[-1] =~ /^=/;
shift @section if $remove_heading;
pop @section
while @section and $section[-1] =~ /^\s*$/;
shift @section
while @section and $section[0] =~ /^\s*$/;
};
@section = map { $_ =~ s!^=\w+\s+!!; $_ } @section;
return join "", @section;
}
sub regen_EXAMPLES {
my $perl = $^X;
if ($perl =~/\s/) {
$perl = qq{"$perl"};
};
(my $example_file = $main_file) =~ s!\.pm$!/Examples.pm!;
my $examples = `$perl -w examples/gen_examples_pod.pl`;
if ($examples) {
warn "(Re)Creating $example_file\n";
$examples =~ s/\r\n/\n/g;
update_file( $example_file, $examples );
};
};
sub update_file {
my( $filename, $new_content ) = @_;
my $content;
if( -f $filename ) {
open my $fh, '<:raw:encoding(UTF-8)', $filename
or die "Couldn't read '$filename': $!";
local $/;
$content = <$fh>;
};
if( $content ne $new_content ) {
if( open my $fh, '>:raw:encoding(UTF-8)', $filename ) {
print $fh $new_content;
} else {
warn "Couldn't (re)write '$filename': $!";
};
};
}
Test-HTML-Content-0.12/t/ 0000755 0001750 0001750 00000000000 14457155523 014347 5 ustar corion corion Test-HTML-Content-0.12/t/07-errors.link.t 0000755 0001750 0001750 00000010466 14457155521 017240 0 ustar corion corion # Test script to test the failure modes of Test::HTML::Content
use Test::More;
use lib 't';
use testlib;
BEGIN {
eval {
require Test::Builder::Tester;
Test::Builder::Tester->import;
};
if ($@) {
plan skip_all => "Test::Builder::Tester required for testing error messages";
}
};
# perldelta 5.14
# Accept both old and new-style stringification
my $modifiers = (qr/foobar/ =~ /\Q(?^/) ? "^" : "-xism";
sub run {
# Test that each exported function fails as documented
test_out("not ok 1 - Link failure (no links)");
test_fail(+8);
if ($Test::HTML::Content::can_xpath eq 'XML::LibXML') {
test_diag("Invalid HTML:","");
} else {
test_diag("Expected to find at least one tag(s) matching",
" href = http://www.perl.com",
"Got none");
};
link_ok("","http://www.perl.com","Link failure (no links)");
test_test("Finding no link works");
test_out("not ok 1 - Link failure (two links that don't match)");
test_fail(+14);
if ($Test::HTML::Content::can_xpath eq 'XML::LibXML') {
test_diag("Expected to find at least one tag(s) matching",
" href = http://www.perl.com",
"Got",
' foo',
' Home');
} else {
test_diag("Expected to find at least one tag(s) matching",
" href = http://www.perl.com",
"Got",
" ",
" ");
};
link_ok("fooHome",
"http://www.perl.com","Link failure (two links that don't match)");
test_test("Finding no link returns all other links");
test_out("not ok 1 - Link failure (two links shouldn't exist do)");
test_fail(+14);
if ($Test::HTML::Content::can_xpath eq 'XML::LibXML') {
test_diag("Expected to find no tag(s) matching",
" href = (?$modifiers:.)",
"Got",
' foo',
' Home');
} else {
test_diag("Expected to find no tag(s) matching",
" href = (?$modifiers:.)",
"Got",
" ",
" ");
};
no_link("fooHome",
qr".","Link failure (two links shouldn't exist do)");
test_test("Finding a link where one should be returns all other links");
test_out("not ok 1 - Link failure (too few links)");
test_fail(+14);
if ($Test::HTML::Content::can_xpath eq 'XML::LibXML') {
test_diag("Expected to find exactly 3 tag(s) matching",
" href = (?$modifiers:.)",
"Got",
' foo',
' Home');
} else {
test_diag("Expected to find exactly 3 tag(s) matching",
" href = (?$modifiers:.)",
"Got",
" ",
" ");
};
link_count("fooHome",qr".",3,"Link failure (too few links)");
test_test("Diagnosing too few links works");
test_out("not ok 1 - Link failure (too many links)");
test_fail(+18);
if ($Test::HTML::Content::can_xpath eq 'XML::LibXML') {
test_diag("Expected to find exactly 3 tag(s) matching",
" href = (?$modifiers:.)",
"Got",
' bar',
' .',
' foo',
' Home');
} else {
test_diag("Expected to find exactly 3 tag(s) matching",
" href = (?$modifiers:.)",
"Got",
" ",
" ",
" ",
" ");
};
link_count("bar.fooHome",qr".",3,"Link failure (too many links)");
test_test("Diagnosing too many links works");
};
runtests( 5,\&run);
Test-HTML-Content-0.12/t/00-load.t 0000644 0001750 0001750 00000000572 14457155521 015672 0 ustar corion corion #!perl
use strict;
use warnings;
use Test::More tests => 1;
require './Makefile.PL';
my %module = get_module_info();
my $module = $module{ NAME };
require_ok( $module );
diag( sprintf "Testing %s %s, Perl %s", $module, $module->VERSION, $] );
for (sort grep /\.pm\z/, keys %INC) {
s/\.pm\z//;
s!/!::!g;
eval { diag(join(' ', $_, $_->VERSION || '')) };
}
Test-HTML-Content-0.12/t/12-title.t 0000755 0001750 0001750 00000001651 14457155521 016101 0 ustar corion corion use strict;
use Test::More tests => 7;
BEGIN {
use_ok( "Test::HTML::Content" );
};
SKIP: {
skip "XML::XPath or XML::LibXML is needed for title testing", 6
unless $Test::HTML::Content::can_xpath;
title_ok('A test title',qr"A test title","Title RE");
title_ok('A test title',qr"^A test title$","Anchored title RE");
title_ok('A test title',qr"test","Title RE works for partial matches");
title_ok('A test title',"A test title","Title string");
no_title('A test title',"test","Complete title string gets compared");
no_title('A test title',"A toast title","no_title string");
}; Test-HTML-Content-0.12/t/12-title-fallback.t 0000755 0001750 0001750 00000002521 14457155521 017633 0 ustar corion corion use strict;
use Test::More tests => 1+6*2;
BEGIN {
use_ok( "Test::HTML::Content");
if ($Test::HTML::Content::can_xpath) {
require Test::HTML::Content::NoXPath;
&Test::HTML::Content::NoXPath::install;
};
};
eval {
title_ok('A test title',qr"A test title","Title RE");
};
is( $@, "", "Gracefull title fallback (title_ok)" );
eval {
title_ok('A test title',qr"^A test title$","Anchored title RE");
};
is( $@, "", "Gracefull title fallback (title_ok)" );
eval {
title_ok('A test title',qr"test","Title RE works for partial matches");
};
is( $@, "", "Gracefull title fallback (title_ok)" );
eval {
title_ok('A test title',"A test title","Title string");
};
is( $@, "", "Gracefull title fallback (title_ok)" );
eval {
no_title('A test title',"test","Complete title string gets compared");
};
is( $@, "", "Gracefull title fallback (no_title)" );
eval {
no_title('A test title',"A toast title","no_title string");
};
is( $@, "", "Gracefull title fallback (no_title)" );
Test-HTML-Content-0.12/t/08-errors.comment.t 0000755 0001750 0001750 00000006651 14457155521 017747 0 ustar corion corion # Test script to test the failure modes of Test::HTML::Content
use Test::More;
use lib 't';
use testlib;
use vars qw( $Test::HTML::Content::can_xpath );
eval {
require Test::Builder::Tester;
Test::Builder::Tester->import;
};
if ($@) {
plan skip_all => "Test::Builder::Tester required for testing error messages";
}
# perldelta 5.14
# Accept both old and new-style stringification
my $modifiers = (qr/foobar/ =~ /\Q(?^/) ? "^" : "-xism";
sub run {
# Test that each exported function fails as documented
test_out("not ok 1 - Comment failure (no comments)");
test_fail(+7);
if ($Test::HTML::Content::can_xpath eq 'XML::LibXML') {
test_diag("Invalid HTML:","");
} else {
test_diag("No comment found at all",
"Expected at least one comment like 'hidden message'",);
};
comment_ok("","hidden message","Comment failure (no comments)");
test_test("Finding no comment works");
test_out("not ok 1 - Comment failure (nonmatching comments)");
test_fail(+9);
#if ($Test::HTML::Content::can_xpath eq 'XML::XPath') {
# test_diag("Invalid HTML:","");
#} else {
test_diag("Saw ''",
"Saw ''",
"Saw ''",
"Expected at least one comment like 'hidden message'");
#};
comment_ok("",
"hidden message","Comment failure (nonmatching comments)");
test_test("Finding no comment returns all other comments");
test_out("not ok 1 - Comment failure (two comments that shouldn't exist do)");
test_fail(+8);
#if ($Test::HTML::Content::can_xpath eq 'XML::XPath') {
# test_diag("Invalid HTML:","");
#} else {
test_diag("Saw ''",
"Saw ''",
"Expected no comment like '(?$modifiers:hidden m.ssage)'");
#};
no_comment("",
qr"hidden m.ssage","Comment failure (two comments that shouldn't exist do)");
test_test("Finding a comment where none should be returns all comments");
test_out("not ok 1 - Comment failure (too few comments)");
test_fail(+8);
#if ($Test::HTML::Content::can_xpath eq 'XML::XPath') {
# test_diag("Invalid HTML:","");
#} else {
test_diag("Saw ''",
"Saw ''",
"Expected exactly 3 comments like '(?$modifiers:hidden m.ssage)'");
#};
comment_count("",
qr"hidden m.ssage",3,"Comment failure (too few comments)");
test_test("Diagnosing too few comments works");
test_out("not ok 1 - Comment failure (too few comments)");
test_fail(+8);
#if ($Test::HTML::Content::can_xpath eq 'XML::XPath') {
# test_diag("Invalid HTML:","");
#} else {
test_diag("Saw ''",
"Saw ''",
"Expected exactly 1 comments like '(?$modifiers:hidden m.ssage)'");
#};
comment_count("",
qr"hidden m.ssage",1,"Comment failure (too few comments)");
test_test("Diagnosing too many comments works");
};
runtests( 5, \&run );
Test-HTML-Content-0.12/t/05-doctype.t 0000755 0001750 0001750 00000001456 14457155521 016434 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use lib 't';
use testlib;
sub run {
use_ok('Test::HTML::Content');
# Tests for comments
has_declaration('
', 'DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN"', "Doctype 3.2");
has_declaration('
', qr'HTML', "Doctype via RE");
has_declaration('
', qr'DOCTYPE.*?HTML 3\.2',"Doctype via other RE");
no_declaration('
', qr'DOCTYPE.*?HtML 3\.2',"Doctype via other RE");
};
# Borked javadoc HTML DOCTYPE ...
#
runtests( 1+4, \&run );
Test-HTML-Content-0.12/t/09-errors.xpath.t 0000755 0001750 0001750 00000004326 14457155521 017427 0 ustar corion corion # Test script to test the failure modes of Test::HTML::Content
use Test::More;
BEGIN{
eval {
require Test::Builder::Tester;
Test::Builder::Tester->import;
};
if ($@) {
plan skip_all => "Test::Builder::Tester required for testing error messages";
}
};
BEGIN {
plan tests => 7;
use_ok('Test::HTML::Content');
};
SKIP: {
if (! $Test::HTML::Content::can_xpath) {
skip "Need XPath functionality to test it", 6;
exit;
};
my $HTML = q{Test
1
2
};
test_out("not ok 1 - no XPath results found");
test_fail(+5);
test_diag(q{Got},
q{ },
q{ 1
},
q{ 2
});
xpath_ok($HTML,'//p[@boo]','//p',"no XPath results found");
test_test("Finding no xpath results where some should be outputs the fallback");
test_out("not ok 1 - no XPath results found");
test_fail(+2);
test_diag(q{Got none});
xpath_ok($HTML,'//p[@boo]',"no XPath results found");
test_test("Finding no xpath results (implicit)");
test_out("not ok 1 - no XPath results found");
test_fail(+5);
test_diag(q{Got},
q{ },
q{ 1
},
q{ 2
});
no_xpath($HTML,'//p[@foo]','//p',"no XPath results found");
test_test("Finding xpath results where none should be outputs the fallback");
test_out("not ok 1 - no XPath results found");
test_fail(+5);
test_diag(q{Got},
q{ },
q{ 1
},
q{ 2
});
no_xpath($HTML,'//p',"no XPath results found");
test_test("Finding xpath results (implicit fallback)");
test_out("not ok 1 - no XPath results found");
test_fail(+5);
test_diag(q{Got},
q{ },
q{ 1
},
q{ 2
});
xpath_count($HTML,'//p',4,"no XPath results found");
test_test("Too few hits get reported");
test_out("not ok 1 - no XPath results found");
test_fail(+5);
test_diag(q{Got},
q{ },
q{ 1
},
q{ 2
});
xpath_count($HTML,'//p',2,"no XPath results found");
test_test("Too many hits get reported");
};
Test-HTML-Content-0.12/t/01-libxml-xpath-abstraction.t 0000755 0001750 0001750 00000001437 14457155521 021700 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use Test::More;
use lib 't';
use testlib;
# This test file tests the abstraction
# of XML::LibXML and XML::XPath nodes
my $HTML = 'test';
sub run {
my ($implementation) = @_;
SKIP: {
skip "Tests irrelevant for pure Perl implementation", 4
if $implementation eq 'PurePerl';
use_ok('Test::HTML::Content');
my $tree = Test::HTML::Content::__get_node_tree($HTML, '/html/body');
isn't( $tree, undef, "Got body node");
foreach my $node ($tree->get_nodelist) {
is( Test::HTML::Content::__get_node_content($node,'onload'), 'foo()', 'onload attribute');
is( Test::HTML::Content::__get_node_content($node,'_content'), 'test','_content pseudo attribute');
};
};
};
runtests( 4,\&run );
Test-HTML-Content-0.12/t/embedded-Test-HTML-Content-XPathExtensions.t 0000644 0001750 0001750 00000002127 14457155521 024456 0 ustar corion corion #!D:\perl\5.8.2\bin\perl.exe -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
my $Original_File = 'lib\Test\HTML\Content\XPathExtensions.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 58 lib/Test/HTML/Content/XPathExtensions.pm
# This module patches the XML::XPath::Function namespace
use Test::HTML::Content::XPathExtensions;
;
}
};
is($@, '', "example from line 58");
undef $main::_STDOUT_;
undef $main::_STDERR_;
Test-HTML-Content-0.12/t/10-errors.text.t 0000755 0001750 0001750 00000001600 14457155521 017247 0 ustar corion corion # Test script to test the failure modes of Test::HTML::Content
use Test::More;
eval {
require Test::Builder::Tester;
Test::Builder::Tester->import;
};
if ($@) {
plan skip_all => "Test::Builder::Tester required for testing error messages";
}
plan tests => 1+1*2;
use_ok('Test::HTML::Content');
# Test that each exported function fails as documented
sub run_tests {
test_out("not ok 1 - Text failure (empty document)");
test_fail(+1);
text_ok("","Perl","Text failure (empty document)");
no warnings 'once';
if ($Test::HTML::Content::can_xpath) {
test_diag( 'Invalid HTML:', "" );
} else {
test_diag( 'No text found at all', "Expected at least one text element like 'Perl'" );
};
test_test("Empty document gets reported");
};
run_tests;
require Test::HTML::Content::NoXPath;
Test::HTML::Content::NoXPath->install;
run_tests; Test-HTML-Content-0.12/t/01-internal-api.t 0000755 0001750 0001750 00000022203 14457155521 017335 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use Test::More;
use lib 't';
use testlib;
# This test file tests the internal routines of Test::HTML.
# The internal routines aren't really intended for public
# consumption, but the tests you'll find in here should
# document the behaviour enough ...
my (%cases_2,%cases_3);
my $count;
BEGIN {
$cases_2{__dwim_compare} = [
"foo" => "bar" => 0,
"foo" => "..." => 0,
"bar" => "foo" => 0,
"bar" => "barra" => 0,
"barra" => "bar" => 0,
"foo" => qr"bar" => 0,
"foo" => qr"..." => 1,
"bar" => qr"foo" => 0,
"bar" => qr"barra" => 0,
"barra" => qr"bar" => 1,
"foo" => qr"^oo" => 0,
"foo" => qr"oo$" => 1,
"FOO" => qr"foo$" => 0,
"FOO" => qr"foo$"i => 1,
];
$cases_2{__match_comment} = [
"hidden message" => qr"hidden\s+message" => 1,
"FOO" => qr"foo$"i => 1,
" FOO" => qr"foo$"i => 1,
"FOO " => qr"foo$"i => 0,
"FOO " => qr"^foo$"i => 0,
" hidden message " => "hidden message" => 1,
" hidden message " => "hidden message" => 0,
];
$cases_2{__match_text} = [
"hidden message" => qr"hidden\s+message" => 1,
"FOO" => qr"foo$"i => 1,
" FOO" => qr"foo$"i => 1,
"FOO " => qr"foo$"i => 0,
"FOO " => qr"^foo$"i => 0,
" hidden message " => "hidden message" => 1,
" hidden message " => "hidden message" => 0,
];
$cases_2{__match_declaration} = [
"hidden message" => qr"hidden\s+message" => 1,
"FOO" => qr"foo$"i => 1,
" FOO" => qr"foo$"i => 1,
"FOO " => qr"foo$"i => 0,
"FOO " => qr"^foo$"i => 0,
" hidden message " => "hidden message" => 1,
" hidden message " => "hidden message" => 0,
];
$cases_3{__match} = [
{href => 'http://www.perl.com', alt =>"foo"},{}, "href" => 0,
{href => 'http://www.perl.com', alt =>"foo"},{}, "alt" => 0,
{href => 'http://www.perl.com', alt =>undef},{alt => "boo"}, "alt" => 0,
{href => undef, alt =>"foo"},{href => 'http://www.perl.com'}, "href" => 0,
{href => 'http://www.perl.com', alt =>"foo"},{href => 'www.perl.com'}, "href" => 0,
{href => 'http://www.perl.com', alt =>"foo"},{href => '.', alt => "foo"}, "href" => 0,
{href => 'http://www.perl.com', alt =>"foo"},{href => 'http://www.perl.com'}, "href" => 1,
{href => qr'www\.perl\.com'},{href => 'http://www.perl.com', alt =>"foo"}, "href" => 1,
{href => qr'.', alt => "foo"},{href => 'http://www.perl.com', alt =>"foo"}, "href" => 1,
];
$count = (18 + 24 + 12);
$count += (@{$cases_2{$_}} / 3) for (keys %cases_2);
$count += (@{$cases_3{$_}} / 4) for (keys %cases_3);
};
sub run_case {
my ($count,$methods) = @_;
my $method;
for $method (sort keys %$methods) {
my @cases = @{$methods->{$method}};
while (@cases) {
my (@params) = splice @cases, 0, $count;
my $outcome = pop @params;
my ($visual);
($visual = $method) =~ tr/_/ /;
$visual =~ s/^\s*(.*?)\s*$/$1/;
no strict 'refs';
cmp_ok("Test::HTML::Content::$method"->(@params), '==',$outcome,"$visual(". join( "=~",@params ).")");
};
};
};
sub run {
run_case( 3, \%cases_2 );
run_case( 4, \%cases_3 );
my ($count,$seen);
($count,$seen) = Test::HTML::Content::__count_tags->("foo","a",{href => "http://www.perl.com"});
is($count, 0,"Counting tags 1");
is(@$seen, 0,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("Perl","a",{href => "http://www.perl.com"});
is($count, 0,"Counting tags 2");
is(@$seen, 1,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("Perl","a",{href => "http://www.perl.com"});
is($count, 0,"Counting tags 3");
is(@$seen, 0,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("Perl","a",{href => "http://www.perl.com"});
is($count, 0,"Counting tags 4");
is(@$seen, 0,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("Perl","a",{href => "http://www.perl.com"});
is($count, 1,"Counting tags 6");
is(@$seen, 1,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("Perl","a",{href => "http://www.perl.com"});
is($count, 1,"Counting tags 7");
is(@$seen, 1,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("PerlPerl","a",{href => "http://www.perl.com", alt => undef});
is($count, 1,"Counting tags 8");
is(@$seen, 2,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("PerlPerl","a",{href => "http://www.perl.com"});
is($count, 2,"Counting tags 9");
is(@$seen, 2,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_tags->("PerlPerl
","a",{href => "http://www.perl.com"});
is($count, 2,"Counting tags 10");
is(@$seen, 2,"Checking possible candidates");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,0,"Counting comments 0");
is(@$seen,0,"Counting possible candidates 0");
($count,$seen) = Test::HTML::Content::__count_comments( "foo" => "foo" );
is($count,0,"Counting comments 1");
is(@$seen,0,"Counting possible candidates 1");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,1,"Counting comments 2");
is(@$seen,1,"Counting possible candidates 2");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,0,"Counting comments 3");
is(@$seen,1,"Counting possible candidates 3");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,0,"Counting comments 4");
is(@$seen,1,"Counting possible candidates 4");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,0,"Counting comments 5");
is(@$seen,1,"Counting possible candidates 5");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo " );
is($count,1,"Counting comments 6");
is(@$seen,1,"Counting possible candidates 6");
($count,$seen) = Test::HTML::Content::__count_comments( "" => qr"foo" );
is($count,1,"Counting comments 7");
is(@$seen,1,"Counting possible candidates 7");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,1,"Counting comments 8");
is(@$seen,1,"Counting possible candidates 8");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,2,"Counting comments 9");
is(@$seen,2,"Counting possible candidates 9");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,3,"Counting comments 10");
is(@$seen,3,"Counting possible candidates 10");
($count,$seen) = Test::HTML::Content::__count_comments( "" => "foo" );
is($count,2,"Counting comments 11");
is(@$seen,3,"Counting possible candidates 11");
($count,$seen) = Test::HTML::Content::__count_text( "" => "foo" );
is($count,0,"Counting text occurrences 0");
is(@$seen,0,"Counting possible candidates 0");
($count,$seen) = Test::HTML::Content::__count_text( "foo" => "foo" );
is($count,1,"counting text occurrences 1");
is(@$seen,1,"Counting possible candidates 1");
($count,$seen) = Test::HTML::Content::__count_text( "" => "foo" );
is($count,0,"counting text occurrences 2");
is(@$seen,0,"Counting possible candidates 2");
# This test disabled, as it is not consistent between XPath and NoXPath...
#($count,$seen) = Test::HTML::Content::__count_text( "
" => "foo" );
#is($count,0,"counting text occurrences 3");
#is(@$seen,2,"Counting possible candidates 3");
($count,$seen) = Test::HTML::Content::__count_text( "foo bar" => "foo" );
is($count,1,"counting text occurrences 4");
is(@$seen,2,"Counting possible candidates 4");
($count,$seen) = Test::HTML::Content::__count_text( "foo" => "foo" );
is($count,0,"counting text occurrences 5");
is(@$seen,3,"Counting possible candidates 5");
($count,$seen) = Test::HTML::Content::__count_text( "Hello foo World" => qr"foo" );
is($count,1,"Checking RE for text 6");
is(@$seen,1,"Counting possible candidates 6");
};
runtests( $count, \&run );
Test-HTML-Content-0.12/t/01-fallback-xpath.t 0000755 0001750 0001750 00000001322 14457155521 017632 0 ustar corion corion use strict;
use Test::More tests => 4;
my $HTML = "dot";
SKIP: {
eval {
require Test::Without::Module;
Test::Without::Module->import( 'XML::LibXML' );
};
skip "Need Test::Without::Module to test the fallback", 4
if $@;
use_ok("Test::HTML::Content");
link_ok($HTML,'target',"Finding a link works without XML::LibXML");
my ($result,$args);
eval {
($result,$args) = Test::HTML::Content::__count_tags($HTML,'a',{_content=>'dot'});
};
is($@,'',"Missing prerequisites don't let the tests fail");
ok($result eq 'skip' || $result == 1,'Skipped or passed when XML::LibXML is missing')
or diag "Expected 'skip' or '1', but got '$result'";
};
Test-HTML-Content-0.12/t/09-errors.declaration.t 0000755 0001750 0001750 00000000566 14457155521 020572 0 ustar corion corion # Test script to test the failure modes of Test::HTML::Content
use Test::More;
eval {
require Test::Builder::Tester;
Test::Builder::Tester->import;
};
if ($@) {
plan skip_all => "Test::Builder::Tester required for testing error messages";
}
plan tests => 1;
use_ok('Test::HTML::Content');
# Test that doctype_ok fails as documented
# to be done Test-HTML-Content-0.12/t/01-xpath-query-builder.t 0000755 0001750 0001750 00000001717 14457155521 020674 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use Test::More;
use lib 't';
use testlib;
# This test file tests the generation of the XPath queries
# The XPath queries have to work for both, XML::XPath
# and XML::LibXML, so not all features of XML::XPath
# can be used ...
my (@cases);
BEGIN {
@cases=(
[ tag => {href => 'http://www.perl.com', alt =>"foo"} => '//tag[@alt = "foo" and @href = "http://www.perl.com"]' ],
[ tag => {href => qr'http://', alt =>"foo"} => '//tag[@alt = "foo" and @href]' ],
[ tag => {href => qr'http://', alt => undef} => '//tag[not(@alt) and @href]' ],
[ tag2 => {href => qr'http://', alt => undef} => '//tag2[not(@alt) and @href]' ],
);
# plan( tests => scalar @cases +1 );
};
sub run_case {
my ($tag,$attr,$result) = @_;
my ($query,$code) = Test::HTML::Content::__build_xpath_query("//".$tag,$attr);
is( $query, $result, $query );
};
sub run {
for my $case (@cases) {
run_case( @$case );
};
};
runtests( scalar @cases, \&run );
Test-HTML-Content-0.12/t/00-prerequisites.t 0000755 0001750 0001750 00000000734 14457155521 017662 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use Test::More tests => 3;
# TODO:
# * Better prerequisites checking
# * Split up the tests into separate files
# First, check the prerequisites
use_ok('Test::Builder')
or BAILOUT("The tests require Test::Builder");
use_ok('HTML::TokeParser')
or BAILOUT("The tests require HTML::TokeParser");
use_ok('Test::HTML::Content')
or Test::Builder::BAILOUT("The tests require Test::HTML::Content - this shouldn't happen at all");
Test-HTML-Content-0.12/t/04-comments.t 0000755 0001750 0001750 00000005134 14457155521 016606 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use lib 't';
use testlib;
sub run {
use_ok('Test::HTML::Content');
# Tests for comments
comment_ok('Mail me at some address',
'(c) 2002 corion@cpan.org', "Comments are found if there");
comment_ok('Mail me at some address',
' (c) 2002 corion@cpan.org', "Whitespace at front");
comment_ok('Mail me at some address',
' (c) 2002 corion@cpan.org ', "Whitespace at front and end");
comment_ok('Mail me at some address',
'(c) 2002 corion@cpan.org ', "Whitespace at end");
comment_ok('Mail me at some address',
'(c) 2002 corion@cpan.org', "Whitespace at HTML front");
comment_ok('Mail me at some address',
'(c) 2002 corion@cpan.org', "Whitespace at HTML end");
comment_ok('Mail me at some address',
qr'corion@cpan.org', "RE over comments");
comment_ok('Mail me at foo some address', 'corion@cpan.org', "Comments are found if there");
comment_count('Mail me at foo some address', 'corion@cpan.org',1, "Comments are found if there");
comment_count('Mail me at foo
some address', 'corion@cpan.org',2, "Comments are counted correctly");
comment_count('Mail me at foo some address', qr'\@cpan\.org',2, "RE-Comments are counted correctly");
no_comment('Mail me at (c) 2002 corion@cpan.org some address',
'(c) 2002 corion@cpan.org', "Comments are not found if not there");
no_comment('Mail me at corion@cpan.org some address',
'corion@cpan.org', "Comments are not found if not there");
no_comment('Mail me at foo some address', qr'\@cpan\.com', "RE-Comments are found correctly");
no_comment('Mail me at foo some address', qr'corion\@[c]pan\.org', "RE-Comments not stringified");
};
runtests( 1+15, \&run );
Test-HTML-Content-0.12/t/01-fallback-libxml.t 0000755 0001750 0001750 00000001333 14457155521 017777 0 ustar corion corion use strict;
use Test::More tests => 4;
SKIP: {
eval {
require Test::Without::Module;
Test::Without::Module->import( 'XML::XPath' );
};
skip "Need Test::Without::Module to test the fallback", 4
if $@;
use_ok("Test::HTML::Content");
link_ok("dot",'here',"Finding a link works without libxml");
my ($result,$args);
eval { ($result,$args) = Test::HTML::Content::__count_tags("dot",'a',{_content=>'dot'}); };
is($@,'',"Missing prerequisites don't let the tests fail");
ok($result eq 'skip' || $result == 1,'Skipped or passed when XML::XPath is missing')
or diag "Expected 'skip' or '1', but got '$result'";
};
Test-HTML-Content-0.12/t/02-tags.t 0000755 0001750 0001750 00000012514 14457155521 015715 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use lib 't';
use testlib;
sub run {
# Tests for tags
tag_ok('Title',
"a",{href => "http://www.perl.com" }, "Single attribute");
tag_ok('Title',
"A",{href => "http://www.perl.com" }, "Uppercase query finds lowercase tag");
tag_ok('Title',
"a",{href => "http://www.perl.com" }, "Lowercase query finds uppercase tag");
tag_ok('Title',
"A",{href => "http://www.perl.com" }, "Uppercase query finds uppercase tag");
tag_ok('Title',
"a",{href => "http://www.perl.com" }, "Lowercase query finds lowercase tag");
tag_ok('Title',
"a",{}, "No attributes");
tag_ok('Title',
"a",undef, "Undef attributes");
tag_ok('Title',
"a", "Forgotten attributes");
tag_count('Title',
"a",{href => "http://www.perl.com" },1, "Single attribute gets counted once");
tag_ok('Title',
"a",{href => "http://www.perl.com" }, "Superfluous attributes are ignored");
tag_count('Title',
"a",{href => "http://www.perl.com" }, 1, "Superfluous attributes are ignored and still the matchcount stays");
tag_ok('TitleIcon',
"a",{href => "http://www.perl.com" }, "Tags that appear twice get reported");
tag_count('TitleIcon',
"a",{href => "http://www.perl.com" },2, "Tags that appear twice get reported twice");
no_tag('Title',
"a",{href => "http://www.perl.com" }, "Plain strings get matched exactly");
tag_ok('Title',
"a",{href => qr"^http://.*$" }, "Regular expressions for attributes");
tag_ok('Title',
"a",{href => qr"^http://.*$", name => "Perl" }, "Mixing regular expressions with strings");
tag_ok('Title',
"a",{href => qr"^http://.*$", name => qr"^P.*l$" }, "Specifying more than one RE");
tag_ok('Title',
"a",{href => qr"http://www.pea?rl.com", name => qr"^Pea?rl$" }, "Optional RE");
tag_count('TitleAnother link',
"a",{href => "http://www.perl.com" },2, "Ignored tags");
tag_count('TitleAnother link',
"a",{href => "http://www.perl.com", name => undef },1, "Absent tags");
no_tag('Title',
"a",{href => "http://www.perl.com" }, "Misspelled attribute is not found");
tag_count('Title',
"a",{href => "http://www.perl.com" },0, "Misspelled attribute is reported zero times");
no_tag('Title',
"a",{href => "http://www.perl.com" }, "Tag with same attribute but different tag is not found");
tag_count('Title',
"a",{href => "http://www.perl.com" }, 0,"Tag with same attribute but different tag is reported zero times");
no_tag('Title',
"a",{href => "http://www.perl.com" },"Tag with different attribute value is not found");
tag_count('Title',
"a",{href => "http://www.perl.com" },0,"Tag with different attribute value is reported zero times");
no_tag('',
"a",{href => "http://www.perl.com" }, "Tag within a comment is not found");
tag_count('',
"a",{href => "http://www.perl.com" }, 0, "Tag within a comment is reported zero times");
no_tag('Title',
"a",{href => "http://www.perl.com" }, "Tag within a (different) comment is not found");
tag_count('Title',
"a",{href => "http://www.perl.com" }, 0, "Tag within a (different) comment is reported zero times");
# RE parameters
no_tag('Title',
"a",{href => "http://www.perl.com", name => qr"^Pearl$" }, "Nonmatching via RE");
tag_count('
Nice style
Ugly style
Super-ugly style
',
"p",{style => qr"ugly$" }, 2, "Tag attribute counting");
};
runtests(32,\&run); Test-HTML-Content-0.12/t/03-links.t 0000755 0001750 0001750 00000001460 14457155521 016076 0 ustar corion corion #!/usr/bin/perl -w
use strict;
use lib 't';
use testlib;
sub run {
# Tests for links
no_link('','http://www.perl.com', "Simple non-existing link");
no_link('http://www.perl.com',"http://www.perl.com", "Plain text gets not interpreted as link");
link_ok('Title',"http://www.perl.com", "A link is found");
link_count('IconTitle',"http://www.perl.com", 2,"A link that appears twice is reported twice");
link_ok('Mail me at
some address',
'corion@somewhere.else', "Links are not found if commented out");
};
runtests(5,\&run); Test-HTML-Content-0.12/t/testlib.pm 0000755 0001750 0001750 00000001603 14457155521 016354 0 ustar corion corion use strict;
use Test::More;
use vars qw(%modules);
BEGIN {
$modules{pureperl} = \&run_pureperl;
eval { require XML::XPath; $XML::XPath::VERSION >= 1.13 and $modules{xpath} = \&run_xpath };
eval { require XML::LibXML; $modules{libxml} = \&run_libxml };
};
sub main::runtests {
my ($count,$code) = @_;
my @candidates = (sort keys %modules);
plan( tests => 1+ $count * scalar @candidates );
use_ok('Test::HTML::Content');
for my $implementation (@candidates) {
my $test = $modules{$implementation};
$test->($count,$code);
};
};
sub run_libxml {
my ($count,$code) = @_;
Test::HTML::Content::install_libxml();
$code->('XML::LibXML');
};
sub run_xpath {
my ($count,$code) = @_;
Test::HTML::Content::install_xpath();
$code->('XML::XPath');
};
sub run_pureperl {
my ($count,$code) = @_;
Test::HTML::Content::install_pureperl();
$code->('PurePerl');
};
1;
Test-HTML-Content-0.12/t/06-text.t 0000755 0001750 0001750 00000020304 14457155521 015743 0 ustar corion corion use strict;
use lib 't';
use testlib;
my $HTML = <<'HTML';
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very long text.This is a very long text.This is a very long text.
This is a very long text.This is a very long text.This is a very lang text.This is a very long text.This is a very long text.
HTML
my $HTML2 = "This is some text. And some more text. And some other stuff
";
# use Test::HTML::Content;
sub run {
text_ok($HTML,qr"This is a very lang text."ism,"REs for text work");
text_count($HTML,qr"This is a very lang text.",1,"Counting text elements works");
no_text($HTML, "This is a very long test","Negation works as well");
no_text($HTML, qr"This is a very long test","Negation also works with REs");
text_ok($HTML2,"This is some text.","Complete elements are matched");
text_ok($HTML2,"And some more text.","Complete elements are matched with whitespace at the ends");
text_count($HTML2,qr"text",2,"Counting elements works with REs");
text_count($HTML2,qr"[aA]nd",2,"Counting elements works with REs");
# Now guard against inadverent stringification of REs :
#$text =~ s/^\s*(.*?)\s*$/$1/;
no_text("[A] simple test",qr"[A] simple test","No stringification of REs in no_text()");
text_count("[A] simple test",qr"[A] simple test",0,"No stringification of REs in text_count()");
text_ok("A simple test",qr"A simple test","Text is not broken up");
};
runtests( 11, \&run ); Test-HTML-Content-0.12/t/01-fallback-pureperl.t 0000755 0001750 0001750 00000001316 14457155521 020347 0 ustar corion corion use strict;
use Test::More tests => 4;
SKIP: {
eval {
require Test::Without::Module;
Test::Without::Module->import( 'XML::XPath' );
Test::Without::Module->import( 'XML::LibXML' );
};
skip "Need Test::Without::Module to test the fallback", 4
if $@;
use_ok("Test::HTML::Content");
link_ok("dot",'here',"Finding a link works without xpath");
my ($result,$args);
eval {
($result,$args) = Test::HTML::Content::__count_tags("dot",'a',{_content=>'dot'});
};
is($@,'',"Missing prerequisites don't let the tests fail");
is($result,'skip','Missing prerequisites make the tests skip instead');
};
Test-HTML-Content-0.12/t/13-xpath-gracefull-errors.t 0000755 0001750 0001750 00000002042 14457155521 021354 0 ustar corion corion # Test script to test the failure modes of Test::HTML::Content
use Test::More;
use lib 't';
use testlib;
eval {
require Test::Builder::Tester;
Test::Builder::Tester->import;
};
if ($@) {
plan skip_all => "Test::Builder::Tester required for testing error messages";
}
sub run {
use_ok('Test::HTML::Content');
SKIP: {
{ no warnings 'once';
$Test::HTML::Content::can_xpath
or skip "XML::XPath or XML::LibXML required", 2;
};
my ($tree,$result,$seen);
eval {
($result,$seen) = Test::HTML::Content::__count_comments("", "hidden message");
};
is($@,'',"Invalid HTML does not crash the test");
eval {
($tree) = Test::HTML::Content::__get_node_tree("",'//comment()');
};
is($@,'',"Invalid HTML does not crash the test");
# is($tree,undef,"The result of __get_node_tree is undef");
}
};
runtests( 3, \&run); Test-HTML-Content-0.12/t/embedded-Test-HTML-Content.t 0000644 0001750 0001750 00000005046 14457155521 021357 0 ustar corion corion #!D:\perl\5.8.2\bin\perl.exe -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
my $Original_File = 'lib\Test\HTML\Content.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 598 lib/Test/HTML/Content.pm
$HTML = "A test pageHome page
Perl
";
link_ok($HTML,"http://www.perl.com","We link to Perl");
no_link($HTML,"http://www.pearl.com","We have no embarassing typos");
link_ok($HTML,qr"http://[a-z]+\.perl.com","We have a link to perl.com");
title_count($HTML,1,"We have one title tag");
title_ok($HTML,qr/test/);
tag_ok($HTML,"img", {src => "http://www.perl.com/camel.png"},
"We have an image of a camel on the page");
tag_count($HTML,"img", {src => "http://www.perl.com/camel.png"}, 2,
"In fact, we have exactly two camel images on the page");
no_tag($HTML,"blink",{}, "No annoying blink tags ..." );
# We can check the textual contents
text_ok($HTML,"Perl");
# We can also check the contents of comments
comment_ok($HTML,"Hidden message");
# Advanced stuff
# Using a regular expression to match against
# tag attributes - here checking there are no ugly styles
no_tag($HTML,"p",{ style => qr'ugly$' }, "No ugly styles" );
# REs also can be used for substrings in comments
comment_ok($HTML,qr"[hH]idden\s+mess");
# and if you have XML::LibXML or XML::XPath, you can
# even do XPath queries yourself:
xpath_ok($HTML,'/html/body/p','HTML is somewhat wellformed');
no_xpath($HTML,'/html/head/p','HTML is somewhat wellformed');
;
}
};
is($@, '', "example from line 598");
undef $main::_STDOUT_;
undef $main::_STDERR_;
Test-HTML-Content-0.12/t/embedded-Test-HTML-Content-NoXPath.t 0000644 0001750 0001750 00000002127 14457155521 022673 0 ustar corion corion #!D:\perl\5.8.2\bin\perl.exe -w
use Test::More 'no_plan';
package Catch;
sub TIEHANDLE {
my($class, $var) = @_;
return bless { var => $var }, $class;
}
sub PRINT {
my($self) = shift;
${'main::'.$self->{var}} .= join '', @_;
}
sub OPEN {} # XXX Hackery in case the user redirects
sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
sub READ {}
sub READLINE {}
sub GETC {}
my $Original_File = 'lib\Test\HTML\Content\NoXPath.pm';
package main;
# pre-5.8.0's warns aren't caught by a tied STDERR.
$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
tie *STDERR, 'Catch', '_STDERR_' or die $!;
undef $main::_STDOUT_;
undef $main::_STDERR_;
eval q{
my $example = sub {
local $^W = 0;
#line 195 lib/Test/HTML/Content/NoXPath.pm
# This module is implicitly loaded by Test::HTML::Content
# if XML::XPath or HTML::Tidy::Simple are unavailable.
;
}
};
is($@, '', "example from line 195");
undef $main::_STDOUT_;
undef $main::_STDERR_;
Test-HTML-Content-0.12/README.mkdn 0000644 0001750 0001750 00000014161 14457155521 015715 0 ustar corion corion
[](https://github.com/Corion/Test-HTML-Content/actions?query=workflow%3Awindows)
[](https://github.com/Corion/Test-HTML-Content/actions?query=workflow%3Amacos)
[](https://github.com/Corion/Test-HTML-Content/actions?query=workflow%3Alinux)
# NAME
Test::HTML::Content - Perl extension for testing HTML output
# SYNOPSIS
use Test::HTML::Content( tests => 13 );
$HTML = "A test pageHome page
Perl
";
link_ok($HTML,"http://www.perl.com","We link to Perl");
no_link($HTML,"http://www.pearl.com","We have no embarassing typos");
link_ok($HTML,qr"http://[a-z]+\.perl.com","We have a link to perl.com");
title_count($HTML,1,"We have one title tag");
title_ok($HTML,qr/test/);
tag_ok($HTML,"img", {src => "http://www.perl.com/camel.png"},
"We have an image of a camel on the page");
tag_count($HTML,"img", {src => "http://www.perl.com/camel.png"}, 2,
"In fact, we have exactly two camel images on the page");
no_tag($HTML,"blink",{}, "No annoying blink tags ..." );
# We can check the textual contents
text_ok($HTML,"Perl");
# We can also check the contents of comments
comment_ok($HTML,"Hidden message");
# Advanced stuff
# Using a regular expression to match against
# tag attributes - here checking there are no ugly styles
no_tag($HTML,"p",{ style => qr'ugly$' }, "No ugly styles" );
# REs also can be used for substrings in comments
comment_ok($HTML,qr"[hH]idden\s+mess");
# and if you have XML::LibXML or XML::XPath, you can
# even do XPath queries yourself:
xpath_ok($HTML,'/html/body/p','HTML is somewhat wellformed');
no_xpath($HTML,'/html/head/p','HTML is somewhat wellformed');
# DESCRIPTION
This is a module to test the HTML output of your programs in simple
test scripts. It can test a scalar (presumably containing HTML) for
the presence (or absence, or a specific number) of tags having (or
lacking) specific attributes. Unspecified attributes are ignored,
and the attribute values can be specified as either scalars (meaning
a match succeeds if the strings are identical) or regular expressions
(meaning that a match succeeds if the actual attribute value is matched
by the given RE) or undef (meaning that the attribute must not
be present).
If you want to specify or test the deeper structure
of the HTML (for example, META tags within the BODY) or the (textual)
content of tags, you will have to resort to `xpath_ok`,`xpath_count`
and `no_xpath`, which take an XPath expression. If you find yourself crafting
very complex XPath expression to verify the structure of your output, it is
time to rethink your testing process and maybe use a template based solution
or simply compare against prefabricated files as a whole.
The used HTML parser is HTML::TokeParser, the used XPath module
is XML::XPath or XML::LibXML. XML::XPath needs valid xHTML, XML::LibXML
will try its best to force your code into xHTML, but it is best to
supply valid xHTML (snippets) to the test functions.
If no XPath parsers/interpreters are available, the tests will automatically
skip, so your users won't need to install XML::XPath or XML::LibXML. The module
then falls back onto a crude implementation of the core functions for tags,
links, comments and text, and the diagnostic output of the tests varies a bit.
The test functionality is derived from [Test::Builder](https://metacpan.org/pod/Test%3A%3ABuilder), and the export
behaviour is the same. When you use Test::HTML::Content, a set of
HTML testing functions is exported into the namespace of the caller.
## EXPORT
Exports the bunch of test functions :
link_ok() no_link() link_count()
tag_ok() no_tag() tag_count()
text_ok no_text() text_count()
comment_ok() no_comment() comment_count()
xpath_ok() no_xpath() xpath_count()
has_declaration() no_declaration()
## CONSIDERATIONS
The module reparses the HTML string every time a test function is called.
This will make running many tests over the same, large HTML stream relatively
slow. A possible speedup could be simple minded caching mechanism that keeps the most
recent HTML stream in a cache.
## CAVEATS
The test output differs between XPath and HTML parsing, because XML::XPath
delivers the complete node including the content, where my HTML parser only
delivers the start tag. So don't make your tests depend on the \_exact\_
output of my tests. It was a pain to do so in my test scripts for this module
and if you really want to, take a look at the included test scripts.
The title functions `title_ok` and `no_title` rely on the XPath functionality
and will thus skip if XPath functionality is unavailable.
## BUGS
Currently, if there is text split up by comments, the text will be seen
as two separate entities, so the following dosen't work :
is_text( "Hello World", "Hello World" );
Whether this is a real bug or not, I don't know at the moment - most likely,
I'll modify text\_ok() and siblings to ignore embedded comments.
## TODO
My things on the todo list for this module. Patches are welcome !
- Refactor the code to fold some of the internal routines
- Implement a cache for the last parsed tree / token sequence
- Possibly diag() the row/line number for failing tests
- Allow RE instead of plain strings in the functions (for tags themselves). This
one is most likely useless.
# LICENSE
This code may be distributed under the same terms as Perl itself.
# AUTHOR
Max Maischein
# SEE ALSO
perl(1), [Test::Builder](https://metacpan.org/pod/Test%3A%3ABuilder),[Test::Simple](https://metacpan.org/pod/Test%3A%3ASimple),[Test::HTML::Lint](https://metacpan.org/pod/Test%3A%3AHTML%3A%3ALint).
Test-HTML-Content-0.12/.gitignore 0000644 0001750 0001750 00000000341 14457155521 016070 0 ustar corion corion Thumbs.db
_Inline
ccv-src/
out.png
blib/
*.bak
Makefile
Makefile.old
pm_to_blib
CCV.def
CCV.inl
CCV.c
*.bs
*.old
*.o
dll.base
dll.exp
.releaserc
Test-HTML-Content-*.tar
Test-HTML-Content-*.tar.gz
Test-HTML-Content-*/
MYMETA.* Test-HTML-Content-0.12/META.yml 0000644 0001750 0001750 00000001547 14457155523 015364 0 ustar corion corion ---
abstract: 'Perl extension for testing HTML output'
author:
- 'Max Maischein '
build_requires:
ExtUtils::MakeMaker: '0'
Test::More: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 0
generated_by: 'ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: Test-HTML-Content
no_index:
directory:
- t
- inc
requires:
HTML::TokeParser: '0'
Test::Builder: '0'
Test::More: '0'
XML::LibXML: '2.0133'
perl: '5.006'
resources:
bugtracker: https://github.com/Corion/Test-HTML-Content/issues
license: https://dev.perl.org/licenses/
repository: git://github.com/Corion/Test-HTML-Content.git
version: '0.12'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
x_static_install: 1
Test-HTML-Content-0.12/lib/ 0000755 0001750 0001750 00000000000 14457155523 014652 5 ustar corion corion Test-HTML-Content-0.12/lib/Test/ 0000755 0001750 0001750 00000000000 14457155523 015571 5 ustar corion corion Test-HTML-Content-0.12/lib/Test/HTML/ 0000755 0001750 0001750 00000000000 14457155523 016335 5 ustar corion corion Test-HTML-Content-0.12/lib/Test/HTML/Content/ 0000755 0001750 0001750 00000000000 14457155523 017747 5 ustar corion corion Test-HTML-Content-0.12/lib/Test/HTML/Content/NoXPath.pm 0000755 0001750 0001750 00000011623 14457155521 021632 0 ustar corion corion 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.12';
BEGIN {
# Check whether HTML::Parser is v3 and delivers the comments starting
# with the ";
my $p = HTML::TokeParser->new(\$HTML);
my ($type,$text) = @{$p->get_token()};
if ($text eq "") {
$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__
=head1 NAME
Test::HTML::Content::NoXPath - HTML::TokeParser fallback for Test::HTML::Content
=head1 SYNOPSIS
=for example begin
# This module is implicitly loaded by Test::HTML::Content
# if XML::XPath or HTML::Tidy::Simple are unavailable.
=for example end
=head1 DESCRIPTION
This is the module that gets loaded when Test::HTML::Content
can't find its prerequisites :
XML::XPath
HTML::Tidy
=head2 EXPORT
Nothing. It stomps over the Test::HTML::Content namespace.
=head1 LICENSE
This code may be distributed under the same terms as Perl itself.
=head1 AUTHOR
Max Maischein, corion@cpan.org
=head1 SEE ALSO
L,L,L,L,L
=cut
Test-HTML-Content-0.12/lib/Test/HTML/Content/XPathExtensions.pm 0000755 0001750 0001750 00000003765 14457155521 023425 0 ustar corion corion package Test::HTML::Content::XPathExtensions;
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.12';
@exports = qw( matches comment );
sub matches {
my $self = shift;
my ($node, @params) = @_;
die "starts-with: incorrect number of params\n" unless @params == 2;
my $re = $params[1]->string_value;
return($params[0]->string_value =~ /$re/)
? XML::XPath::Boolean->True
: XML::XPath::Boolean->False;
}
sub comment {
my $self = shift;
my ($node, @params) = @_;
die "starts-with: incorrect number of params\n" unless @params == 1;
my $re = $params[1]->string_value;
return(ref $node =~ /Comment$/)
? XML::XPath::Boolean->True
: XML::XPath::Boolean->False;
};
sub import {
for (@exports) {
no strict 'refs';
# Install our extensions unless they already exist :
*{"XML::XPath::Function::$_"} = *{"Test::HTML::Content::XPathExtensions::$_"}
unless defined *{"XML::XPath::Function::$_"}{CODE};
};
};
1;
__END__
=head1 NAME
Test::HTML::Content::XPathExtensions - Perlish XPath extensions
=head1 SYNOPSIS
=for example begin
# This module patches the XML::XPath::Function namespace
use Test::HTML::Content::XPathExtensions;
=for example end
=head1 DESCRIPTION
This is the module that provides RE support for XML::XPath
and support for matching comments through the two functions
C and C.
The two functions are modeled after what I found on the Saxon
website on the C namespace :
=over 4
=item *
http://saxon.sourceforge.net/saxon7.3.1/functions.html
=item *
http://www.w3.org/TR/xquery-operators/
=back
=head2 EXPORT
Nothing. It stomps over the XML::XPath::Function namespace.
=head1 LICENSE
This code may be distributed under the same terms as Perl itself.
=head1 AUTHOR
Max Maischein, corion@cpan.org
=head1 SEE ALSO
L
=cut
Test-HTML-Content-0.12/lib/Test/HTML/Content.pm 0000755 0001750 0001750 00000050616 14457155521 020316 0 ustar corion corion package Test::HTML::Content;
require 5.005_62;
use strict;
use File::Spec;
use Carp qw(carp croak);
use HTML::TokeParser;
# we want to stay compatible to 5.5 and use warnings if
# we can
eval 'use warnings' if $] >= 5.006;
use Test::Builder;
require Exporter;
use vars qw/@ISA @EXPORT_OK @EXPORT $VERSION $can_xpath/;
@ISA = qw(Exporter);
use vars qw( $tidy );
# DONE:
# * use Test::Builder;
# * Add comment_ok() method
# * Allow RE instead of plain strings in the functions (for tag attributes and comments)
# * Create a function to check the DOCTYPE and other directives
# * Have a better way to diagnose ignored candidates in tag_ok(), tag_count
# and no_tag() in case a test fails
@EXPORT = qw(
link_ok no_link link_count
tag_ok no_tag tag_count
comment_ok no_comment comment_count
has_declaration no_declaration
text_ok no_text text_count
title_ok no_title
xpath_ok no_xpath xpath_count
);
$VERSION = '0.12';
my $Test = Test::Builder->new;
use vars qw($HTML_PARSER_StripsTags $parsing_method);
$parsing_method = 'parse_html_string';
# Cribbed from the Test::Builder synopsis
sub import {
my($self) = shift;
my $pack = caller;
$Test->exported_to($pack);
$Test->plan(@_);
$self->export_to_level(1, $self, @EXPORT);
}
sub __dwim_compare {
# Do the Right Thing (Perl 6 style) with the RHS being a Regex or a string
my ($target,$template) = @_;
if (ref $template) { # supposedly a Regexp, but possibly blessed, so no eq comparision
return ($target =~ $template )
} else {
return $target eq $template;
};
};
sub __node_content {
my $node = shift;
if ($can_xpath eq 'XML::XPath') { return XML::XPath::XMLParser::as_string($node) };
if ($can_xpath eq 'XML::LibXML') { return $node->toString };
};
sub __text_content {
my $node = shift;
if ($can_xpath eq 'XML::XPath') { return $node->string_value };
if ($can_xpath eq 'XML::LibXML') { return $node->textContent };
}
sub __match_comment {
my ($text,$template) = @_;
$text =~ s/^$/$1/sm 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 $tree;
$tree = __get_node_tree($HTML,'//comment()');
return (undef,undef) unless ($tree);
my $result = 0;
my @seen;
foreach my $node ($tree->get_nodelist) {
my $content = __node_content($node);
$content =~ s/\A\Z/$1/gsm;
push @seen, $content;
$result++ if __match_comment($content,$comment);
};
$_ = "" for @seen;
return ($result, \@seen);
};
sub __output_diag {
my ($cond,$match,$descr,$kind,$name,$seen) = @_;
local $Test::Builder::Level = $Test::Builder::Level + 2;
unless ($Test->ok($cond,$name)) {
if (@$seen) {
$Test->diag( "Saw '$_'" ) for @$seen;
} else {
$Test->diag( "No $kind found at all" );
};
$Test->diag( "Expected $descr like '$match'" );
};
};
sub __invalid_html {
my ($HTML,$name) = @_;
carp "No test name given" unless $name;
$Test->ok(0,$name);
$Test->diag( "Invalid HTML:");
$Test->diag($HTML);
};
sub __output_comment {
my ($check,$expectation,$HTML,$comment,$name) = @_;
my ($result,$seen) = __count_comments($HTML,$comment);
if (defined $result) {
$result = $check->($result);
__output_diag($result,$comment,$expectation,"comment",$name,$seen);
} else {
local $Test::Builder::Level = $Test::Builder::Level +2;
__invalid_html($HTML,$name);
};
$result;
};
sub comment_ok {
my ($HTML,$comment,$name) = @_;
__output_comment(sub{shift},"at least one comment",$HTML,$comment,$name);
};
sub no_comment {
my ($HTML,$comment,$name) = @_;
__output_comment(sub{shift == 0},"no comment",$HTML,$comment,$name);
};
sub comment_count {
my ($HTML,$comment,$count,$name) = @_;
__output_comment(sub{shift == $count},"exactly $count comments",$HTML,$comment,$name);
};
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 $tree = __get_node_tree($HTML,'//text()');
return (undef,undef) unless $tree;
my $result = 0;
my @seen;
foreach my $node ($tree->get_nodelist) {
my $content = __node_content($node);
push @seen, $content
unless $content =~ /\A\r?\n?\Z/sm;
$result++ if __match_text($content,$text);
};
return ($result, \@seen);
};
sub __output_text {
my ($check,$expectation,$HTML,$text,$name) = @_;
my ($result,$seen) = __count_text($HTML,$text);
if (defined $result) {
local $Test::Builder::Level = $Test::Builder::Level;
$result = $check->($result);
__output_diag($result,$text,$expectation,"text",$name,$seen);
} else {
local $Test::Builder::Level = $Test::Builder::Level +2;
__invalid_html($HTML,$name);
};
$result;
};
sub text_ok {
my ($HTML,$text,$name) = @_;
__output_text(sub{shift > 0}, "at least one text element",$HTML,$text,$name);
};
sub no_text {
my ($HTML,$text,$name) = @_;
__output_text(sub{shift == 0}, "no text elements",$HTML,$text,$name);
};
sub text_count {
my ($HTML,$text,$count,$name) = @_;
__output_text(sub{shift == $count}, "exactly $count elements",$HTML,$text,$name);
};
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 __get_node_tree {
my ($HTML,$query) = @_;
croak "No HTML given" unless defined $HTML;
croak "No query given" unless defined $query;
my ($tree,$find,$result);
if ($HTML !~ m!\A\s*\Z!ms) {
eval {
require XML::LibXML; XML::LibXML->import;
my $parser = XML::LibXML->new();
$parser->recover(1);
$tree = $parser->$parsing_method($HTML);
$find = 'findnodes';
$HTML_PARSER_StripsTags = 1;
};
unless ($tree) {
eval {
require XML::XPath; XML::XPath->import;
require XML::Parser;
my $p = XML::Parser->new( ErrorContext => 2, ParseParamEnt => 0, NoLWP => 1 );
$tree = XML::XPath->new( parser => $p, xml => $HTML );
$find = 'find';
};
};
undef $tree if $@;
if ($tree) {
eval {
$result = $tree->$find($query);
unless ($result) {
$result = {};
bless $result, 'Test::HTML::Content::EmptyXPathResult';
};
};
warn $@ if $@;
};
} else { };
return $result;
};
sub __get_node_content {
my ($node,$name) = @_;
if ($name eq '_content') {
return __text_content( $node )
# return $node->textContent()
} else {
return $node->getAttribute($name)
};
};
sub __build_xpath_query {
my ($query,$attrref) = @_;
my @postvalidation;
if ($attrref) {
my @query;
for (sort keys %$attrref) {
my $name = $_;
my $value = $attrref->{$name};
my $xpath_name = '@' . $name;
if ($name eq '_content') { $xpath_name = "text()" };
if (! defined $value) {
push @query, "not($xpath_name)"
} elsif ((ref $value) ne 'Regexp') {
push @query, "$xpath_name = \"$value\"";
push @postvalidation, sub {
return __get_node_content( shift,$name ) eq $value
};
} else {
push @query, "$xpath_name";
push @postvalidation, sub {
return __get_node_content( shift,$name ) =~ $value
};
};
};
$query .= "[" . join( " and ", map {"$_"} @query ) . "]"
if @query;
};
my $postvalidation = sub {
my $node = shift;
my $test;
for $test (@postvalidation) {
return () unless $test->($node);
};
return 1;
};
($query,$postvalidation);
};
sub __count_tags {
my ($HTML,$tag,$attrref) = @_;
$attrref = {} unless defined $attrref;
my $fallback = lc "//$tag";
my ($query,$valid) = __build_xpath_query( lc "//$tag", $attrref );
my $tree = __get_node_tree($HTML,$query);
return (undef,undef) unless $tree;
my @found = grep { $valid->($_) } ($tree->get_nodelist);
# Collect the nodes we did see for later reference :
my @seen;
foreach my $node (__get_node_tree($HTML,$fallback)->get_nodelist) {
push @seen, __node_content($node);
};
return scalar(@found),\@seen;
};
sub __tag_diag {
my ($tag,$num,$attrs,$found) = @_;
my $phrase = "Expected to find $num <$tag> tag(s)";
$phrase .= " matching" if (scalar keys %$attrs > 0);
$Test->diag($phrase);
$Test->diag(" $_ = " . (defined $attrs->{$_} ? $attrs->{$_} : ''))
for sort keys %$attrs;
if (@$found) {
$Test->diag("Got");
for my $tag (@$found) {
my $vis = "$tag";
$vis =~ s!\s*/>\s*$!/>!; # canonicalize between XML::Parser and XML::LibXML
$Test->diag(" " . $vis);
};
} else {
$Test->diag("Got none");
};
};
sub __output_tag {
my ($check,$expectation,$HTML,$tag,$attrref,$name) = @_;
($attrref,$name) = ({},$attrref)
unless defined $name;
$attrref = {}
unless defined $attrref;
croak "$attrref dosen't look like a hash reference for the attributes"
unless ref $attrref eq 'HASH';
my ($currcount,$seen) = __count_tags($HTML,$tag,$attrref);
my $result;
if (defined $currcount) {
if ($currcount eq 'skip') {
$Test->skip($seen);
} else {
local $Test::Builder::Level = $Test::Builder::Level +1;
$result = $check->($currcount);
unless ($Test->ok($result, $name)) {
__tag_diag($tag,$expectation,$attrref,$seen) ;
};
};
} else {
local $Test::Builder::Level = $Test::Builder::Level +2;
__invalid_html($HTML,$name);
};
$result;
};
sub tag_count {
my ($HTML,$tag,$attrref,$count,$name) = @_;
__output_tag(sub { shift == $count }, "exactly $count",$HTML,$tag,$attrref,$name);
};
sub tag_ok {
my ($HTML,$tag,$attrref,$name) = @_;
__output_tag(sub { shift > 0 }, "at least one",$HTML,$tag,$attrref,$name);
};
sub no_tag {
my ($HTML,$tag,$attrref,$name) = @_;
__output_tag(sub { shift == 0 }, "no",$HTML,$tag,$attrref,$name);
};
sub link_count {
my ($HTML,$link,$count,$name) = @_;
local $Test::Builder::Level = 2;
return tag_count($HTML,"a",{href => $link},$count,$name);
};
sub link_ok {
my ($HTML,$link,$name) = (@_);
local $Test::Builder::Level = 2;
return tag_ok($HTML,'a',{ href => $link },$name);
};
sub no_link {
my ($HTML,$link,$name) = (@_);
local $Test::Builder::Level = 2;
return no_tag($HTML,'a',{ href => $link },$name);
};
sub title_ok {
my ($HTML,$title,$name) = @_;
local $Test::Builder::Level = 2;
return tag_ok($HTML,"title",{_content => $title},$name);
};
sub no_title {
my ($HTML,$title,$name) = (@_);
local $Test::Builder::Level = 2;
return no_tag($HTML,'title',{ _content => $title },$name);
};
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 has_declaration {
my ($HTML,$declaration,$name) = @_;
my ($result,$seen) = __count_declarations($HTML,$declaration);
if (defined $result) {
__output_diag($result == 1,$declaration,"exactly one declaration","declaration",$name,$seen);
} else {
local $Test::Builder::Level = $Test::Builder::Level +1;
__invalid_html($HTML,$name);
};
$result;
};
sub no_declaration {
my ($HTML,$declaration,$name) = @_;
my ($result,$seen) = __count_declarations($HTML,$declaration);
if (defined $result) {
__output_diag($result == 0,$declaration,"no declaration","declaration",$name,$seen);
} else {
local $Test::Builder::Level = $Test::Builder::Level +1;
__invalid_html($HTML,$name);
};
$result;
};
sub __count_xpath {
my ($HTML,$query,$fallback) = @_;
$fallback = $query unless defined $fallback;
my $tree = __get_node_tree($HTML,$query);
return (undef,undef) unless $tree;
my @found = ($tree->get_nodelist);
# Collect the nodes we did see for later reference :
my @seen;
foreach my $node (__get_node_tree($HTML,$fallback)->get_nodelist) {
push @seen, __node_content($node);
};
return scalar(@found),\@seen;
};
sub __xpath_diag {
my ($query,$num,$found) = @_;
my $phrase = "Expected to find $num nodes matching on '$query'";
if (@$found) {
$Test->diag("Got");
for my $tag (@$found) {
my $vis = "$tag";
$vis =~ s!\s*/>$!/>!; # canonicalize between XML::Parser and XML::LibXML
$Test->diag(" $vis");
}
} else {
$Test->diag("Got none");
};
};
sub __output_xpath {
my ($check,$expectation,$HTML,$query,$fallback,$name) = @_;
($fallback,$name) = ($query,$fallback) unless $name;
my ($currcount,$seen) = __count_xpath($HTML,$query,$fallback);
my $result;
if (defined $currcount) {
if ($currcount eq 'skip') {
$Test->skip($seen);
} else {
local $Test::Builder::Level = $Test::Builder::Level +1;
$result = $check->($currcount);
unless ($Test->ok($result, $name)) {
__xpath_diag($query,$expectation,$seen) ;
};
};
} else {
local $Test::Builder::Level = $Test::Builder::Level +1;
__invalid_html($HTML,$name);
};
$result;
};
sub xpath_count {
my ($HTML,$query,$count,$fallback,$name) = @_;
__output_xpath( sub {shift == $count},"exactly $count",$HTML,$query,$fallback,$name);
};
sub xpath_ok {
my ($HTML,$query,$fallback,$name) = @_;
__output_xpath( sub{shift > 0},"at least one",$HTML,$query,$fallback,$name);
};
sub no_xpath {
my ($HTML,$query,$fallback,$name) = @_;
__output_xpath( sub{shift == 0},"no",$HTML,$query,$fallback,$name);
};
sub install_xpath {
require XML::XPath;
XML::XPath->import();
die "Need XML::XPath 1.13 or higher"
unless $XML::XPath::VERSION >= 1.13;
$can_xpath = 'XML::XPath';
};
sub install_libxml {
local $^W;
require XML::LibXML;
XML::LibXML->import();
$can_xpath = 'XML::LibXML';
};
# And install our plain handlers if we have to :
sub install_pureperl {
require Test::HTML::Content::NoXPath;
Test::HTML::Content::NoXPath->import;
};
BEGIN {
# Load the XML-variant if our prerequisites are there :
eval { install_libxml }
or eval { install_xpath }
or install_pureperl;
};
{
package Test::HTML::Content::EmptyXPathResult;
sub size { 0 };
sub get_nodelist { () };
};
1;
__END__
=head1 NAME
Test::HTML::Content - Perl extension for testing HTML output
=head1 SYNOPSIS
use Test::HTML::Content( tests => 13 );
=for example begin
$HTML = "A test pageHome page
Perl
";
link_ok($HTML,"http://www.perl.com","We link to Perl");
no_link($HTML,"http://www.pearl.com","We have no embarassing typos");
link_ok($HTML,qr"http://[a-z]+\.perl.com","We have a link to perl.com");
title_count($HTML,1,"We have one title tag");
title_ok($HTML,qr/test/);
tag_ok($HTML,"img", {src => "http://www.perl.com/camel.png"},
"We have an image of a camel on the page");
tag_count($HTML,"img", {src => "http://www.perl.com/camel.png"}, 2,
"In fact, we have exactly two camel images on the page");
no_tag($HTML,"blink",{}, "No annoying blink tags ..." );
# We can check the textual contents
text_ok($HTML,"Perl");
# We can also check the contents of comments
comment_ok($HTML,"Hidden message");
# Advanced stuff
# Using a regular expression to match against
# tag attributes - here checking there are no ugly styles
no_tag($HTML,"p",{ style => qr'ugly$' }, "No ugly styles" );
# REs also can be used for substrings in comments
comment_ok($HTML,qr"[hH]idden\s+mess");
# and if you have XML::LibXML or XML::XPath, you can
# even do XPath queries yourself:
xpath_ok($HTML,'/html/body/p','HTML is somewhat wellformed');
no_xpath($HTML,'/html/head/p','HTML is somewhat wellformed');
=for example end
=head1 DESCRIPTION
This is a module to test the HTML output of your programs in simple
test scripts. It can test a scalar (presumably containing HTML) for
the presence (or absence, or a specific number) of tags having (or
lacking) specific attributes. Unspecified attributes are ignored,
and the attribute values can be specified as either scalars (meaning
a match succeeds if the strings are identical) or regular expressions
(meaning that a match succeeds if the actual attribute value is matched
by the given RE) or undef (meaning that the attribute must not
be present).
If you want to specify or test the deeper structure
of the HTML (for example, META tags within the BODY) or the (textual)
content of tags, you will have to resort to C,C
and C, which take an XPath expression. If you find yourself crafting
very complex XPath expression to verify the structure of your output, it is
time to rethink your testing process and maybe use a template based solution
or simply compare against prefabricated files as a whole.
The used HTML parser is HTML::TokeParser, the used XPath module
is XML::XPath or XML::LibXML. XML::XPath needs valid xHTML, XML::LibXML
will try its best to force your code into xHTML, but it is best to
supply valid xHTML (snippets) to the test functions.
If no XPath parsers/interpreters are available, the tests will automatically
skip, so your users won't need to install XML::XPath or XML::LibXML. The module
then falls back onto a crude implementation of the core functions for tags,
links, comments and text, and the diagnostic output of the tests varies a bit.
The test functionality is derived from L, and the export
behaviour is the same. When you use Test::HTML::Content, a set of
HTML testing functions is exported into the namespace of the caller.
=head2 EXPORT
Exports the bunch of test functions :
link_ok() no_link() link_count()
tag_ok() no_tag() tag_count()
text_ok no_text() text_count()
comment_ok() no_comment() comment_count()
xpath_ok() no_xpath() xpath_count()
has_declaration() no_declaration()
=head2 CONSIDERATIONS
The module reparses the HTML string every time a test function is called.
This will make running many tests over the same, large HTML stream relatively
slow. A possible speedup could be simple minded caching mechanism that keeps the most
recent HTML stream in a cache.
=head2 CAVEATS
The test output differs between XPath and HTML parsing, because XML::XPath
delivers the complete node including the content, where my HTML parser only
delivers the start tag. So don't make your tests depend on the _exact_
output of my tests. It was a pain to do so in my test scripts for this module
and if you really want to, take a look at the included test scripts.
The title functions C and C rely on the XPath functionality
and will thus skip if XPath functionality is unavailable.
=head2 BUGS
Currently, if there is text split up by comments, the text will be seen
as two separate entities, so the following dosen't work :
is_text( "Hello World", "Hello World" );
Whether this is a real bug or not, I don't know at the moment - most likely,
I'll modify text_ok() and siblings to ignore embedded comments.
=head2 TODO
My things on the todo list for this module. Patches are welcome !
=over 4
=item * Refactor the code to fold some of the internal routines
=item * Implement a cache for the last parsed tree / token sequence
=item * Possibly diag() the row/line number for failing tests
=item * Allow RE instead of plain strings in the functions (for tags themselves). This
one is most likely useless.
=back
=head1 LICENSE
This code may be distributed under the same terms as Perl itself.
=head1 AUTHOR
Max Maischein Ecorion@cpan.orgE
=head1 SEE ALSO
perl(1), L,L,L.
=cut
Test-HTML-Content-0.12/META.json 0000644 0001750 0001750 00000003063 14457155523 015527 0 ustar corion corion {
"abstract" : "Perl extension for testing HTML output",
"author" : [
"Max Maischein "
],
"dynamic_config" : 0,
"generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : 2
},
"name" : "Test-HTML-Content",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"HTML::TokeParser" : "0",
"Test::Builder" : "0",
"Test::More" : "0",
"XML::LibXML" : "2.0133",
"perl" : "5.006"
}
},
"test" : {
"requires" : {
"Test::More" : "0"
}
}
},
"release_status" : "stable",
"resources" : {
"bugtracker" : {
"web" : "https://github.com/Corion/Test-HTML-Content/issues"
},
"license" : [
"https://dev.perl.org/licenses/"
],
"repository" : {
"type" : "git",
"url" : "git://github.com/Corion/Test-HTML-Content.git",
"web" : "https://github.com/Corion/Test-HTML-Content"
}
},
"version" : "0.12",
"x_serialization_backend" : "JSON::PP version 4.11",
"x_static_install" : 1
}
Test-HTML-Content-0.12/xt/ 0000755 0001750 0001750 00000000000 14457155523 014537 5 ustar corion corion Test-HTML-Content-0.12/xt/99-todo.t 0000644 0001750 0001750 00000002166 14457155521 016133 0 ustar corion corion use Test::More;
use File::Spec;
use File::Find;
use strict;
# Check that all files do not contain any
# lines with "XXX" - such markers should
# either have been converted into Todo-stuff
# or have been resolved.
# The test was provided by Andy Lester.
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my @files;
my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, grep { -d } ($blib));
if( my $exe = $module{EXE_FILES}) {
push @files, @$exe;
};
plan tests => 2* @files;
foreach my $file (@files) {
source_file_ok($file);
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
sub source_file_ok {
my $file = shift;
open( my $fh, '<', $file ) or die "Can't open $file: $!";
my @lines = <$fh>;
close $fh;
my $n = 0;
for ( @lines ) {
++$n;
s/^/$file ($n): /;
}
my @x = grep /XXX/, @lines;
if ( !is( scalar @x, 0, "Looking for XXXes in $file" ) ) {
diag( $_ ) for @x;
}
@x = grep /<<<|>>>/, @lines;
if ( !is( scalar @x, 0, "Looking for <<<<|>>>> in $file" ) ) {
diag( $_ ) for @x;
}
}
Test-HTML-Content-0.12/xt/99-changes.t 0000644 0001750 0001750 00000001337 14457155521 016575 0 ustar corion corion #!perl -w
use warnings;
use strict;
use File::Find;
use Test::More tests => 2;
=head1 PURPOSE
This test ensures that the Changes file
mentions the current version and that a
release date is mentioned as well
=cut
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my $module = $module{NAME};
(my $file = $module) =~ s!::!/!g;
require "$file.pm";
my $version = sprintf '%0.2f', $module->VERSION;
my $changes = do { local $/; open my $fh, 'Changes' or die $!; <$fh> };
ok $changes =~ /^(.*$version.*)$/m, "We find version $version for $module";
my $changes_line = $1;
ok $changes_line =~ /$version\s+20\d\d-[01]\d-[0123]\d\b/, "We find a release date on the same line"
or diag $changes_line;
Test-HTML-Content-0.12/xt/99-manifest.t 0000644 0001750 0001750 00000002044 14457155521 016767 0 ustar corion corion use strict;
use Test::More;
# Check that MANIFEST and MANIFEST.skip are sane :
use File::Find;
use File::Spec;
my @files = qw( MANIFEST MANIFEST.SKIP );
plan tests => scalar @files * 4
+1 # MANIFEST existence check
+1 # MYMETA.* non-existence check
;
for my $file (@files) {
ok(-f $file, "$file exists");
open my $fh, '<', $file
or die "Couldn't open $file : $!";
my @lines = <$fh>;
is_deeply([grep(/^$/, @lines)],[], "No empty lines in $file");
is_deeply([grep(/^\s+$/, @lines)],[], "No whitespace-only lines in $file");
is_deeply([grep(/^\s*\S\s+$/, @lines)],[],"No trailing whitespace on lines in $file");
if ($file eq 'MANIFEST') {
chomp @lines;
is_deeply([grep { s/\s.*//; ! -f } @lines], [], "All files in $file exist")
or do { diag "$_ is mentioned in $file but doesn't exist on disk" for grep { ! -f } @lines };
# Exclude some files from shipping
is_deeply([grep(/^MYMETA\.(yml|json)$/, @lines)],[],"We don't try to ship MYMETA.* $file");
};
close $fh;
};
Test-HTML-Content-0.12/xt/99-unix-text.t 0000644 0001750 0001750 00000001745 14457155521 017135 0 ustar corion corion use Test::More;
# Check that all released module files are in
# UNIX text format
use File::Spec;
use File::Find;
use strict;
my @files = ('Makefile.PL', 'MANIFEST', 'MANIFEST.SKIP', glob 't/*.t');
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my @files;
my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, grep { -d } ($blib));
if( my $exe = $module{EXE_FILES}) {
push @files, @$exe;
};
plan tests => scalar @files;
foreach my $file (@files) {
unix_file_ok($file);
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
sub unix_file_ok {
my ($filename) = @_;
local $/;
open my $fh, '<', $filename
or die "Couldn't open '$filename' : $!\n";
binmode $fh;
my $content = <$fh>;
my $i;
my @lines = grep { /\x0D\x0A$/sm } map { sprintf "%s: %s\x0A", $i++, $_ } split /\x0A/, $content;
unless (is(scalar @lines, 0,"'$filename' contains no windows newlines")) {
diag $_ for @lines;
};
close $fh;
};
Test-HTML-Content-0.12/xt/99-test-prerequisites.t 0000644 0001750 0001750 00000006564 14457155521 021055 0 ustar corion corion #!perl -w
use warnings;
use strict;
use Test::More;
use Data::Dumper;
use File::Find;
=head1 DESCRIPTION
This test checks whether all tests still pass when the optional test
prerequisites for the test are not present.
This is done by using L to rerun the test while excluding
the optional prerequisite.
=cut
BEGIN {
eval {
require CPAN::Meta::Prereqs;
require Parse::CPAN::Meta;
require Perl::PrereqScanner::Lite;
require Module::CoreList;
require Test::Without::Module;
require Capture::Tiny;
Capture::Tiny->import('capture');
require Path::Class;
Path::Class->import('dir');
};
if (my $err = $@) {
warn "# $err";
plan skip_all => "Prerequisite needed for testing is missing";
exit 0;
};
};
my @tests;
if( @ARGV ) {
@tests = @ARGV;
} else {
open my $manifest, '<', 'MANIFEST'
or die "Couldn't read MANIFEST: $!";
@tests = grep { -f $_ } grep { m!^(t/.*\.t|scripts/.*\.pl)$! } map { s!\s*$!!; $_ } <$manifest>
}
plan tests => 0+@tests;
my $meta = Parse::CPAN::Meta->load_file('META.json');
# Find what META.* declares
my $explicit_test_prereqs = CPAN::Meta::Prereqs->new( $meta->{prereqs} )->merged_requirements->as_string_hash;
my $minimum_perl = $meta->{prereqs}->{runtime}->{requires}->{perl} || 5.006;
sub distributed_packages {
my @modules;
for( @_ ) {
dir($_)->recurse( callback => sub {
my( $child ) = @_;
if( !$child->is_dir and $child =~ /\.pm$/) {
push @modules, ((scalar $child->slurp()) =~ m/^\s*package\s+(?:#.*?\n\s+)*(\w+(?:::\w+)*)\b/msg);
}
});
};
map { $_ => $_ } @modules;
}
# Find what we distribute:
my %distribution = distributed_packages('blib','t');
my $scanner = Perl::PrereqScanner::Lite->new;
for my $test_file (@tests) {
my $implicit_test_prereqs = $scanner->scan_file($test_file)->as_string_hash;
my %missing = %{ $implicit_test_prereqs };
#use Data::Dumper;
#warn Dumper \%missing;
for my $p ( keys %missing ) {
# remove core modules
if( Module::CoreList::is_core( $p, undef, $minimum_perl)) {
delete $missing{ $p };
#diag "$p is core for $minimum_perl";
} else {
#diag "$p is not in core for $minimum_perl";
};
};
# remove explicit (test) prerequisites
for my $k (keys %$explicit_test_prereqs) {
delete $missing{ $k };
};
#warn Dumper $explicit_test_prereqs->as_string_hash;
# Remove stuff from our distribution
for my $k (keys %distribution) {
delete $missing{ $k };
};
# If we have no apparent missing prerequisites, we're good
my @missing = sort keys %missing;
# Rerun the test without these modules and see whether it crashes
my @failed;
for my $candidate (@missing) {
diag "Checking that $candidate is not essential";
my @cmd = ($^X, "-MTest::Without::Module=$candidate", "-Mblib", '-w', $test_file);
my $cmd = join " ", @cmd;
my ($stdout, $stderr, $exit) = capture {
system( @cmd );
};
if( $exit != 0 ) {
push @failed, [ $candidate, [@cmd]];
} elsif( $? != 0 ) {
push @failed, [ $candidate, [@cmd]];
};
};
is 0+@failed, 0, $test_file
or diag Dumper \@failed;
};
done_testing;
Test-HTML-Content-0.12/xt/99-pod.t 0000644 0001750 0001750 00000001455 14457155521 015750 0 ustar corion corion use Test::More;
# Check our Pod
# The test was provided by Andy Lester,
# who stole it from Brian D. Foy
# Thanks to both !
use File::Spec;
use File::Find;
use strict;
eval {
require Test::Pod;
Test::Pod->import;
};
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my @files;
if ($@) {
plan skip_all => "Test::Pod required for testing POD";
}
elsif ($Test::Pod::VERSION < 0.95) {
plan skip_all => "Test::Pod 0.95 required for testing POD";
}
else {
my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, grep { -d } ($blib));
if( my $exe = $module{EXE_FILES}) {
push @files, @$exe;
};
plan tests => scalar @files;
foreach my $file (@files) {
pod_file_ok($file);
}
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
Test-HTML-Content-0.12/xt/copyright.t 0000644 0001750 0001750 00000004650 14457155521 016737 0 ustar corion corion #!perl
use warnings;
use strict;
use File::Find;
use Test::More tests => 1;
use POSIX 'strftime';
my $this_year = strftime '%Y', localtime;
my $last_modified_year = 0;
my $is_checkout = -d '.git';
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my @files;
#my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, grep { -d } ('lib'));
if( my $exe = $module{EXE_FILES}) {
push @files, @$exe;
};
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
sub collect {
my( $file ) = @_;
note $file;
my $modified_ts;
if( $is_checkout ) {
# diag `git log -1 --pretty="format:%ct" "$file"`;
$modified_ts = `git log -1 --pretty="format:%ct" "$file"`;
} else {
$modified_ts = (stat($_))[9];
}
my $modified_year;
if( $modified_ts ) {
$modified_year = strftime('%Y', localtime($modified_ts));
} else {
$modified_year = 1970;
};
open my $fh, '<', $file
or die "Couldn't read $file: $!";
my @copyright = map {
/\bcopyright\b.*?\d{4}-(\d{4})\b/i
? [ $_ => $1 ]
: ()
}
<$fh>;
my $copyright = 0;
for (@copyright) {
$copyright = $_->[1] > $copyright ? $_->[1] : $copyright;
};
return {
file => $file,
copyright_lines => \@copyright,
copyright => $copyright,
modified => $modified_year,
};
};
my @results;
for my $file (@files) {
push @results, collect($file);
};
for my $file (@results) {
$last_modified_year = $last_modified_year < $file->{modified}
? $file->{modified}
: $last_modified_year;
};
note "Distribution was last modified in $last_modified_year";
my @out_of_date = grep { $_->{copyright} and $_->{copyright} < $last_modified_year } @results;
if(! is 0+@out_of_date, 0, "All files have a current copyright year ($last_modified_year)") {
for my $file (@out_of_date) {
diag sprintf "%s modified %d, but copyright is %d", $file->{file}, $file->{modified}, $file->{copyright};
diag $_ for map {@$_} @{ $file->{copyright_lines}};
};
diag q{To fix (in a rough way, please review) run};
diag sprintf q{ perl -i -ple 's!(\bcopyright\b.*?\d{4}-)(\d{4})\b!${1}%s!i' %s},
$this_year,
join ' ',
map { $_->{file} } @out_of_date;
};
Test-HTML-Content-0.12/xt/99-compile.t 0000644 0001750 0001750 00000002025 14457155521 016610 0 ustar corion corion #!perl
use warnings;
use strict;
use File::Find;
use Test::More;
BEGIN {
eval 'use Capture::Tiny ":all"; 1';
if ($@) {
plan skip_all => "Capture::Tiny needed for testing";
exit 0;
};
};
plan 'no_plan';
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my $last_version = undef;
sub check {
#return if (! m{(\.pm|\.pl) \z}xmsi);
my ($stdout, $stderr, $exit) = capture(sub {
system( $^X, '-Mblib', '-c', $_ );
});
s!\s*\z!!
for ($stdout, $stderr);
if( $exit ) {
diag $stderr;
diag "Exit code: ", $exit;
fail($_);
} elsif( $stderr ne "$_ syntax OK") {
diag $stderr;
fail($_);
} else {
pass($_);
};
}
my @files;
find({wanted => \&wanted, no_chdir => 1},
grep { -d $_ }
'blib/lib', 'examples', 'lib'
);
if( my $exe = $module{EXE_FILES}) {
push @files, @$exe;
};
for (@files) {
check($_)
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
Test-HTML-Content-0.12/xt/99-synopsis.t 0000644 0001750 0001750 00000003011 14457155521 017043 0 ustar corion corion use strict;
use Test::More;
use File::Spec;
use File::Find;
use File::Temp 'tempfile';
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my @files;
my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, grep { -d } ($blib));
#if( my $exe = $module{EXE_FILES}) {
# push @files, @$exe;
#};
plan tests => scalar @files;
foreach my $file (@files) {
synopsis_file_ok($file);
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/
and $_ !~ /\bDSL\.pm$/; # we skip that one as it initializes immediately
}
sub synopsis_file_ok {
my( $file ) = @_;
my $name = "SYNOPSIS in $file compiles";
open my $fh, '<', $file
or die "Couldn't read '$file': $!";
my @synopsis = map { s!^\s\s!!; $_ } # outdent all code for here-docs
grep { /^\s\s/ } # extract all verbatim (=code) stuff
grep { /^=head1\s+SYNOPSIS$/.../^=/ } # extract Pod synopsis
<$fh>;
if( @synopsis ) {
my($tmpfh,$tempname) = tempfile();
print {$tmpfh} join '', @synopsis;
close $tmpfh; # flush it
my $output = `$^X -Ilib -c $tempname 2>&1`;
if( $output =~ /\ssyntax OK$/ ) {
pass $name;
} else {
fail $name;
diag $output;
diag $_ for @synopsis;
};
unlink $tempname
or warn "Couldn't clean up $tempname: $!";
} else {
SKIP: {
skip "$file has no SYNOPSIS section", 1;
};
};
}
Test-HTML-Content-0.12/xt/99-versions.t 0000644 0001750 0001750 00000003157 14457155521 017037 0 ustar corion corion #!perl -w
# Stolen from ChrisDolan on use.perl.org
# http://use.perl.org/comments.pl?sid=29264&cid=44309
use warnings;
use strict;
use File::Find;
use Test::More;
require './Makefile.PL';
# Loaded from Makefile.PL
our %module = get_module_info();
my @files;
my $blib = File::Spec->catfile(qw(blib lib));
find(\&wanted, grep { -d } ($blib));
if( my $exe = $module{EXE_FILES}) {
push @files, @$exe;
};
sub read_file {
open my $fh, '<', $_[0]
or die "Couldn't read '$_[0]': $!";
binmode $fh;
local $/;
<$fh>
}
sub wanted {
push @files, $File::Find::name if /\.p(l|m|od)$/;
}
plan tests => 0+@files;
my $last_version = undef;
sub check {
my $content = read_file($_);
# only look at perl scripts, not sh scripts
return if (m{blib/script/}xms && $content !~ m/\A \#![^\r\n]+?perl/xms);
# what my version numbers look like
my $version = qr/\d+\.\d+/;
my @version_lines = grep { defined }
$content =~ m/ [^\n]* \$VERSION \s* = \s* ["']($version)['"] | package \s+ \S+ \s+ ($version) \s* ; /gxms;
if (@version_lines == 0) {
fail($_);
}
for my $line (@version_lines) {
$line =~ s/^\s+//;
$line =~ s/\s+$//;
if (!defined $last_version) {
$last_version = shift @version_lines;
diag "Checking for $last_version";
pass($_);
} else {
is($line, $last_version, $_);
}
}
}
for (@files) {
check();
};
if (! defined $last_version) {
fail('Failed to find any files with $VERSION');
}
Test-HTML-Content-0.12/xt/99-minimumversion.t 0000644 0001750 0001750 00000000471 14457155521 020244 0 ustar corion corion #!perl -w
use strict;
use Test::More;
eval {
#require Test::MinimumVersion::Fast;
require Test::MinimumVersion;
Test::MinimumVersion->import;
};
my @files;
if ($@) {
plan skip_all => "Test::MinimumVersion required for testing minimum Perl version";
}
else {
all_minimum_version_from_metajson_ok();
}
Test-HTML-Content-0.12/xt/meta-lint.t 0000644 0001750 0001750 00000002157 14457155521 016621 0 ustar corion corion #!perl -w
# Stolen from ChrisDolan on use.perl.org
# http://use.perl.org/comments.pl?sid=29264&cid=44309
use warnings;
use strict;
use File::Find;
use Test::More;
eval {
#require Test::MinimumVersion::Fast;
require Parse::CPAN::Meta;
Parse::CPAN::Meta->import();
require CPAN::Meta::Validator;
CPAN::Meta::Validator->VERSION(2.15);
};
if ($@) {
plan skip_all => "CPAN::Meta::Validator version 2.15 required for testing META files";
}
else {
plan tests => 4;
}
use lib '.';
our %module;
require 'Makefile.PL';
# Loaded from Makefile.PL
%module = get_module_info();
my $module = $module{NAME};
(my $file = $module) =~ s!::!/!g;
require "$file.pm";
my $version = sprintf '%0.2f', $module->VERSION;
for my $meta_file ('META.yml', 'META.json') {
my $meta = Parse::CPAN::Meta->load_file($meta_file);
my $cmv = CPAN::Meta::Validator->new( $meta );
if(! ok $cmv->is_valid, "$meta_file is valid" ) {
diag $_ for $cmv->errors;
};
# Also check that the declared version matches the version in META.*
is $meta->{version}, $version, "$meta_file version matches module version ($version)";
};
Test-HTML-Content-0.12/Changes 0000755 0001750 0001750 00000005136 14457155521 015405 0 ustar corion corion Revision history for Perl extension Test::HTML::Content.
0.12 2023-07-23
- Fix test output/diagnostics between XML::LibXML and XML::Parser
0.11 2023-07-21
- Various test suite updates, no code changes, no need to upgrade
0.10 2023-01-20
- Add a XML::LibXML version number if we find it installed
This is to hunt down spurious test failures with an unknown version
of XML::LibXML
- Upgrade package/distribution infrastructure
- No code changes, no need to upgrade
0.09 2013-02-06
- Apply patch from RT 70099, by gregor herrmann and dom
This fixes bugs in the test suite
and RT 70099
- Apply patch from RT 42072 by gyles19@visi.com
This fixes the crash when using XML::XPath instead of XML::LibXML
0.08 2008-11-12
???
0.07 2003-12-30
- Fixed test bug reported by Kate Pugh (KAKE):
t/09-errors.xpath.t was missing a SKIP: label
- still no resolution on the other reported errors, as XML::XPath "works"
on my Win32 machine, but dosen't work elsewhere :-(
Most of the failures seem to be failures due to different text output
of the tests:
# #
vs.
# #
but as I can't replicate them here, it's hard to fix those :-(
0.08 2008-11-12
+ Added $parsing_method to allow XML to be tested as well.
0.06 2003-12-22
- Fixed tests against XML::XPath
- added another test testing the internal abstraction
API and differences between XML::XPath and XML::LibXML
0.05 2003-12-04
- Added XPath functionality (xpath_ok, no_xpath, xpath_count)
- Added fallback to old functionality if neither XML::LibXML nor
XML::XPath are available
- refactored code to have less duplication, at the cost of
some functions passed as parameters (this shouldn't bother you,
as it is all hidden)
0.04 lost in the void
0.03 Mon Sep 23 2002
- Fixed Pod (Thanks to Andy Lester)
- Added a test for the synopsis (Thanks to Andy Lester)
- Added a test for Pod consistency (Thanks to Andy Lester and brian d foy)
- Added text_ok(), no_text() and text_count()
- Fixed reporting of errors to the correct level. Errors now
get reported in your test file instead of somewhere within
Content.pm
0.02 Sun Sep 22 2002
- Renamed from Test::HTML to Test::HTML::Content
- Added warnings for the module again, if available
- Fixed inconsistencies between usage of
HTML::Parser v2 and HTML::Parser v3 (as displayed through
HTML::TokeParser)
0.01 Wed Sep 18 13:53:54 2002
- original version; created by h2xs 1.20 with options
-X Test::HTML
Test-HTML-Content-0.12/README 0000755 0001750 0001750 00000004662 14457155521 014775 0 ustar corion corion Test::HTML::Content - Perl extension for testing HTML output
DESCRIPTION
This is a module to test the HTML output of your programs in simple
test scripts. It can test a scalar (presumably containing HTML) for
the presence (or absence, or a specific number) of tags having (or
lacking) specific attributes. Unspecified attributes are ignored,
and the attribute values can be specified as either scalars (meaning
a match succeeds if the strings are identical) or regular expressions
(meaning that a match succeeds if the actual attribute value is matched
by the given RE) or undef (meaning that the attribute must not
be present).
If you want to specify or test the deeper structure
of the HTML (for example, META tags within the BODY) or the (textual)
content of tags, you will have to resort to C,C
and C, which take an XPath expression. If you find yourself crafting
very complex XPath expression to verify the structure of your output, it is
time to rethink your testing process and maybe use a template based solution
or simply compare against prefabricated files as a whole.
The used HTML parser is HTML::TokeParser, the used XPath module
is XML::XPath or XML::LibXML. XML::XPath needs valid xHTML, XML::LibXML
will try its best to force your code into xHTML, but it is best to
supply valid xHTML (snippets) to the test functions.
If no XPath parsers/interpreters are available, the tests will automatically
skip, so your users won't need to install XML::XPath or XML::LibXML. The module
then falls back onto a crude implementation of the core functions for tags,
links, comments and text, and the diagnostic output of the tests varies a bit.
The test functionality is derived from L, and the export
behaviour is the same. When you use Test::HTML::Content, a set of
HTML testing functions is exported into the namespace of the caller.
INSTALLATION
This is a Perl module distribution. It should be installed with whichever
tool you use to manage your installation of Perl, e.g. any of
cpanm .
cpan .
cpanp -i .
Consult https://www.cpan.org/modules/INSTALL.html for further instruction.
Should you wish to install this module manually, the procedure is
perl Makefile.PL
make
make test
make install
SEE ALSO
perl(1), L,L,L.
AUTHOR
Max Maischein Ecorion@cpan.orgE
LICENSE
This code may be distributed under the same terms as Perl itself.
Test-HTML-Content-0.12/MANIFEST 0000644 0001750 0001750 00000001727 14457155521 015242 0 ustar corion corion .gitignore
Changes
lib/Test/HTML/Content.pm
lib/Test/HTML/Content/NoXPath.pm
lib/Test/HTML/Content/XPathExtensions.pm
Makefile.PL
MANIFEST This list of files
MANIFEST.SKIP
META.json
META.yml
README
README.mkdn
t/00-load.t
t/00-prerequisites.t
t/01-fallback-libxml.t
t/01-fallback-pureperl.t
t/01-fallback-xpath.t
t/01-internal-api.t
t/01-libxml-xpath-abstraction.t
t/01-xpath-query-builder.t
t/02-tags.t
t/03-links.t
t/04-comments.t
t/05-doctype.t
t/06-text.t
t/07-errors.link.t
t/08-errors.comment.t
t/09-errors.declaration.t
t/09-errors.xpath.t
t/10-errors.text.t
t/12-title-fallback.t
t/12-title.t
t/13-xpath-gracefull-errors.t
t/embedded-Test-HTML-Content-NoXPath.t
t/embedded-Test-HTML-Content-XPathExtensions.t
t/embedded-Test-HTML-Content.t
t/testlib.pm
testrules.yml
xt/99-changes.t
xt/99-compile.t
xt/99-manifest.t
xt/99-minimumversion.t
xt/99-pod.t
xt/99-synopsis.t
xt/99-test-prerequisites.t
xt/99-todo.t
xt/99-unix-text.t
xt/99-versions.t
xt/copyright.t
xt/meta-lint.t
Test-HTML-Content-0.12/testrules.yml 0000644 0001750 0001750 00000000121 14457155521 016651 0 ustar corion corion ---
# This test suite can be run fully in parallel
par:
- t/*.t
- xt/*.t