t/01-constants.t

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4 use lib 't';
   5
   6 use File::Temp qw/tempfile/;
   7 use Test::More tests => 19;
   8
   9 our ($section_1, $section_2, $section_3, $section_4, %options);
  10
  11 sub handle_item {
  12         my ($options, $description) = m/^(.*?)\n\n(.*)/s;
  13         my (@options, $longest);
  14         $longest = "";
  15         for my $option ($options =~ m/\G((?:-\w|--\w+))(?:,\s*)?/g) {
  16                 push @options, $option;
  17                 $longest = $option if length $option > length $longest
  18         }
  19         $longest =~ s/^-*//;
  20         $options{$longest} = {
  21                 options => \@options,
  22                 description => $description,
  23         };
  24 }
  25
  26 sub run_parser {
  27         Pod::Constants->import(
  28                 section_1 => \$section_1,
  29                 -trim     => 1,
  30                 section_2 => \$section_2,
  31                 section_3 => sub { tr/[a-z]/[A-Z]/; $section_3 = $_ },
  32                 section_4 => sub { eval },
  33                 'command line parameters' => sub {
  34                         Pod::Constants::add_hook('*item' => \&handle_item)
  35                 });
  36 }
  37
  38 use_ok('Pod::Constants');
  39 run_parser;
  40
  41 ok $Pod::Constants::VERSION, "Pod::Constants sets its own VERSION";
  42
  43 # to avoid a warning
  44 if ( 0 ) { $Cheese::foo = $ReEntrancyTest::wohoo = $Cheese::quux; }
  45 eval 'use Cheese';
  46
  47 is($section_1, "Down with Pants!\n\n", "no trim from main");
  48 is($section_2, "42", "with trim from main");
  49 is($section_3, "CLANK_EST", "sub");
  50 is($section_4, "touche", "eval");
  51 is($Cheese::foo, "detcepxe", "From module");
  52 is($ReEntrancyTest::wohoo, "Re-entrancy works!", "From module");
  53 is($Cheese::quux, "Blah.", "From module(2)");
  54 like(`$^X -c t/Cheese.pm 2>&1`, qr/syntax OK/, "perl -c module");
  55 like(`$^X -c t/cheese.pl 2>&1`, qr/syntax OK/, "perl -c script");
  56
  57 # test the examples on the man page :)
  58 package Pod::Constants;
  59 Pod::Constants->import (SYNOPSIS => sub {
  60     $main::section_1 = join "\n", map { s/^ //; $_ } split /\n/, $_
  61 });
  62
  63 package main;
  64 # why define your test results when you can read them in from POD?
  65 $section_1 =~ s/myhash\)/myhash, %myhash2)/;
  66 $section_1 =~ s/myhash;/myhash, "%myhash\'s value after the above:" => sub { %myhash2 = eval };/;
  67
  68 my ($fh, $file) = tempfile 'pod-constants-testXXXX', TMPDIR => 1, UNLINK => 1;
  69 print $fh <<"EOF";
  70 package TestManPage;
  71 $section_1;
  72 1
  73 EOF
  74 close $fh;
  75
  76 $INC{'TestManPage.pm'} = $file;
  77 require $file;
  78
  79 is $TestManPage::myvar, 'This string will be loaded into $myvar',"man page example 1";
  80 is $TestManPage::VERSION, $Pod::Constants::VERSION, "man page example 2";
  81 ok $TestManPage::VERSION, "man page example 2 cross-check";
  82 is $TestManPage::myarray[2], 'For example, this is $myarray[2].', "man page example 3";
  83
  84 my $ok = 0;
  85 while (my ($k, $v) = each %TestManPage::myhash) {
  86     if (exists $TestManPage::myhash2{$k}) { $ok ++ };
  87     if ($v eq $TestManPage::myhash2{$k}) { $ok ++ };
  88 }
  89
  90 is $ok, 4, "man page example 4";
  91 is scalar keys %TestManPage::myhash, 2, "man page example 4 cross-check";
  92 is $TestManPage::html, '<p>This text will be in $html</p>', "man page example 5";
  93
  94 # supress warnings
  95 $TestManPage::myvar = $TestManPage::html = undef;
  96 @TestManPage::myarray = ();
  97
  98 is $options{foo}->{options}->[0], "-f", "Pod::Constants::add_hook";
  99
 100 =head2 section_1
 101
 102 Down with Pants!
 103
 104 =head2 section_2
 105
 106 42
 107
 108 =head2 section_3
 109
 110 clank_est
 111
 112 =head2 section_4
 113
 114 $section_4 = "touche"
 115
 116 =cut
 117
 118 =head1 command line parameters
 119
 120 the following command line parameters are supported
 121
 122 =item -f, --foo
 123
 124 This does something cool.
 125
 126 =item -h, --help
 127
 128 This also does something pretty cool.
 129
 130 =cut