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