.
HTML
my @links = $p->links;
# There should be 4 links in the document
is(@links, 4);
my $t;
my %attr;
for (@links) {
($t, %attr) = @$_ if $_->[0] eq 'img';
}
is($t, 'img');
is(delete $attr{src}, "http://www.sn.no/foo/img.jpg");
# there should be no more attributes
ok(!scalar(keys %attr));
HTML-Parser-3.83/t/tokeparser.t 0000644 0001750 0001750 00000006433 14652213774 014721 0 ustar olaf olaf use strict;
use warnings;
use HTML::TokeParser ();
use Test::More tests => 17;
# First we create an HTML document to test
my $file = "ttest$$.htm";
die "$file already exists" if -e $file;
{
open(my $fh, '>', $file) or die "Can't create $file: $!";
print {$fh} <<'EOT';
This is the title again
And this is a link to the
Institute
EOT close($fh); } END { unlink($file) || warn "Can't unlink $file: $!"; } my $p; $p = HTML::TokeParser->new($file) || die "Can't open $file: $!"; ok($p->unbroken_text); if ($p->get_tag("foo", "title")) { my $title = $p->get_trimmed_text; #diag "Title: $title"; is($title, "This is the
Heading
HTML ok($p->get_tag("h1")); is($p->get_trimmed_text, "Heading"); undef($p); # test parsing of large embedded documents my $doc = "foo is bar\n\n\n" x 2022; #use Time::HiRes qw(time); my $start = time; $p = HTML::TokeParser->new(\$doc); #diag "Construction time: ", time - $start; my $count; while (my $t = $p->get_token) { $count++ if $t->[0] eq "S"; } #diag "Parse time: ", time - $start; is($count, 2022); $p = HTML::TokeParser->new(\<<'EOT');This is a heading
This is sometext.
This is some more text.
This is even some more. EOT $p->get_tag("/h1"); my $t = $p->get_trimmed_text("br", "p"); is($t, "This is some text."); $p->get_tag; $t = $p->get_trimmed_text("br", "p"); is($t, "This is some more text."); undef($p); $p = HTML::TokeParser->new(\<<'EOT');
This is a bold heading
This is some italic text.This is some more text.
This is even some more.
EOT
$p->get_tag("h1");
$t = $p->get_phrase;
is($t, "This is a bold heading");
$t = $p->get_phrase;
is($t, "");
$p->get_tag;
$t = $p->get_phrase;
is($t, "This is some italic text. This is some more text.");
undef($p);
HTML-Parser-3.83/t/offset.t 0000644 0001750 0001750 00000002421 14652213774 014021 0 ustar olaf olaf use strict;
use warnings;
use HTML::Parser ();
use Test::More tests => 1;
my $HTML = <<'EOT';
Ho ho
<--comment-> EOT $p->parse($doc)->eof; #use Data::Dump; Data::Dump::dump(@expected); for my $i (1 .. length($doc)) { my @t; $p->handler(default => \@t); $p->parse(chunk($doc, $i)); # check that we got the same stuff #diag "X:", join(":", @t); #diag "Y:", join(":", @expected); is(join(":", @t), join(":", @expected)); } sub chunk { my $str = shift; my $size = shift || 1; sub { my $res = substr($str, 0, $size); #diag "...$res"; substr($str, 0, $size) = ""; $res; } } # Test croking behaviour $p->handler(default => []); my $error; { local $@; #<<< do not let perltidy touch this $error = $@ || 'Error' unless eval { $p->parse(sub { die "Hi" }); 1 }; #>>> } like($error, qr/^Hi/); HTML-Parser-3.83/t/argspec.t 0000644 0001750 0001750 00000010512 14652213774 014157 0 ustar olaf olaf use strict; use warnings; use HTML::Parser (); use Test::More; my $decl = ''; my $com1 = ''; my $com2 = ''; my $start = ''; my $end = ''; my $empty = "
- >|\n|<
- >|</id=33>>|",
'|<
- >|< å/id=34>>', "|>>ul<<|", "|>>body<<|\n\n|", ) { if ($res !~ /\Q$_\E/) { diag "Can't find '$_' in parsed document"; $bad++; } } diag $res if $bad || $ENV{PRINT_RESULTS}; # And we check that we get the same result all the time $res =~ s/\|//g; # remove all break marks if ($last_res && $res ne $last_res) { diag "The result is not the same as last time"; $bad++; } $last_res = $res; unless ($res =~ /Various entities/) { diag "Some text must be missing"; $bad++; } ok(!$bad); } HTML-Parser-3.83/t/case-sensitive.t 0000644 0001750 0001750 00000003245 14652213774 015462 0 ustar olaf olaf use strict; use warnings; use HTML::Parser (); use Test::More tests => 8; my $p = HTML::Parser->new(); $p->case_sensitive(1); my $text = ""; $p->handler( start => sub { my ($tag, $attr, $attrseq) = @_; $text .= "S[$tag"; for my $k (sort keys %$attr) { my $v = $attr->{$k}; $text .= " $k=$v"; } if (@$attrseq) { $text .= " Order:"; } for my $k (@$attrseq) { $text .= " $k"; } $text .= "]"; }, "tagname,attr,attrseq" ); $p->handler( end => sub { my ($tag) = @_; $text .= "E[$tag]"; }, "tagname" ); my $html = <<'EOT';
EOT my $cs = 'S[tAg aRg=Value arg=other value Order: aRg arg]E[tAg]'; my $ci = 'S[tag arg=Value Order: arg arg]E[tag]'; $p->parse($html)->eof; is($text, $cs); $text = ""; $p->case_sensitive(0); $p->parse($html)->eof; is($text, $ci); $text = ""; $p->case_sensitive(1); $p->xml_mode(1); $p->parse($html)->eof; is($text, $cs); $text = ""; $p->case_sensitive(0); $p->parse($html)->eof; is($text, $cs); $html = <<'EOT'; EOT $p->ignore_tags('ignore'); $cs = 'S[tAg aRg=Value arg=other value Order: aRg arg]E[tAg]S[iGnOrE]'; $ci = 'S[tag arg=Value Order: arg arg]E[tag]'; $text = ""; $p->case_sensitive(0); $p->xml_mode(0); $p->parse($html)->eof; is($text, $ci); $text = ""; $p->case_sensitive(1); $p->xml_mode(0); $p->parse($html)->eof; is($text, $cs); $text = ""; $p->case_sensitive(0); $p->xml_mode(1); $p->parse($html)->eof; is($text, $cs); $text = ""; $p->case_sensitive(1); $p->xml_mode(1); $p->parse($html)->eof; is($text, $cs); HTML-Parser-3.83/t/api_version.t 0000644 0001750 0001750 00000001102 14652213774 015044 0 ustar olaf olaf use strict; use warnings; use HTML::Parser (); use Test::More tests => 4; my $p = HTML::Parser->new(api_version => 3); ok(!$p->handler("start"), "API version 3"); my $error; my $success = 0; { local $@; #<<< do not let perltidy touch this $error = $@ || 'Error' unless eval { my $p = HTML::Parser->new(api_version => 4); $success = 1; }; #>>> } like($error, qr/^API version 4 not supported/, 'API v4 error'); ok(!$success, "!API version 4"); $p = HTML::Parser->new(api_version => 2); is($p->handler("start"), "start", "API version 2"); HTML-Parser-3.83/t/crashme.t 0000644 0001750 0001750 00000001426 14652213774 014161 0 ustar olaf olaf use strict; use warnings; use HTML::Parser (); use Test::More; my $no_tests = shift || 3; plan tests => $no_tests; my $file = "junk$$.html"; die if -e $file; for (1 .. $no_tests) { open(my $junk, '>', $file) || die; for (1 .. rand(5000)) { for (1 .. rand(200)) { print {$junk} pack("N", rand(2**32)); } print {$junk} ("<", "&", ">")[rand(3)]; # make these a bit more likely } close($junk); #diag "Parse @{[-s $file]} bytes of junk"; HTML::Parser->new->parse_file($file); pass(); #print_mem(); } unlink($file); sub print_mem { # this probably only works on Linux open(my $stat, "/proc/self/status") || return; while (defined(my $line = <$stat>)) { diag $line if $line =~ /^VmSize/; } } HTML-Parser-3.83/t/linkextor-rel.t 0000644 0001750 0001750 00000001415 14652213774 015334 0 ustar olaf olaf use strict; use warnings; use HTML::LinkExtor (); use Test::More tests => 3; my $HTML = < This is link and an .
HTML
# Try the callback interface
my $links = "";
my $p = HTML::LinkExtor->new(sub {
my($tag, %links) = @_;
#diag "$tag @{[%links]}";
$links .= "$tag @{[%links]}\n";
});
$p->parse($HTML); $p->eof;
ok($links =~ m|^base href http://www\.sn\.no/$|m);
ok($links =~ m|^a href link\.html$|m);
# Used to be problems when using the links method on a document with
# no links it it. This is a test to prove that it works.
$p = new HTML::LinkExtor;
$p->parse("this is a document with no links"); $p->eof;
my @links = $p->links;
is(@links, 0);
HTML-Parser-3.83/t/argspec-bad.t 0000644 0001750 0001750 00000001556 14652213774 014713 0 ustar olaf olaf use strict;
use warnings;
use HTML::Parser ();
use Test::More tests => 6;
my $p = HTML::Parser->new(api_version => 3);
sub test_error {
my ($arg, $check_exp) = @_;
my $error;
{
local $@;
#<<< do not let perltidy touch this
$error = $@ || 'Error' unless eval {
$p->handler(end => "end", $arg);
1
};
#>>>
}
like($error, $check_exp);
}
test_error(q(xyzzy), qr/^Unrecognized identifier xyzzy/);
test_error(q(tagname text), qr/^Missing comma separator/);
test_error(q(tagname, "text), qr/^Unterminated literal string/);
test_error(q(tagname, "t\\t"), qr/^Backslash reserved for literal string/);
test_error('"' . ("x" x 256) . '"',
qr/^Literal string is longer than 255 chars/);
$p->handler(end => sub { is(length(shift), 255) }, '"' . ("x" x 255) . '"');
$p->parse(" - >|< å/id=34>>', "|>>ul<<|", "|>>body<<|\n\n|", ) { if ($res !~ /\Q$_\E/) { diag "Can't find '$_' in parsed document"; $bad++; } } diag $res if $bad || $ENV{PRINT_RESULTS}; # And we check that we get the same result all the time $res =~ s/\|//g; # remove all break marks if ($last_res && $res ne $last_res) { diag "The result is not the same as last time"; $bad++; } $last_res = $res; unless ($res =~ /Various entities/) { diag "Some text must be missing"; $bad++; } ok(!$bad); } HTML-Parser-3.83/t/case-sensitive.t 0000644 0001750 0001750 00000003245 14652213774 015462 0 ustar olaf olaf use strict; use warnings; use HTML::Parser (); use Test::More tests => 8; my $p = HTML::Parser->new(); $p->case_sensitive(1); my $text = ""; $p->handler( start => sub { my ($tag, $attr, $attrseq) = @_; $text .= "S[$tag"; for my $k (sort keys %$attr) { my $v = $attr->{$k}; $text .= " $k=$v"; } if (@$attrseq) { $text .= " Order:"; } for my $k (@$attrseq) { $text .= " $k"; } $text .= "]"; }, "tagname,attr,attrseq" ); $p->handler( end => sub { my ($tag) = @_; $text .= "E[$tag]"; }, "tagname" ); my $html = <<'EOT';