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 => 20;
   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                 'GUI parameters'  => sub {
  34                         Pod::Constants::delete_hook('*item')
  35                 },
  36                 'command line parameters' => sub {
  37                         Pod::Constants::add_hook('*item' => \&handle_item)
  38                 });
  39 }
  40
  41 use_ok('Pod::Constants');
  42 run_parser;
  43
  44 ok $Pod::Constants::VERSION, "Pod::Constants sets its own VERSION";
  45
  46 # to avoid a warning
  47 if ( 0 ) { $Cheese::foo = $ReEntrancyTest::wohoo = $Cheese::quux; }
  48 eval 'use Cheese';
  49
  50 is($section_1, "Down with Pants!\n\n", "no trim from main");
  51 is($section_2, "42", "with trim from main");
  52 is($section_3, "CLANK_EST", "sub");
  53 is($section_4, "touche", "eval");
  54 is($Cheese::foo, "detcepxe", "From module");
  55 is($ReEntrancyTest::wohoo, "Re-entrancy works!", "From module");
  56 is($Cheese::quux, "Blah.", "From module(2)");
  57 like(`$^X -c t/Cheese.pm 2>&1`, qr/syntax OK/, "perl -c module");
  58 like(`$^X -c t/cheese.pl 2>&1`, qr/syntax OK/, "perl -c script");
  59
  60 # test the examples on the man page :)
  61 package Pod::Constants;
  62 Pod::Constants->import (SYNOPSIS => sub {
  63     $main::section_1 = join "\n", map { s/^ //; $_ } split /\n/, $_
  64 });
  65
  66 package main;
  67 # why define your test results when you can read them in from POD?
  68 $section_1 =~ s/myhash\)/myhash, %myhash2)/;
  69 $section_1 =~ s/myhash;/myhash, "%myhash\'s value after the above:" => sub { %myhash2 = eval };/;
  70
  71 my ($fh, $file) = tempfile 'pod-constants-testXXXX', TMPDIR => 1, UNLINK => 1;
  72 print $fh <<"EOF";
  73 package TestManPage;
  74 $section_1;
  75 1
  76 EOF
  77 close $fh;
  78
  79 $INC{'TestManPage.pm'} = $file;
  80 require $file;
  81
  82 is $TestManPage::myvar, 'This string will be loaded into $myvar',"man page example 1";
  83 is $TestManPage::VERSION, $Pod::Constants::VERSION, "man page example 2";
  84 ok $TestManPage::VERSION, "man page example 2 cross-check";
  85 is $TestManPage::myarray[2], 'For example, this is $myarray[2].', "man page example 3";
  86
  87 my $ok = 0;
  88 while (my ($k, $v) = each %TestManPage::myhash) {
  89     if (exists $TestManPage::myhash2{$k}) { $ok ++ };
  90     if ($v eq $TestManPage::myhash2{$k}) { $ok ++ };
  91 }
  92
  93 is $ok, 4, "man page example 4";
  94 is scalar keys %TestManPage::myhash, 2, "man page example 4 cross-check";
  95 is $TestManPage::html, '<p>This text will be in $html</p>', "man page example 5";
  96
  97 # supress warnings
  98 $TestManPage::myvar = $TestManPage::html = undef;
  99 @TestManPage::myarray = ();
 100
 101 is $options{foo}->{options}->[0], "-f", "Pod::Constants::add_hook";
 102 ok !exists $options{gtk}, 'Pod::Constants::remove_hook';
 103
 104 =head2 section_1
 105
 106 Down with Pants!
 107
 108 =head2 section_2
 109
 110 42
 111
 112 =head2 section_3
 113
 114 clank_est
 115
 116 =head2 section_4
 117
 118 $section_4 = "touche"
 119
 120 =cut
 121
 122 =head1 command line parameters
 123
 124 the following command line parameters are supported
 125
 126 =item -f, --foo
 127
 128 This does something cool.
 129
 130 =item -h, --help
 131
 132 This also does something pretty cool.
 133
 134 =head1 GUI parameters
 135
 136 the following GUI parameters are supported
 137
 138 =item -g, --gtk
 139
 140 Use a GTK+ look-and-feel
 141
 142 =item -q, --qt
 143
 144 Use a Qt look-and-feel
 145
 146 =cut