Update VPIT::TestHelpers to 0bb3aa5
[perl/modules/indirect.git] / t / lib / VPIT / TestHelpers.pm
1 package VPIT::TestHelpers;
2
3 use strict;
4 use warnings;
5
6 use Config ();
7
8 =head1 NAME
9
10 VPIT::TestHelpers
11
12 =head1 SYNTAX
13
14     use VPIT::TestHelpers (
15      feature1 => \@feature1_args,
16      feature2 => \@feature2_args,
17     );
18
19 =cut
20
21 sub export_to_pkg {
22  my ($subs, $pkg) = @_;
23
24  while (my ($name, $code) = each %$subs) {
25   no strict 'refs';
26   *{$pkg.'::'.$name} = $code;
27  }
28
29  return 1;
30 }
31
32 sub sanitize_prefix {
33  my $prefix = shift;
34
35  if (defined $prefix) {
36   if (length $prefix and $prefix !~ /_$/) {
37    $prefix .= '_';
38   }
39  } else {
40   $prefix = '';
41  }
42
43  return $prefix;
44 }
45
46 my %default_exports = (
47  load_or_skip     => \&load_or_skip,
48  load_or_skip_all => \&load_or_skip_all,
49  skip_all         => \&skip_all,
50 );
51
52 my %features = (
53  threads  => \&init_threads,
54  usleep   => \&init_usleep,
55  run_perl => \&init_run_perl,
56  capture  => \&init_capture,
57 );
58
59 sub import {
60  shift;
61  my @opts = @_;
62
63  my %exports = %default_exports;
64
65  for (my $i = 0; $i <= $#opts; ++$i) {
66   my $feature = $opts[$i];
67   next unless defined $feature;
68
69   my $args;
70   if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') {
71    ++$i;
72    $args = $opts[$i];
73   } else {
74    $args = [ ];
75   }
76
77   my $handler = $features{$feature};
78   die "Unknown feature '$feature'" unless defined $handler;
79
80   my %syms = $handler->(@$args);
81
82   $exports{$_} = $syms{$_} for sort keys %syms;
83  }
84
85  export_to_pkg \%exports => scalar caller;
86 }
87
88 my $test_sub = sub {
89  my $sub = shift;
90
91  my $stash;
92  if ($INC{'Test/Leaner.pm'}) {
93   $stash = \%Test::Leaner::;
94  } else {
95   require Test::More;
96   $stash = \%Test::More::;
97  }
98
99  my $glob = $stash->{$sub};
100  return ref \$glob eq 'GLOB' ? *$glob{CODE}
101       : ref  $glob eq 'CODE' ?  $glob
102       :                          undef;
103 };
104
105 sub skip { $test_sub->('skip')->(@_) }
106
107 sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) }
108
109 sub diag {
110  my $diag = $test_sub->('diag');
111  $diag->($_) for @_;
112 }
113
114 our $TODO;
115 local $TODO;
116
117 sub load {
118  my ($pkg, $ver, $imports) = @_;
119
120  my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg;
121  my $err;
122
123  local $@;
124  if (eval "use $spec (); 1") {
125   $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} };
126   $ver = 'undef' unless defined $ver;
127
128   if ($imports) {
129    my @imports = @$imports;
130    my $caller  = (caller 1)[0];
131    local $@;
132    my $res = eval <<"IMPORTER";
133 package
134         $caller;
135 BEGIN { \$pkg->import(\@imports) }
136 1;
137 IMPORTER
138    $err = "Could not import '@imports' from $pkg $ver: $@" unless $res;
139   }
140  } else {
141   (my $file = "$pkg.pm") =~ s{::}{/}g;
142   delete $INC{$file};
143   $err = "Could not load $spec";
144  }
145
146  if ($err) {
147   return wantarray ? (0, $err) : 0;
148  } else {
149   diag "Using $pkg $ver";
150   return 1;
151  }
152 }
153
154 sub load_or_skip {
155  my ($pkg, $ver, $imports, $tests) = @_;
156
157  die 'You must specify how many tests to skip' unless defined $tests;
158
159  my ($loaded, $err) = load($pkg, $ver, $imports);
160  skip $err => $tests unless $loaded;
161
162  return $loaded;
163 }
164
165 sub load_or_skip_all {
166  my ($pkg, $ver, $imports) = @_;
167
168  my ($loaded, $err) = load($pkg, $ver, $imports);
169  skip_all $err unless $loaded;
170
171  return $loaded;
172 }
173
174 =head1 FEATURES
175
176 =head2 C<run_perl>
177
178 =over 4
179
180 =item *
181
182 Import :
183
184     use VPIT::TestHelpers run_perl => [ $p ]
185
186 where :
187
188 =over 8
189
190 =item -
191
192 C<$p> is prefixed to the constants exported by this feature (defaults to C<''>).
193
194 =back
195
196 =item *
197
198 Dependencies :
199
200 =over 8
201
202 =item -
203
204 L<File::Spec>
205
206 =back
207
208 =item *
209
210 Exports :
211
212 =over 8
213
214 =item -
215
216 C<run_perl $code>
217
218 =item -
219
220 C<run_perl_file $file>
221
222 =item -
223
224 C<RUN_PERL_FAILED> (possibly prefixed by C<$p>)
225
226 =back
227
228 =back
229
230 =cut
231
232 sub fresh_perl_env (&) {
233  my $handler = shift;
234
235  my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>};
236  my $ld_name  = $Config::Config{ldlibpthname};
237  my $ldlibpth = $ENV{$ld_name};
238
239  local %ENV;
240  $ENV{$ld_name}   = $ldlibpth   if                      defined $ldlibpth;
241  $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
242  $ENV{PATH}       = $PATH       if $^O eq 'cygwin'  and defined $PATH;
243
244  my $perl = $^X;
245  unless (-e $perl and -x $perl) {
246   $perl = $Config::Config{perlpath};
247   unless (-e $perl and -x $perl) {
248    return undef;
249   }
250  }
251
252  return $handler->($perl, '-T', map("-I$_", @INC));
253 }
254
255 sub init_run_perl {
256  my $p = sanitize_prefix(shift);
257
258  # This is only required for run_perl_file(), so it is not needed for the
259  # threads feature which only calls run_perl() - don't forget to update its
260  # requirements if this ever changes.
261  require File::Spec;
262
263  return (
264   run_perl              => \&run_perl,
265   run_perl_file         => \&run_perl_file,
266   "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' },
267  );
268 }
269
270 sub run_perl {
271  my $code = shift;
272
273  if ($code =~ /"/) {
274   die 'Double quotes in evaluated code are not portable';
275  }
276
277  fresh_perl_env {
278   my ($perl, @perl_args) = @_;
279   system { $perl } $perl, @perl_args, '-e', $code;
280  };
281 }
282
283 sub run_perl_file {
284  my $file = shift;
285
286  $file = File::Spec->rel2abs($file);
287  unless (-e $file and -r _) {
288   die 'Could not run perl file';
289  }
290
291  fresh_perl_env {
292   my ($perl, @perl_args) = @_;
293   system { $perl } $perl, @perl_args, $file;
294  };
295 }
296
297 =head2 C<capture>
298
299 =over 4
300
301 =item *
302
303 Import :
304
305     use VPIT::TestHelpers capture => [ $p ];
306
307 where :
308
309 =over 8
310
311 =item -
312
313 C<$p> is prefixed to the constants exported by this feature (defaults to C<''>).
314
315 =back
316
317 =item *
318
319 Dependencies :
320
321 =over 8
322
323 =item -
324
325 Neither VMS nor OS/2
326
327 =item -
328
329 L<IO::Handle>
330
331 =item -
332
333 L<IO::Select>
334
335 =item -
336
337 L<IPC::Open3>
338
339 =item -
340
341 On MSWin32 : L<Socket>
342
343 =back
344
345 =item *
346
347 Exports :
348
349 =over 8
350
351 =item -
352
353 C<capture @command>
354
355 =item -
356
357 C<CAPTURE_FAILED $details> (possibly prefixed by C<$p>)
358
359 =item -
360
361 C<capture_perl $code>
362
363 =item -
364
365 C<CAPTURE_PERL_FAILED $details> (possibly prefixed by C<$p>)
366
367 =back
368
369 =back
370
371 =cut
372
373 sub init_capture {
374  my $p = sanitize_prefix(shift);
375
376  skip_all 'Cannot capture output on VMS'  if $^O eq 'VMS';
377  skip_all 'Cannot capture output on OS/2' if $^O eq 'os2';
378
379  load_or_skip_all 'IO::Handle', '0', [ ];
380  load_or_skip_all 'IO::Select', '0', [ ];
381  load_or_skip_all 'IPC::Open3', '0', [ ];
382  if ($^O eq 'MSWin32') {
383   load_or_skip_all 'Socket', '0', [ ];
384  }
385
386  return (
387   capture                   => \&capture,
388   "${p}CAPTURE_FAILED"      => \&capture_failed_msg,
389   capture_perl              => \&capture_perl,
390   "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg,
391  );
392 }
393
394 # Inspired from IPC::Cmd
395
396 sub capture {
397  my @cmd = @_;
398
399  my $want = wantarray;
400
401  my $fail = sub {
402   my $err     = $!;
403   my $ext_err = $^O eq 'MSWin32' ? $^E : undef;
404
405   my $syscall = shift;
406   my $args    = join ', ', @_;
407
408   my $msg = "$syscall($args) failed: ";
409
410   if (defined $err) {
411    no warnings 'numeric';
412    my ($err_code, $err_str) = (int $err, "$err");
413    $msg .= "$err_str ($err_code)";
414   }
415
416   if (defined $ext_err) {
417    no warnings 'numeric';
418    my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err");
419    $msg .= ", $ext_err_str ($ext_err_code)";
420   }
421
422   die "$msg\n";
423  };
424
425  my ($status, $content_out, $content_err);
426
427  local $@;
428  my $ok = eval {
429   my ($pid, $out, $err);
430
431   if ($^O eq 'MSWin32') {
432    my $pipe = sub {
433     socketpair $_[0], $_[1],
434                &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC
435                       or $fail->(qw<socketpair reader writer>);
436     shutdown $_[0], 1 or $fail->(qw<shutdown reader>);
437     shutdown $_[1], 0 or $fail->(qw<shutdown writer>);
438     return 1;
439    };
440    local (*IN_R,  *IN_W);
441    local (*OUT_R, *OUT_W);
442    local (*ERR_R, *ERR_W);
443    $pipe->(*IN_R,  *IN_W);
444    $pipe->(*OUT_R, *OUT_W);
445    $pipe->(*ERR_R, *ERR_W);
446
447    $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd);
448
449    close *IN_W or $fail->(qw<close input>);
450    $out = *OUT_R;
451    $err = *ERR_R;
452   } else {
453    my $in = IO::Handle->new;
454    $out   = IO::Handle->new;
455    $out->autoflush(1);
456    $err   = IO::Handle->new;
457    $err->autoflush(1);
458
459    $pid = IPC::Open3::open3($in, $out, $err, @cmd);
460
461    close $in;
462   }
463
464   # Forward signals to the child (except SIGKILL)
465   my %sig_handlers;
466   foreach my $s (keys %SIG) {
467    $sig_handlers{$s} = sub {
468     kill "$s" => $pid;
469     $SIG{$s} = $sig_handlers{$s};
470    };
471   }
472   local $SIG{$_} = $sig_handlers{$_} for keys %SIG;
473
474   unless ($want) {
475    close $out or $fail->(qw<close output>);
476    close $err or $fail->(qw<close error>);
477    waitpid $pid, 0;
478    $status = $?;
479    return 1;
480   }
481
482   my $sel = IO::Select->new();
483   $sel->add($out, $err);
484
485   my $fd_out = fileno $out;
486   my $fd_err = fileno $err;
487
488   my %contents;
489   $contents{$fd_out} = '';
490   $contents{$fd_err} = '';
491
492   while (my @ready = $sel->can_read) {
493    for my $fh (@ready) {
494     my $buf;
495     my $bytes_read = sysread $fh, $buf, 4096;
496     if (not defined $bytes_read) {
497      $fail->('sysread', 'fd(' . fileno($fh) . ')');
498     } elsif ($bytes_read) {
499      $contents{fileno($fh)} .= $buf;
500     } else {
501      $sel->remove($fh);
502      close $fh or $fail->('close', 'fd(' . fileno($fh) . ')');
503      last unless $sel->count;
504     }
505    }
506   }
507
508   waitpid $pid, 0;
509   $status = $?;
510
511   if ($^O eq 'MSWin32') {
512    # Manual CRLF translation that couldn't be done with sysread.
513    s/\x0D\x0A/\n/g for values %contents;
514   }
515
516   $content_out = $contents{$fd_out};
517   $content_err = $contents{$fd_err};
518
519   1;
520  };
521
522  if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err
523                   and $content_err =~ /^open3/) {
524   # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3
525   # could be reported to STDERR instead of being propagated, so work around
526   # this.
527   $ok = 0;
528   $@  = $content_err;
529  }
530
531  if ($ok) {
532   return ($status, $content_out, $content_err);
533  } else {
534   my $err = $@;
535   chomp $err;
536   return (undef, $err);
537  }
538 }
539
540 sub capture_failed_msg {
541  my $details = shift;
542
543  my $msg = 'Could not capture command output';
544  $msg   .= " ($details)" if defined $details;
545
546  return $msg;
547 }
548
549 sub capture_perl {
550  my $code = shift;
551
552  if ($code =~ /"/) {
553   die 'Double quotes in evaluated code are not portable';
554  }
555
556  fresh_perl_env {
557   my @perl = @_;
558   capture @perl, '-e', $code;
559  };
560 }
561
562 sub capture_perl_failed_msg {
563  my $details = shift;
564
565  my $msg = 'Could not capture perl output';
566  $msg   .= " ($details)" if defined $details;
567
568  return $msg;
569 }
570
571 =head2 C<threads>
572
573 =over 4
574
575 =item *
576
577 Import :
578
579     use VPIT::TestHelpers threads => [
580      $pkg, $threadsafe_var, $force_var
581     ];
582
583 where :
584
585 =over 8
586
587 =item -
588
589 C<$pkg> is the target package name that will be exercised by this test ;
590
591 =item -
592
593 C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C<undef>) ;
594
595 =item -
596
597 C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C<PERL_FORCE_TEST_THREADS>).
598
599 =back
600
601 =item *
602
603 Dependencies :
604
605 =over 8
606
607 =item -
608
609 C<perl> 5.13.4
610
611 =item -
612
613 L<POSIX>
614
615 =item -
616
617 L<threads> 1.67
618
619 =item -
620
621 L<threads::shared> 1.14
622
623 =back
624
625 =item *
626
627 Exports :
628
629 =over 8
630
631 =item -
632
633 C<spawn $coderef>
634
635 =back
636
637 =item *
638
639 Notes :
640
641 =over 8
642
643 =item -
644
645 C<< exit => 'threads_only' >> is passed to C<< threads->import >>.
646
647 =back
648
649 =back
650
651 =cut
652
653 sub init_threads {
654  my ($pkg, $threadsafe_var, $force_var) = @_;
655
656  skip_all 'This perl wasn\'t built to support threads'
657                                             unless $Config::Config{useithreads};
658
659  if (defined $pkg and defined $threadsafe_var) {
660   my $threadsafe;
661   # run_perl() doesn't actually require anything
662   my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())");
663   if (defined $stat) {
664    require POSIX;
665    my $res  = $stat >> 8;
666    if ($res == POSIX::EXIT_SUCCESS()) {
667     $threadsafe = 1;
668    } elsif ($res == POSIX::EXIT_FAILURE()) {
669     $threadsafe = !1;
670    }
671   }
672   if (not defined $threadsafe) {
673    skip_all "Could not detect if $pkg is thread safe or not";
674   } elsif (not $threadsafe) {
675    skip_all "This $pkg is not thread safe";
676   }
677  }
678
679  $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var;
680  my $force  = $ENV{$force_var} ? 1 : !1;
681  skip_all 'perl 5.13.4 required to test thread safety'
682                                              unless $force or "$]" >= 5.013_004;
683
684  unless ($INC{'threads.pm'}) {
685   my $test_module;
686   if ($INC{'Test/Leaner.pm'}) {
687    $test_module = 'Test::Leaner';
688   } elsif ($INC{'Test/More.pm'}) {
689    $test_module = 'Test::More';
690   }
691   die "$test_module was loaded too soon" if defined $test_module;
692  }
693
694  load_or_skip_all 'threads',         $force ? '0' : '1.67', [
695   exit => 'threads_only',
696  ];
697  load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ];
698
699  diag "Threads testing forced by \$ENV{$force_var}" if $force;
700
701  return spawn => \&spawn;
702 }
703
704 sub spawn {
705  local $@;
706  my @diag;
707  my $thread = eval {
708   local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
709   threads->create(@_);
710  };
711  push @diag, "Thread creation error: $@" if $@;
712  diag @diag;
713  return $thread ? $thread : ();
714 }
715
716 =head2 C<usleep>
717
718 =over 4
719
720 =item *
721
722 Import :
723
724     use VPIT::TestHelpers 'usleep' => [ @impls ];
725
726 where :
727
728 =over 8
729
730 =item -
731
732 C<@impls> is the list of desired implementations (which may be C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be checked.
733 When the list is empty, it defaults to all of them.
734
735 =back
736
737 =item *
738
739 Dependencies : none
740
741 =item *
742
743 Exports :
744
745 =over 8
746
747 =item -
748
749 C<usleep $microseconds>
750
751 =back
752
753 =back
754
755 =cut
756
757 sub init_usleep {
758  my (@impls) = @_;
759
760  my %impls = (
761   'Time::HiRes' => sub {
762    if (do { local $@; eval { require Time::HiRes; 1 } }) {
763     defined and diag "Using usleep() from Time::HiRes $_"
764                                                       for $Time::HiRes::VERSION;
765     return \&Time::HiRes::usleep;
766    } else {
767     return undef;
768    }
769   },
770   'select' => sub {
771    if ($Config::Config{d_select}) {
772     diag 'Using select()-based fallback usleep()';
773     return sub ($) {
774      my $s = $_[0];
775      my $r = 0;
776      while ($s > 0) {
777       my ($found, $t) = select(undef, undef, undef, $s / 1e6);
778       last unless defined $t;
779       $t  = int($t * 1e6);
780       $s -= $t;
781       $r += $t;
782      }
783      return $r;
784     };
785    } else {
786     return undef;
787    }
788   },
789   'sleep' => sub {
790    diag 'Using sleep()-based fallback usleep()';
791    return sub ($) {
792     my $ms = int $_[0];
793     my $s  = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1);
794     my $t  = sleep $s;
795     return $t * 1e6;
796    };
797   },
798  );
799
800  @impls = qw<Time::HiRes select sleep> unless @impls;
801
802  my $usleep;
803  for my $impl (@impls) {
804   next unless defined $impl and $impls{$impl};
805   $usleep = $impls{$impl}->();
806   last if defined $usleep;
807  }
808
809  skip_all "Could not find a suitable usleep() implementation among: @impls"
810                                                                  unless $usleep;
811
812  return usleep => $usleep;
813 }
814
815 =head1 CLASSES
816
817 =head2 C<VPIT::TestHelpers::Guard>
818
819 Syntax :
820
821     {
822      my $guard = VPIT::TestHelpers::Guard->new($coderef);
823      ...
824     } # $codref called here
825
826 =cut
827
828 package VPIT::TestHelpers::Guard;
829
830 sub new {
831  my ($class, $code) = @_;
832
833  bless { code => $code }, $class;
834 }
835
836 sub DESTROY { $_[0]->{code}->() }
837
838 =head1 AUTHOR
839
840 Vincent Pit C<< <vpit at cpan.org> >>.
841
842 =head1 COPYRIGHT & LICENSE
843
844 Copyright 2012,2013,2014,2015,2019 Vincent Pit, all rights reserved.
845
846 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
847
848 =cut
849
850 1;