Merge pull request #11 from atoomic/test-fixup

Avoid wait forever from t/pod/pod2usage2.t
Dual-Life · Oct 6, 2020 · b00daa2 · b00daa2
2 parents a11ba16 + 9bc8cea
commit b00daa2
Show file tree

Hide file tree

Showing 6 changed files with 95 additions and 31 deletions.
diff --git a/.github/workflows/testsuite.yml b/.github/workflows/testsuite.yml
@@ -18,6 +18,41 @@ jobs:
 
     runs-on: ubuntu-latest
 
+    steps:
+      - uses: actions/checkout@v2
+      - name: install perl-doc
+        run: |
+          sudo apt-get clean
+          sudo apt-get install -y perl-doc perl-doc-html
+      - name: perl -V
+        run: perl -V
+      - name: Install dependencies
+        uses: perl-actions/install-with-cpm@v1
+        with:
+          cpanfile: "cpanfile"
+      - run: perl Makefile.PL
+      - run: make
+      - run: make test
+      - name: remove pod2usage
+        run: |
+          POD=$(which pod2usage)
+          echo "pod2usage: $POD"
+          sudo rm -f $POD ||:
+      - run: sudo make install
+      - run: which pod2usage
+
+  # ------------------------------------------------------------------------
+
+  no-perl-doc:
+    needs: [ubuntu]
+    env:
+      PERL_USE_UNSAFE_INC: 0
+      AUTHOR_TESTING: 1
+      AUTOMATED_TESTING: 1
+      RELEASE_TESTING: 1
+
+    runs-on: ubuntu-latest
+
     steps:
       - uses: actions/checkout@v2
       - name: perl -V
@@ -111,7 +146,7 @@ jobs:
       - name: Set up Perl
         run: |
           choco install strawberryperl
-          echo "##[add-path]C:\strawberry\c\bin;C:\strawberry\perl\site\bin;C:\strawberry\perl\bin"
+          echo "C:\strawberry\c\bin;C:\strawberry\perl\site\bin;C:\strawberry\perl\bin" >> $GITHUB_PATH
       - name: perl -V
         run: perl -V
       - name: Install dependencies

diff --git a/META.json b/META.json
@@ -53,6 +53,8 @@
             "Cwd" : "0",
             "File::Basename" : "0",
             "File::Spec" : "0.82",
+            "Pod::Perldoc" : "3.28",
+            "Pod::Simple" : "3.40",
             "Pod::Text" : "4.00",
             "perl" : "5.006"
          }

