1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
use strict;
use warnings;
package # no_index
MarkdownTests;
use Test::More 0.88; # done_testing
use Test::Differences;
use Pod::Markdown ();
use Exporter ();
our @ISA = qw(Exporter);
our @EXPORT = (
qw(
convert_ok
hex_escape
io_string
eq_or_diff
slurp_file
test_parser
warning
with_and_without_entities
),
@Test::More::EXPORT
);
sub import {
my $class = shift;
Test::More::plan(@_) if @_;
@_ = ($class);
strict->import;
warnings->import;
goto &Exporter::import;
}
sub hex_escape {
local $_ = $_[0];
s/([^\x20-\x7e])/sprintf "\\x{%x}", ord $1/ge;
return $_;
}
sub diag_xml {
diag_with('Pod::Simple::DumpAsXML', @_);
}
sub diag_text {
diag_with('Pod::Simple::DumpAsText', @_);
}
sub diag_with {
my ($class, $pod) = @_;
$class =~ /[^a-zA-Z0-9:]/ and die "Invalid class name '$class'";
eval "require $class" or die $@;
my $parser = $class->new;
$parser->output_string(\(my $got));
$parser->parse_string_document("=pod\n\n$pod\n");
diag $got;
}
sub hash_string {
my $h = $_[0];
return join ', ', map { "$_: $h->{$_}" } sort keys %$h;
}
sub convert_ok {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my ($pod, $exp, $desc, %opts) = @_;
my %attr = %{ $opts{attr} || {} };
my $parser = test_parser(%attr);
my $prefix = $opts{prefix} || '';
my $podenc = ($opts{encoding} ? "=encoding $opts{encoding}\n\n" : '');
if( $opts{verbose} ){
$desc .= " \t" . hex_escape "($pod => $exp)";
$desc .= join ' ', ' (', hash_string(\%attr), ')' if keys %attr;
$desc .= " =encoding $opts{encoding}" if $podenc;
}
diag_xml($pod) if $opts{diag_xml};
diag_text($pod) if $opts{diag_text};
$opts{init}->($parser) if $opts{init};
$parser->output_string(\(my $got));
$parser->parse_string_document("$podenc=pod\n\n$prefix$pod\n\n=cut\n");
# Chomp both ends.
for ($got, $exp) {
s/^\n+//;
s/\n+$//;
}
eq_or_diff($got, $prefix.$exp, $desc);
}
sub test_parser {
Pod::Markdown->new(
# Default to very simple values for simple tests.
perldoc_url_prefix => 'pod://',
# Just return the raw fragment so we know that it isn't unexpectedly mangled.
perldoc_fragment_format => sub { $_ },
markdown_fragment_format => sub { $_ },
@_
);
}
{ package # no_index
MarkdownTests::IOString;
use Symbol ();
sub new {
my $class = ref($_[0]) || $_[0];
my $s = $_[1];
my $self = Symbol::gensym;
tie *$self, $class, $self;
*$self->{lines} = [map { "$_\n" } split /\n/, $s ];
$self;
}
sub READLINE { shift @{ *{$_[0]}->{lines} } }
sub TIEHANDLE {
my ($class, $s) = @_;
bless $s, $class;
}
{ no warnings 'once'; *getline = \&READLINE; }
}
sub io_string {
MarkdownTests::IOString->new(@_);
}
sub slurp_file {
my $path = shift;
open(my $fh, '<', $path)
or die "Failed to open $path: $!";
slurp_fh($fh)
}
sub slurp_fh { my $fh = shift; local $/; <$fh>; }
# Similar interface to Test::Fatal;
sub warning (&) { ## no critic (Prototypes)
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, $_[0] };
$_[0]->();
pop @warnings;
}
sub with_and_without_entities (&) { ## no critic (Prototypes)
SKIP: for my $ents ( 0, 1 ){
if( $ents && ! $Pod::Markdown::HAS_HTML_ENTITIES ){
skip 'HTML::Entities required for this test', 1;
}
local $Pod::Markdown::HAS_HTML_ENTITIES = $ents;
$_[0]->($ents);
}
}
1;
|
