]> git.vpit.fr Git - perl/modules/VPIT-TestHelpers.git/blob - lib/VPIT/TestHelpers.pm
Introduce fresh_perl_env() and make run_perl() use it
[perl/modules/VPIT-TestHelpers.git] / lib / VPIT / TestHelpers.pm
1 package VPIT::TestHelpers;
2
3 use strict;
4 use warnings;
5
6 use Config ();
7
8 sub export_to_pkg {
9  my ($subs, $pkg) = @_;
10
11  while (my ($name, $code) = each %$subs) {
12   no strict 'refs';
13   *{$pkg.'::'.$name} = $code;
14  }
15
16  return 1;
17 }
18
19 my %default_exports = (
20  load_or_skip     => \&load_or_skip,
21  load_or_skip_all => \&load_or_skip_all,
22  run_perl         => \&run_perl,
23  skip_all         => \&skip_all,
24 );
25
26 my %features = (
27  threads => \&init_threads,
28  usleep  => \&init_usleep,
29  capture => \&init_capture,
30 );
31
32 sub import {
33  shift;
34  my @opts = @_;
35
36  my %exports = %default_exports;
37
38  for (my $i = 0; $i <= $#opts; ++$i) {
39   my $feature = $opts[$i];
40   next unless defined $feature;
41
42   my $args;
43   if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') {
44    ++$i;
45    $args = $opts[$i];
46   } else {
47    $args = [ ];
48   }
49
50   my $handler = $features{$feature};
51   die "Unknown feature '$feature'" unless defined $handler;
52
53   my %syms = $handler->(@$args);
54
55   $exports{$_} = $syms{$_} for sort keys %syms;
56  }
57
58  export_to_pkg \%exports => scalar caller;
59 }
60
61 my $test_sub = sub {
62  my $sub = shift;
63
64  my $stash;
65  if ($INC{'Test/Leaner.pm'}) {
66   $stash = \%Test::Leaner::;
67  } else {
68   require Test::More;
69   $stash = \%Test::More::;
70  }
71
72  my $glob = $stash->{$sub};
73  return $glob ? *$glob{CODE} : undef;
74 };
75
76 sub skip { $test_sub->('skip')->(@_) }
77
78 sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) }
79
80 sub diag {
81  my $diag = $test_sub->('diag');
82  $diag->($_) for @_;
83 }
84
85 our $TODO;
86 local $TODO;
87
88 sub load {
89  my ($pkg, $ver, $imports) = @_;
90
91  my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg;
92  my $err;
93
94  local $@;
95  if (eval "use $spec (); 1") {
96   $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} };
97   $ver = 'undef' unless defined $ver;
98
99   if ($imports) {
100    my @imports = @$imports;
101    my $caller  = (caller 1)[0];
102    local $@;
103    my $res = eval <<"IMPORTER";
104 package
105         $caller;
106 BEGIN { \$pkg->import(\@imports) }
107 1;
108 IMPORTER
109    $err = "Could not import '@imports' from $pkg $ver: $@" unless $res;
110   }
111  } else {
112   (my $file = "$pkg.pm") =~ s{::}{/}g;
113   delete $INC{$file};
114   $err = "Could not load $spec";
115  }
116
117  if ($err) {
118   return wantarray ? (0, $err) : 0;
119  } else {
120   diag "Using $pkg $ver";
121   return 1;
122  }
123 }
124
125 sub load_or_skip {
126  my ($pkg, $ver, $imports, $tests) = @_;
127
128  die 'You must specify how many tests to skip' unless defined $tests;
129
130  my ($loaded, $err) = load($pkg, $ver, $imports);
131  skip $err => $tests unless $loaded;
132
133  return $loaded;
134 }
135
136 sub load_or_skip_all {
137  my ($pkg, $ver, $imports) = @_;
138
139  my ($loaded, $err) = load($pkg, $ver, $imports);
140  skip_all $err unless $loaded;
141
142  return $loaded;
143 }
144
145 sub fresh_perl_env (&) {
146  my $handler = shift;
147
148  my ($SystemRoot, $PATH) = @ENV{qw<SystemRoot PATH>};
149  my $ld_name  = $Config::Config{ldlibpthname};
150  my $ldlibpth = $ENV{$ld_name};
151
152  local %ENV;
153  $ENV{$ld_name}   = $ldlibpth   if                      defined $ldlibpth;
154  $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot;
155  $ENV{PATH}       = $PATH       if $^O eq 'cygwin'  and defined $PATH;
156
157  my $perl = $^X;
158  unless (-e $perl and -x $perl) {
159   $perl = $Config::Config{perlpath};
160   unless (-e $perl and -x $perl) {
161    return undef;
162   }
163  }
164
165  return $handler->($perl, '-T', map("-I$_", @INC));
166 }
167
168 sub run_perl {
169  my $code = shift;
170
171  if ($code =~ /"/) {
172   die 'Double quotes in evaluated code are not portable';
173  }
174
175  fresh_perl_env {
176   my ($perl, @perl_args) = @_;
177   system { $perl } $perl, @perl_args, '-e', $code;
178  };
179 }
180
181 sub init_capture {
182  skip_all 'Cannot capture output on VMS' if $^O eq 'VMS';
183
184  load_or_skip_all 'IO::Handle', '0', [ ];
185  load_or_skip_all 'IO::Select', '0', [ ];
186  load_or_skip_all 'IPC::Open3', '0', [ ];
187  if ($^O eq 'MSWin32') {
188   load_or_skip_all 'Socket', '0', [ ];
189  }
190
191  return capture => \&capture;
192 }
193
194 # Inspired from IPC::Cmd
195
196 sub capture {
197  my @cmd = @_;
198
199  my $want = wantarray;
200
201  my $fail = sub {
202   my $err     = $!;
203   my $ext_err = $^O eq 'MSWin32' ? $^E : undef;
204
205   my $syscall = shift;
206   my $args    = join ', ', @_;
207
208   my $msg = "$syscall($args) failed: ";
209
210   if (defined $err) {
211    no warnings 'numeric';
212    my ($err_code, $err_str) = (int $err, "$err");
213    $msg .= "$err_str ($err_code)";
214   }
215
216   if (defined $ext_err) {
217    no warnings 'numeric';
218    my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err");
219    $msg .= ", $ext_err_str ($ext_err_code)";
220   }
221
222   die "$msg\n";
223  };
224
225  my ($status, $content_out, $content_err);
226
227  local $@;
228  my $ok = eval {
229   my ($pid, $out, $err);
230
231   if ($^O eq 'MSWin32') {
232    my $pipe = sub {
233     socketpair $_[0], $_[1],
234                &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC
235                       or $fail->(qw<socketpair reader writer>);
236     shutdown $_[0], 1 or $fail->(qw<shutdown reader>);
237     shutdown $_[1], 0 or $fail->(qw<shutdown writer>);
238     return 1;
239    };
240    local (*IN_R,  *IN_W);
241    local (*OUT_R, *OUT_W);
242    local (*ERR_R, *ERR_W);
243    $pipe->(*IN_R,  *IN_W);
244    $pipe->(*OUT_R, *OUT_W);
245    $pipe->(*ERR_R, *ERR_W);
246
247    $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd);
248
249    close *IN_W or $fail->(qw<close input>);
250    $out = *OUT_R;
251    $err = *ERR_R;
252   } else {
253    my $in = IO::Handle->new;
254    $out   = IO::Handle->new;
255    $out->autoflush(1);
256    $err   = IO::Handle->new;
257    $err->autoflush(1);
258
259    $pid = IPC::Open3::open3($in, $out, $err, @cmd);
260
261    close $in;
262   }
263
264   # Forward signals to the child (except SIGKILL)
265   my %sig_handlers;
266   foreach my $s (keys %SIG) {
267    $sig_handlers{$s} = sub {
268     kill "$s" => $pid;
269     $SIG{$s} = $sig_handlers{$s};
270    };
271   }
272   local $SIG{$_} = $sig_handlers{$_} for keys %SIG;
273
274   unless ($want) {
275    close $out or $fail->(qw<close output>);
276    close $err or $fail->(qw<close error>);
277    waitpid $pid, 0;
278    $status = $?;
279    return 1;
280   }
281
282   my $sel = IO::Select->new();
283   $sel->add($out, $err);
284
285   my $fd_out = fileno $out;
286   my $fd_err = fileno $err;
287
288   my %contents;
289   $contents{$fd_out} = '';
290   $contents{$fd_err} = '';
291
292   while (my @ready = $sel->can_read) {
293    for my $fh (@ready) {
294     my $buf;
295     my $bytes_read = sysread $fh, $buf, 4096;
296     if (not defined $bytes_read) {
297      $fail->('sysread', 'fd(' . fileno($fh) . ')');
298     } elsif ($bytes_read) {
299      $contents{fileno($fh)} .= $buf;
300     } else {
301      $sel->remove($fh);
302      close $fh or $fail->('close', 'fd(' . fileno($fh) . ')');
303      last unless $sel->count;
304     }
305    }
306   }
307
308   waitpid $pid, 0;
309   $status = $?;
310
311   if ($^O eq 'MSWin32') {
312    # Manual CRLF translation that couldn't be done with sysread.
313    s/\x0D\x0A/\n/g for values %contents;
314   }
315
316   $content_out = $contents{$fd_out};
317   $content_err = $contents{$fd_err};
318
319   1;
320  };
321
322  if ($ok) {
323   return ($status, $content_out, $content_err);
324  } else {
325   my $err = $@;
326   chomp $err;
327   return (undef, $err);
328  }
329 }
330
331 sub init_threads {
332  my ($pkg, $threadsafe, $force_var) = @_;
333
334  skip_all 'This perl wasn\'t built to support threads'
335                                             unless $Config::Config{useithreads};
336
337  $pkg = 'package' unless defined $pkg;
338  skip_all "This $pkg isn't thread safe" if defined $threadsafe and !$threadsafe;
339
340  $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var;
341  my $force  = $ENV{$force_var} ? 1 : !1;
342  skip_all 'perl 5.13.4 required to test thread safety'
343                                              unless $force or "$]" >= 5.013_004;
344
345  if (($INC{'Test/More.pm'} || $INC{'Test/Leaner.pm'}) && !$INC{'threads.pm'}) {
346   die 'Test::More/Test::Leaner was loaded too soon';
347  }
348
349  load_or_skip_all 'threads',         $force ? '0' : '1.67', [ ];
350  load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ];
351
352  require Test::Leaner;
353
354  diag "Threads testing forced by \$ENV{$force_var}" if $force;
355
356  return spawn => \&spawn;
357 }
358
359 sub init_usleep {
360  my $usleep;
361
362  if (do { local $@; eval { require Time::HiRes; 1 } }) {
363   defined and diag "Using usleep() from Time::HiRes $_"
364                                                       for $Time::HiRes::VERSION;
365   $usleep = \&Time::HiRes::usleep;
366  } else {
367   diag 'Using fallback usleep()';
368   $usleep = sub {
369    my $s = int($_[0] / 2.5e5);
370    sleep $s if $s;
371   };
372  }
373
374  return usleep => $usleep;
375 }
376
377 sub spawn {
378  local $@;
379  my @diag;
380  my $thread = eval {
381   local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" };
382   threads->create(@_);
383  };
384  push @diag, "Thread creation error: $@" if $@;
385  diag @diag;
386  return $thread ? $thread : ();
387 }
388
389 package VPIT::TestHelpers::Guard;
390
391 sub new {
392  my ($class, $code) = @_;
393
394  bless { code => $code }, $class;
395 }
396
397 sub DESTROY { $_[0]->{code}->() }
398
399 1;