diff --git a/Makefile.PL b/Makefile.PL
@@ -20,6 +20,8 @@ my %WriteMakefileArgs = (
     "Cwd" => 0,
     "File::Basename" => 0,
     "File::Spec" => "0.82",
+    "Pod::Perldoc" => "3.28",
+    "Pod::Simple" => "3.40",
     "Pod::Text" => "4.00"
   },
   "TEST_REQUIRES" => {
@@ -47,6 +49,8 @@ my %FallbackPrereqs = (
   "ExtUtils::MakeMaker" => 0,
   "File::Basename" => 0,
   "File::Spec" => "0.82",
+  "Pod::Perldoc" => "3.28",
+  "Pod::Simple" => "3.40",
   "Pod::Text" => "4.00",
   "Test::More" => "0.60",
   "blib" => 0

diff --git a/cpanfile b/cpanfile
@@ -3,6 +3,8 @@ use warnings;
 
 on 'runtime' => sub {
     requires 'Pod::Text' => '4.00';    # to avoid issues with wrong test results
+    requires 'Pod::Simple' => '3.40';  # to avoid issues with wrong test results
+    requires 'Pod::Perldoc' => '3.28';  # to avoid issues with wrong test results
     requires 'Cwd';
     requires 'File::Basename';
     requires 'File::Spec' => '0.82';

diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd
@@ -28,6 +28,8 @@ do { my $x = {
                                       'Cwd' => '0',
                                       'File::Basename' => '0',
                                       'File::Spec' => '0.82',
+                                      'Pod::Perldoc' => '3.28',
+                                      'Pod::Simple' => '3.40',
                                       'Pod::Text' => '4.00',
                                       'perl' => '5.006'
                                     }

diff --git a/t/pod/pod2usage2.t b/t/pod/pod2usage2.t
@@ -19,24 +19,32 @@ BEGIN {
 sub getoutput
 {
   my ($code) = @_;
-  my $pid = open(TEST_IN, "-|");
-  unless(defined $pid) {
-    die "Cannot fork: $!";
-  }
-  if($pid) {
+  my $pid = open(my $in, "-|");
+  die "Cannot fork: $!" unless defined $pid;
+  if ($pid) {
     # parent
-    my @out = <TEST_IN>;
-    close(TEST_IN);
+    my @out = <$in>;
+    close($in);
+
     my $exit = $?>>8;
     s/^/#/ for @out;
+
     local $" = "";
+
     print "#EXIT=$exit OUTPUT=+++#@out#+++\n";
-    return($exit, join("",@out));
+    waitpid( $pid, 1 );
+
+    return ($exit, join("", @out) );
   }
   # child
-  open(STDERR, ">&STDOUT");
+  open (STDERR, ">&STDOUT");
+
   Test::More->builder->no_ending(1);
-  &$code;
+  local $SIG{ALRM} = sub { die "Alarm reached" };
+  alarm(600);
+
+  # this could hang
+  $code->();
   print "--NORMAL-RETURN--\n";
   exit 0;
 }
@@ -72,17 +80,17 @@ ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbos
 #You naughty person, what did you say?
 # Usage:
 #     frobnicate [ -r | --recursive ] [ -f | --force ] file ...
-# 
+#
 # Options:
 #     -r | --recursive
 #         Run recursively.
-# 
+#
 #     -f | --force
 #         Just do it!
-# 
+#
 #     -n number
 #         Specify number of frobs, default is 42.
-# 
+#
 EOT
 
 ($exit, $text) = getoutput( sub { pod2usage(
@@ -217,7 +225,7 @@ is ($exit, 0,                 "Exit status pod2usage with USAGE and verbose=99")
 ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=99") or diag "Got:\n$text\n";
 #Usage:
 #    This is a test for CPAN#33020
-# 
+#
 EOT
 
 # test with self
@@ -241,13 +249,13 @@ ok (compare ($text, <<'EOT'), "Output test pod2usage with self") or diag "Got:\n
 #      pod2usage($exit_status);
 #
 #      pod2usage( { -message => $message_text ,
-#                   -exitval => $exit_status  ,  
-#                   -verbose => $verbose_level,  
+#                   -exitval => $exit_status  ,
+#                   -verbose => $verbose_level,
 #                   -output  => $filehandle } );
 #
 #      pod2usage(   -msg     => $message_text ,
-#                   -exitval => $exit_status  ,  
-#                   -verbose => $verbose_level,  
+#                   -exitval => $exit_status  ,
+#                   -verbose => $verbose_level,
 #                   -output  => $filehandle   );
 #
 #      pod2usage(   -verbose => 2,
@@ -352,19 +360,30 @@ like ($text, qr/frobnicate - do what I mean/, "Output test pod2usage with relati
 { no warnings;
   *Pod::Usage::initialize = sub { 1; };
 }
-($exit, $text) = getoutput( sub {
-  my $devnull = File::Spec->devnull();
-  open(SAVE_STDOUT, '>&', \*STDOUT);
-  open(STDOUT, '>', $devnull);
-  pod2usage({ -verbose => 2, -input => $0, -output => \*STDOUT, -exit => 0, -message => 'Special perldoc case', -perldocopt => '-i' });
-  open(STDOUT, '>&', \*SAVE_STDOUT);
-  } );
-is ($exit, 0,                 "Exit status pod2usage with special perldoc case");
-# output went to devnull
-like ($text, qr/^\s*$/s, "Output test pod2usage with special perldoc case") or diag "Got:\n$text\n";
+
+SKIP: {
+    my $perldoc = $^X . 'doc';
+    skip "Missing perldoc binary", 2 unless -x $perldoc;
+
+    my $out = qx[$perldoc 2>&1] || '';
+    skip "Need perl-doc package", 2 if $out =~ qr[You need to install the perl-doc package to use this program];
+
+    ($exit, $text) = getoutput( sub {
+        require Pod::Perldoc;
+      my $devnull = File::Spec->devnull();
+      open(SAVE_STDOUT, '>&', \*STDOUT);
+      open(STDOUT, '>', $devnull);
+      pod2usage({ -verbose => 2, -input => $0, -output => \*STDOUT, -exit => 0, -message => 'Special perldoc case', -perldocopt => '-i' });
+      open(STDOUT, '>&', \*SAVE_STDOUT);
+      } );
+    is ($exit, 0,                 "Exit status pod2usage with special perldoc case");
+    # output went to devnull
+    like ($text, qr/^\s*$/s, "Output test pod2usage with special perldoc case") or diag "Got:\n$text\n";
+
+}
 
 # bad regexp syntax
-($exit, $text) = getoutput( sub { pod2usage(-verbose => 99, -sections => 'DESCRIPTION{BLAH') } );
+($exit, $text) = getoutput( sub { pod2usage( -verbose => 99, -sections => 'DESCRIPTION{BLAH') } );
 like ($text, qr/Bad regular expression/, "Output test pod2usage with bad section regexp");
 
 } # end SKIP