1*5486feefSafresh1use strict; 2*5486feefSafresh1use warnings; 3*5486feefSafresh1use Test::More; 4*5486feefSafresh1 5*5486feefSafresh1BEGIN { 6*5486feefSafresh1 package MyXHTML; 7*5486feefSafresh1 use base 'Pod::Simple::XHTML'; 8*5486feefSafresh1 9*5486feefSafresh1 sub new { 10*5486feefSafresh1 my $class = shift; 11*5486feefSafresh1 my $self = $class->SUPER::new(@_); 12*5486feefSafresh1 $self->html_header(''); 13*5486feefSafresh1 $self->html_footer(''); 14*5486feefSafresh1 $self->index(1); 15*5486feefSafresh1 $self->anchor_items(1); 16*5486feefSafresh1 return $self; 17*5486feefSafresh1 } 18*5486feefSafresh1 19*5486feefSafresh1 sub parse_to_string { 20*5486feefSafresh1 my $self = shift; 21*5486feefSafresh1 my $pod = shift; 22*5486feefSafresh1 my $output = ''; 23*5486feefSafresh1 $self->output_string( \$output ); 24*5486feefSafresh1 $self->parse_string_document($pod); 25*5486feefSafresh1 return $output; 26*5486feefSafresh1 } 27*5486feefSafresh1 28*5486feefSafresh1 sub idify { 29*5486feefSafresh1 my ($self, $t, $not_unique) = @_; 30*5486feefSafresh1 for ($t) { 31*5486feefSafresh1 $t =~ s/\A\s+//; 32*5486feefSafresh1 $t =~ s/\s+\z//; 33*5486feefSafresh1 $t =~ s/[\s-]+/-/g; 34*5486feefSafresh1 } 35*5486feefSafresh1 return $t if $not_unique; 36*5486feefSafresh1 my $i = ''; 37*5486feefSafresh1 $i++ while $self->{ids}{"$t$i"}++; 38*5486feefSafresh1 return "$t$i"; 39*5486feefSafresh1 } 40*5486feefSafresh1} 41*5486feefSafresh1 42*5486feefSafresh1 43*5486feefSafresh1my @tests = ( 44*5486feefSafresh1 # Pod id link (url encoded) 45*5486feefSafresh1 [ 'Foo', 'Foo', 'Foo' ], 46*5486feefSafresh1 [ '$@', '$@', '%24%40' ], 47*5486feefSafresh1 [ 'With C<Formatting>', 'With-Formatting', 'With-Formatting' ], 48*5486feefSafresh1 [ '$obj->method($foo)', '$obj->method($foo)', '%24obj-%3Emethod(%24foo)' ], 49*5486feefSafresh1); 50*5486feefSafresh1 51*5486feefSafresh1plan tests => 5 * scalar @tests; 52*5486feefSafresh1 53*5486feefSafresh1my $parser = MyXHTML->new; 54*5486feefSafresh1 55*5486feefSafresh1for my $names (@tests) { 56*5486feefSafresh1 my ($heading, $id, $link) = @$names; 57*5486feefSafresh1 58*5486feefSafresh1 is $link, $parser->encode_url($id), 59*5486feefSafresh1 'assert correct encoding of url fragment'; 60*5486feefSafresh1 61*5486feefSafresh1 my $html_id = $parser->encode_entities($id); 62*5486feefSafresh1 63*5486feefSafresh1 { 64*5486feefSafresh1 my $result = MyXHTML->new->parse_to_string(<<"EOT"); 65*5486feefSafresh1=head1 $heading 66*5486feefSafresh1 67*5486feefSafresh1L<< /$heading >> 68*5486feefSafresh1 69*5486feefSafresh1EOT 70*5486feefSafresh1 like $result, qr{<h1 id="\Q$html_id\E">}, 71*5486feefSafresh1 "heading id generated correctly for '$heading'"; 72*5486feefSafresh1 like $result, qr{<li><a href="\#\Q$link\E">}, 73*5486feefSafresh1 "index link generated correctly for '$heading'"; 74*5486feefSafresh1 like $result, qr{<p><a href="\#\Q$link\E">}, 75*5486feefSafresh1 "L<> link generated correctly for '$heading'"; 76*5486feefSafresh1 } 77*5486feefSafresh1 { 78*5486feefSafresh1 my $result = MyXHTML->new->parse_to_string(<<"EOT"); 79*5486feefSafresh1=over 4 80*5486feefSafresh1 81*5486feefSafresh1=item $heading 82*5486feefSafresh1 83*5486feefSafresh1=back 84*5486feefSafresh1 85*5486feefSafresh1EOT 86*5486feefSafresh1 like $result, qr{<dt id="\Q$html_id\E">}, 87*5486feefSafresh1 "item id generated correctly for '$heading'"; 88*5486feefSafresh1 } 89*5486feefSafresh1} 90