7 if ($^O eq 'MSWin32' || $^O eq 'VMS') {
8 plan skip_all => "Not portable on Win32 or VMS\n";
13 use_ok ("Pod::Usage");
19 my $pid = open(TEST_IN, "-|");
20 unless(defined $pid) {
21 die "Cannot fork: $!";
30 print "#EXIT=$exit OUTPUT=+++#@out#+++\n";
31 return($exit, join("",@out));
34 open(STDERR, ">&STDOUT");
35 Test::More->builder->no_ending(1);
37 print "--NORMAL-RETURN--\n";
43 my ($left,$right) = @_;
44 $left =~ s/^#\s+/#/gm;
45 $right =~ s/^#\s+/#/gm;
52 if('Pod::Usage'->isa('Pod::Text') && $Pod::Text::VERSION < 2.18) {
53 skip("Formatting with Pod::Text $Pod::Text::VERSION not reliable", 33);
56 my ($exit, $text) = getoutput( sub { pod2usage() } );
57 is ($exit, 2, "Exit status pod2usage ()");
58 ok (compare ($text, <<'EOT'), "Output test pod2usage ()");
60 # frobnicate [ -r | --recursive ] [ -f | --force ] file ...
64 ($exit, $text) = getoutput( sub { pod2usage(
65 -message => 'You naughty person, what did you say?',
67 is ($exit, 1, "Exit status pod2usage (-message => '...', -verbose => 1)");
68 ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbose => 1)") or diag("Got:\n$text\n");
69 #You naughty person, what did you say?
71 # frobnicate [ -r | --recursive ] [ -f | --force ] file ...
81 # Specify number of frobs, default is 42.
85 ($exit, $text) = getoutput( sub { pod2usage(
86 -verbose => 2, -exit => 42 ) } );
87 is ($exit, 42, "Exit status pod2usage (-verbose => 2, -exit => 42)");
88 ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -exit => 42)");
90 # frobnicate - do what I mean
93 # frobnicate [ -r | --recursive ] [ -f | --force ] file ...
96 # frobnicate does foo and bar and what not.
106 # Specify number of frobs, default is 42.
110 ($exit, $text) = getoutput( sub { pod2usage(0) } );
111 is ($exit, 0, "Exit status pod2usage (0)");
112 ok (compare ($text, <<'EOT'), "Output test pod2usage (0)");
114 # frobnicate [ -r | --recursive ] [ -f | --force ] file ...
124 # Specify number of frobs, default is 42.
128 ($exit, $text) = getoutput( sub { pod2usage(42) } );
129 is ($exit, 42, "Exit status pod2usage (42)");
130 ok (compare ($text, <<'EOT'), "Output test pod2usage (42)");
132 # frobnicate [ -r | --recursive ] [ -f | --force ] file ...
136 ($exit, $text) = getoutput( sub { pod2usage(-verbose => 0, -exit => 'NOEXIT') } );
137 is ($exit, 0, "Exit status pod2usage (-verbose => 0, -exit => 'NOEXIT')");
138 ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 0, -exit => 'NOEXIT')");
140 # frobnicate [ -r | --recursive ] [ -f | --force ] file ...
145 ($exit, $text) = getoutput( sub { pod2usage(-verbose => 99, -sections => 'DESCRIPTION') } );
146 is ($exit, 1, "Exit status pod2usage (-verbose => 99, -sections => 'DESCRIPTION')");
147 ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 99, -sections => 'DESCRIPTION')");
149 # frobnicate does foo and bar and what not.
153 # does the __DATA__ work ok as input
154 my ($blib, $test_script, $pod_file1, , $pod_file2);
155 if ($ENV{PERL_CORE}) {
157 $test_script = File::Spec->catfile(qw(pod p2u_data.pl));
158 $pod_file1 = File::Spec->catfile(qw(pod usage.pod));
159 $pod_file2 = File::Spec->catfile(qw(pod usage2.pod));
162 $test_script = File::Spec->catfile(qw(t pod p2u_data.pl));
163 $pod_file1 = File::Spec->catfile(qw(t pod usage.pod));
164 $pod_file2 = File::Spec->catfile(qw(t pod usage2.pod));
167 ($exit, $text) = getoutput( sub { system($^X, $blib, $test_script); exit($? >> 8); } );
168 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
169 is ($exit, 17, "Exit status pod2usage (-verbose => 2, -input => \*DATA)");
170 ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -input => \*DATA)") or diag "Got:\n$text\n";
175 # perl podusagetest.pl
182 # test that SYNOPSIS and USAGE are printed
183 ($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
184 -exitval => 0, -verbose => 0); });
185 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
186 is ($exit, 0, "Exit status pod2usage with USAGE");
187 ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE") or diag "Got:\n$text\n";
189 # This is a test for CPAN#33020
192 # And this will be also printed.
196 # test that SYNOPSIS and USAGE are printed with options
197 ($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
198 -exitval => 0, -verbose => 1); });
199 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
200 is ($exit, 0, "Exit status pod2usage with USAGE and verbose=1");
201 ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=1") or diag "Got:\n$text\n";
203 # This is a test for CPAN#33020
206 # And this will be also printed.
209 # And this with verbose == 1
213 # test that only USAGE is printed when requested
214 ($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
215 -exitval => 0, -verbose => 99, -sections => 'USAGE'); });
216 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
217 is ($exit, 0, "Exit status pod2usage with USAGE and verbose=99");
218 ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=99") or diag "Got:\n$text\n";
220 # This is a test for CPAN#33020
224 # test with pod_where
225 use_ok('Pod::Find', qw(pod_where));
226 +# Exclude current dir when testing in CORE; otherwise on case-insensitive
227 +# systems, when in t/ we find pod/usage.pod rather than # ../lib/Pod/Usage.pm
228 +my @NO_CURDIR = ($ENV{PERL_CORE})
232 ($exit, $text) = getoutput( sub { pod2usage( -input => pod_where({-inc => 1, @NO_CURDIR}, 'Pod::Usage'),
233 -exitval => 0, -verbose => 0) } );
234 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
235 is ($exit, 0, "Exit status pod2usage with Pod::Find");
236 ok (compare ($text, <<'EOT'), "Output test pod2usage with Pod::Find") or diag "Got:\n$text\n";
240 # my $message_text = "This text precedes the usage message.";
241 # my $exit_status = 2; ## The exit status to use
242 # my $verbose_level = 0; ## The verbose level to use
243 # my $filehandle = \*STDERR; ## The filehandle to write to
245 # pod2usage($message_text);
247 # pod2usage($exit_status);
249 # pod2usage( { -message => $message_text ,
250 # -exitval => $exit_status ,
251 # -verbose => $verbose_level,
252 # -output => $filehandle } );
254 # pod2usage( -msg => $message_text ,
255 # -exitval => $exit_status ,
256 # -verbose => $verbose_level,
257 # -output => $filehandle );
259 # pod2usage( -verbose => 2,
264 # verify that sections are correctly found after nested headings
265 ($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file2,
266 -exitval => 0, -verbose => 99,
267 -sections => [qw(BugHeader BugHeader/.*')]) });
268 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
269 is ($exit, 0, "Exit status pod2usage with nested headings");
270 ok (compare ($text, <<'EOT'), "Output test pod2usage with nested headings") or diag "Got:\n$text\n";
280 # Verify that =over =back work OK
281 ($exit, $text) = getoutput( sub {
282 pod2usage(-input => $pod_file2,
283 -exitval => 0, -verbose => 99, -sections => 'BugHeader/BugHeader2') } );
284 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
285 is ($exit, 0, "Exit status pod2usage with over/back");
286 ok (compare ($text, <<'EOT'), "Output test pod2usage with over/back") or diag "Got:\n$text\n";
293 # new array API for -sections
294 ($exit, $text) = getoutput( sub {
295 pod2usage(-input => $pod_file2,
296 -exitval => 0, -verbose => 99, -sections => [qw(Heading-1/!.+ Heading-2/.+)]) } );
297 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
298 is ($exit, 0, "Exit status pod2usage with -sections => []");
299 ok (compare ($text, <<'EOT'), "Output test pod2usage with -sections => []") or diag "Got:\n$text\n";
309 # allow subheadings in OPTIONS and ARGUMENTS
310 ($exit, $text) = getoutput( sub {
311 pod2usage(-input => $pod_file2,
312 -exitval => 0, -verbose => 1) } );
313 $text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
314 $text =~ s{[*](destination|files)[*]}{$1}g; # strip * chars
315 is ($exit, 0, "Exit status pod2usage with subheadings in OPTIONS");
316 ok (compare ($text, <<'EOT'), "Output test pod2usage with subheadings in OPTIONS") or diag "Got:\n$text\n";
317 #Options and Arguments:
319 # The required arguments (which typically follow any options on the
326 # Options may be abbreviated. Options which take values may be separated
327 # from the values by whitespace or the "=" character.
336 frobnicate - do what I mean
340 B<frobnicate> S<[ B<-r> | B<--recursive> ]> S<[ B<-f> | B<--force> ]>
345 B<frobnicate> does foo and bar and what not.
351 =item B<-r> | B<--recursive>
355 =item B<-f> | B<--force>
361 Specify number of frobs, default is 42.