1#!/usr/bin/perl -w
2
3use strict;
4use warnings;
5use Test::More;
6use File::Basename qw(fileparse);
7use File::Spec;
8
9BEGIN {
10  if ($^O eq 'MSWin32' || $^O eq 'VMS') {
11    plan skip_all => "Not portable on Win32 or VMS\n";
12  }
13  else {
14    plan tests => 42;
15  }
16  use_ok ("Pod::Usage");
17}
18
19sub getoutput
20{
21  my ($code) = @_;
22  my $pid = open(my $in, "-|");
23  die "Cannot fork: $!" unless defined $pid;
24  if ($pid) {
25    # parent
26    my @out = <$in>;
27    close($in);
28
29    my $exit = $?>>8;
30    s/^/#/ for @out;
31
32    local $" = "";
33
34    print "#EXIT=$exit OUTPUT=+++#@out#+++\n";
35    waitpid( $pid, 1 );
36
37    return ($exit, join("", @out) );
38  }
39  # child
40  open (STDERR, ">&STDOUT");
41
42  Test::More->builder->no_ending(1);
43  local $SIG{ALRM} = sub { die "Alarm reached" };
44  alarm(600);
45
46  # this could hang
47  $code->();
48  print "--NORMAL-RETURN--\n";
49  exit 0;
50}
51
52sub compare
53{
54  my ($left,$right) = @_;
55  $left  =~ s/^#\s+/#/gm;
56  $right =~ s/^#\s+/#/gm;
57  $left  =~ s/\s+/ /gm;
58  $right =~ s/\s+/ /gm;
59  $left eq $right;
60}
61
62SKIP: {
63if('Pod::Usage'->isa('Pod::Text') && $Pod::Text::VERSION < 2.18) {
64  skip("Formatting with Pod::Text $Pod::Text::VERSION not reliable", 33);
65}
66
67my ($exit, $text) = getoutput( sub { pod2usage() } );
68is ($exit, 2,                 "Exit status pod2usage ()");
69ok (compare ($text, <<'EOT'), "Output test pod2usage ()");
70#Usage:
71#    frobnicate [ -r | --recursive ] [ -f | --force ] file ...
72#
73EOT
74
75($exit, $text) = getoutput( sub { pod2usage(
76  -message => 'You naughty person, what did you say?',
77  -verbose => 1 ) });
78is ($exit, 1,                 "Exit status pod2usage (-message => '...', -verbose => 1)");
79ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbose => 1)") or diag("Got:\n$text\n");
80#You naughty person, what did you say?
81# Usage:
82#     frobnicate [ -r | --recursive ] [ -f | --force ] file ...
83#
84# Options:
85#     -r | --recursive
86#         Run recursively.
87#
88#     -f | --force
89#         Just do it!
90#
91#     -n number
92#         Specify number of frobs, default is 42.
93#
94EOT
95
96($exit, $text) = getoutput( sub { pod2usage(
97  -verbose => 2, -exit => 42 ) } );
98is ($exit, 42,                "Exit status pod2usage (-verbose => 2, -exit => 42)");
99ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -exit => 42)");
100#NAME
101#     frobnicate - do what I mean
102#
103# SYNOPSIS
104#     frobnicate [ -r | --recursive ] [ -f | --force ] file ...
105#
106# DESCRIPTION
107#     frobnicate does foo and bar and what not.
108#
109# OPTIONS
110#     -r | --recursive
111#         Run recursively.
112#
113#     -f | --force
114#         Just do it!
115#
116#     -n number
117#         Specify number of frobs, default is 42.
118#
119EOT
120
121($exit, $text) = getoutput( sub { pod2usage(0) } );
122is ($exit, 0,                 "Exit status pod2usage (0)");
123ok (compare ($text, <<'EOT'), "Output test pod2usage (0)");
124#Usage:
125#     frobnicate [ -r | --recursive ] [ -f | --force ] file ...
126#
127# Options:
128#     -r | --recursive
129#         Run recursively.
130#
131#     -f | --force
132#         Just do it!
133#
134#     -n number
135#         Specify number of frobs, default is 42.
136#
137EOT
138
139($exit, $text) = getoutput( sub { pod2usage(42) } );
140is ($exit, 42,                "Exit status pod2usage (42)");
141ok (compare ($text, <<'EOT'), "Output test pod2usage (42)");
142#Usage:
143#     frobnicate [ -r | --recursive ] [ -f | --force ] file ...
144#
145EOT
146
147($exit, $text) = getoutput( sub { pod2usage(-verbose => 0, -exit => 'NOEXIT') } );
148is ($exit, 0,                 "Exit status pod2usage (-verbose => 0, -exit => 'NOEXIT')");
149ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 0, -exit => 'NOEXIT')");
150#Usage:
151#     frobnicate [ -r | --recursive ] [ -f | --force ] file ...
152#
153# --NORMAL-RETURN--
154EOT
155
156($exit, $text) = getoutput( sub { pod2usage(-verbose => 99, -sections => 'DESCRIPTION') } );
157is ($exit, 1,                 "Exit status pod2usage (-verbose => 99, -sections => 'DESCRIPTION')");
158ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 99, -sections => 'DESCRIPTION')");
159#Description:
160#     frobnicate does foo and bar and what not.
161#
162EOT
163
164# does the __DATA__ work ok as input
165my (@blib, $test_script, $pod_file1, , $pod_file2);
166if (!$ENV{PERL_CORE}) {
167  @blib = '-Mblib';
168}
169$test_script = File::Spec->catfile(qw(t pod p2u_data.pl));
170$pod_file1 = File::Spec->catfile(qw(t pod usage.pod));
171$pod_file2 = File::Spec->catfile(qw(t pod usage2.pod));
172
173
174($exit, $text) = getoutput( sub { system($^X, @blib, $test_script); exit($?  >> 8); } );
175$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
176is ($exit, 17,                 "Exit status pod2usage (-verbose => 2, -input => \*DATA)");
177ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -input => \*DATA)") or diag "Got:\n$text\n";
178#NAME
179#    Test
180#
181#SYNOPSIS
182#    perl podusagetest.pl
183#
184#DESCRIPTION
185#    This is a test.
186#
187EOT
188
189# test that SYNOPSIS and USAGE are printed
190($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
191                                            -exitval => 0, -verbose => 0); });
192$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
193is ($exit, 0,                 "Exit status pod2usage with USAGE");
194ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE") or diag "Got:\n$text\n";
195#Usage:
196#    This is a test for CPAN#33020
197#
198#Usage:
199#    And this will be also printed.
200#
201EOT
202
203# test that SYNOPSIS and USAGE are printed with options
204($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
205                                            -exitval => 0, -verbose => 1); });
206$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
207is ($exit, 0,                 "Exit status pod2usage with USAGE and verbose=1");
208ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=1") or diag "Got:\n$text\n";
209#Usage:
210#    This is a test for CPAN#33020
211#
212#Usage:
213#    And this will be also printed.
214#
215#Options:
216#    And this with verbose == 1
217#
218EOT
219
220# test that only USAGE is printed when requested
221($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
222                                            -exitval => 0, -verbose => 99, -sections => 'USAGE'); });
223$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
224is ($exit, 0,                 "Exit status pod2usage with USAGE and verbose=99");
225ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=99") or diag "Got:\n$text\n";
226#Usage:
227#    This is a test for CPAN#33020
228#
229EOT
230
231# test with self
232
233my $src = File::Spec->catfile(qw(lib Pod Usage.pm));
234($exit, $text) = getoutput( sub { pod2usage( -input => $src,
235                                             -exitval => 0, -verbose => 0) } );
236$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
237is ($exit, 0,                 "Exit status pod2usage with self");
238ok (compare ($text, <<'EOT'), "Output test pod2usage with self") or diag "Got:\n$text\n";
239#Usage:
240#      use Pod::Usage;
241#
242#      my $message_text  = "This text precedes the usage message.";
243#      my $exit_status   = 2;          ## The exit status to use
244#      my $verbose_level = 0;          ## The verbose level to use
245#      my $filehandle    = \*STDERR;   ## The filehandle to write to
246#
247#      pod2usage($message_text);
248#
249#      pod2usage($exit_status);
250#
251#      pod2usage( { -message => $message_text ,
252#                   -exitval => $exit_status  ,
253#                   -verbose => $verbose_level,
254#                   -output  => $filehandle } );
255#
256#      pod2usage(   -msg     => $message_text ,
257#                   -exitval => $exit_status  ,
258#                   -verbose => $verbose_level,
259#                   -output  => $filehandle   );
260#
261#      pod2usage(   -verbose => 2,
262#                   -noperldoc => 1  );
263#
264#      pod2usage(   -verbose => 2,
265#                   -perlcmd => $path_to_perl,
266#                   -perldoc => $path_to_perldoc,
267#                   -perldocopt => $perldoc_options );
268#
269EOT
270
271# verify that sections are correctly found after nested headings
272($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file2,
273                                            -exitval => 0, -verbose => 99,
274                                            -sections => [qw(BugHeader BugHeader/.*')]) });
275$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
276is ($exit, 0,                 "Exit status pod2usage with nested headings");
277ok (compare ($text, <<'EOT'), "Output test pod2usage with nested headings") or diag "Got:\n$text\n";
278#BugHeader:
279#    Some text
280#
281#  BugHeader2:
282#    More
283#    Still More
284#
285EOT
286
287# Verify that =over =back work OK
288($exit, $text) = getoutput( sub {
289  pod2usage(-input => $pod_file2,
290            -exitval => 0, -verbose => 99, -sections => 'BugHeader/BugHeader2') } );
291$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
292is ($exit, 0,                 "Exit status pod2usage with over/back");
293ok (compare ($text, <<'EOT'), "Output test pod2usage with over/back") or diag "Got:\n$text\n";
294#  BugHeader2:
295#    More
296#    Still More
297#
298EOT
299
300# new array API for -sections
301($exit, $text) = getoutput( sub {
302  pod2usage(-input => $pod_file2,
303            -exitval => 0, -verbose => 99, -sections => [qw(Heading-1/!.+ Heading-2/.+)]) } );
304$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
305is ($exit, 0,                 "Exit status pod2usage with -sections => []");
306ok (compare ($text, <<'EOT'), "Output test pod2usage with -sections => []") or diag "Got:\n$text\n";
307#Heading-1:
308#    One
309#    Two
310#
311#  Heading-2.2:
312#    More text.
313#
314EOT
315
316# allow subheadings in OPTIONS and ARGUMENTS
317($exit, $text) = getoutput( sub {
318  pod2usage(-input => $pod_file2,
319            -exitval => 0, -verbose => 1) } );
320$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
321$text =~ s{[*](destination|files)[*]}{$1}g; # strip * chars
322is ($exit, 0,                 "Exit status pod2usage with subheadings in OPTIONS");
323ok (compare ($text, <<'EOT'), "Output test pod2usage with subheadings in OPTIONS") or diag "Got:\n$text\n";
324#Options and Arguments:
325#  Arguments:
326#    The required arguments (which typically follow any options on the
327#    command line) are:
328#
329#    destination
330#    files
331#
332#  Options:
333#    Options may be abbreviated. Options which take values may be separated
334#    from the values by whitespace or the "=" character.
335#
336EOT
337
338# test various use cases of calling pod2usage to increase coverage
339($exit, $text) = getoutput( sub {
340  pod2usage({ -input => $pod_file2,
341            -exitval => 3, -verbose => 0 }) } );
342is ($exit, 3,                 "Exit status pod2usage with hash options");
343like ($text, qr/^\s*$/s, "Output test pod2usage with hash options is empty") or diag "Got:\n$text\n";
344
345# call with single string option
346($exit, $text) = getoutput( sub {
347  pod2usage('Just print this') } );
348is ($exit, 2,                 "Exit status pod2usage with single string option");
349like ($text, qr/^#Just print this/, "Output test pod2usage with single string options has first line") or diag "Got:\n$text\n";
350
351# call with search path and relative file name
352my ($file, $dir) = fileparse($0);
353($exit, $text) = getoutput( sub {
354  pod2usage({ -input => $file, -pathlist => [ $dir ], -exit => 0, -verbose => 2 } ) } );
355is ($exit, 0,                 "Exit status pod2usage with relative path");
356like ($text, qr/frobnicate - do what I mean/, "Output test pod2usage with relative path works OK") or diag "Got:\n$text\n";
357
358# trigger specific perldoc case
359# ...and one coverage line
360{ no warnings;
361  *Pod::Usage::initialize = sub { 1; };
362}
363
364our $TODO;
365SKIP: {
366    my $perldoc = $^X . 'doc';
367    skip "Missing perldoc binary", 2 unless -x $perldoc;
368
369    my $out = qx[$perldoc 2>&1] || '';
370    skip "Need perl-doc package", 2 if $out =~ qr[You need to install the perl-doc package to use this program];
371
372    ($exit, $text) = getoutput( sub {
373        require Pod::Perldoc;
374      my $devnull = File::Spec->devnull();
375      open(SAVE_STDOUT, '>&', \*STDOUT);
376      open(STDOUT, '>', $devnull);
377      pod2usage({ -verbose => 2, -input => $0, -output => \*STDOUT, -exit => 0, -message => 'Special perldoc case', -perldocopt => '-i' });
378      open(STDOUT, '>&', \*SAVE_STDOUT);
379      } );
380    is ($exit, 0,                 "Exit status pod2usage with special perldoc case");
381    # output went to devnull
382    TODO: {
383        local $TODO = q[Can get output from stty view #14];
384        is( length($text), 0, "Output test pod2usage with special perldoc case") or diag "Got:\n$text\n";
385    }
386}
387
388# bad regexp syntax
389($exit, $text) = getoutput( sub { pod2usage( -verbose => 99, -sections => 'DESCRIPTION{BLAH') } );
390like ($text, qr/Bad regular expression/, "Output test pod2usage with bad section regexp");
391
392} # end SKIP
393
394__END__
395
396=head1 NAME
397
398frobnicate - do what I mean
399
400=head1 SYNOPSIS
401
402B<frobnicate> S<[ B<-r> | B<--recursive> ]> S<[ B<-f> | B<--force> ]>
403  file ...
404
405=head1 DESCRIPTION
406
407B<frobnicate> does foo and bar and what not.
408
409=head1 OPTIONS
410
411=over 4
412
413=item B<-r> | B<--recursive>
414
415Run recursively.
416
417=item B<-f> | B<--force>
418
419Just do it!
420
421=item B<-n> number
422
423Specify number of frobs, default is 42.
424
425=back
426
427=cut
428
429