1package Test2::Harness::Util::IPC;
2use strict;
3use warnings;
4
5our $VERSION = '1.000082';
6
7use Cwd qw/getcwd/;
8use Config qw/%Config/;
9use Test2::Util qw/CAN_REALLY_FORK/;
10
11use Importer Importer => 'import';
12
13our @EXPORT_OK = qw{
14    USE_P_GROUPS
15    run_cmd
16    swap_io
17};
18
19BEGIN {
20    if ($Config{'d_setpgrp'}) {
21        *USE_P_GROUPS = sub() { 1 };
22    }
23    else {
24        *USE_P_GROUPS = sub() { 0 };
25    }
26}
27
28if (CAN_REALLY_FORK) {
29    *run_cmd = \&_run_cmd_fork;
30}
31else {
32    *run_cmd = \&_run_cmd_spwn;
33}
34
35sub swap_io {
36    my ($fh, $to, $die, $mode) = @_;
37
38    $die ||= sub {
39        my @caller = caller;
40        my @caller2 = caller(1);
41        die("$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2], ${ \__FILE__ } line ${ \__LINE__ }).\n");
42    };
43
44    my $orig_fd;
45    if (ref($fh) eq 'ARRAY') {
46        ($orig_fd, $fh) = @$fh;
47    }
48    else {
49        $orig_fd = fileno($fh);
50    }
51
52    $die->("Could not get original fd ($fh)") unless defined $orig_fd;
53
54    if (ref($to)) {
55        $mode //= $orig_fd ? '>&' : '<&';
56        open($fh, $mode, $to) or $die->("Could not redirect output: $!");
57    }
58    else {
59        $mode //= $orig_fd ? '>' : '<';
60        open($fh, $mode, $to) or $die->("Could not redirect output to '$to': $!");
61    }
62
63    return if fileno($fh) == $orig_fd;
64
65    $die->("New handle does not have the desired fd!");
66}
67
68sub _run_cmd_fork {
69    my %params = @_;
70
71    my $cmd = $params{command} or die "No 'command' specified";
72
73    my $pid = fork;
74    die "Failed to fork" unless defined $pid;
75    if ($pid) {
76        $_->() for @{$params{run_in_parent} // []};
77        return $pid;
78    }
79    else {
80        $_->() for @{$params{run_in_child} // []};
81    }
82    %ENV = (%ENV, %{$params{env}}) if $params{env};
83    setpgrp(0, 0) if USE_P_GROUPS && !$params{no_set_pgrp};
84
85    $cmd = [$cmd->()] if ref($cmd) eq 'CODE';
86
87    if (my $dir = $params{chdir} // $params{ch_dir}) {
88        chdir($dir) or die "Could not chdir: $!";
89    }
90
91    my $stdout = $params{stdout};
92    my $stderr = $params{stderr};
93    my $stdin  = $params{stdin};
94
95    open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!";
96
97    my $die = sub {
98        my $caller1 = $params{caller1};
99        my $caller2 = $params{caller2};
100        my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2]).\n";
101        print $OLD_STDERR $msg;
102        print STDERR $msg;
103        POSIX::_exit(127);
104    };
105
106    swap_io(\*STDERR, $stderr, $die) if $stderr;
107    swap_io(\*STDOUT, $stdout, $die) if $stdout;
108    swap_io(\*STDIN,  $stdin,  $die) if $stdin;
109    open(STDIN, "<", "/dev/null") if !$stdin;
110
111    @$cmd = map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd;
112
113    exec(@$cmd) or $die->("Failed to exec!");
114}
115
116sub _run_cmd_spwn {
117    my %params = @_;
118
119    local %ENV = (%ENV, %{$params{env}}) if $params{env};
120
121    my $cmd = $params{command} or die "No 'command' specified";
122    $cmd = [$cmd->()] if ref($cmd) eq 'CODE';
123
124    my $cwd;
125    if (my $dir = $params{chdir} // $params{ch_dir}) {
126        $cwd = getcwd();
127        chdir($dir) or die "Could not chdir: $!";
128    }
129
130    my $stdout = $params{stdout};
131    my $stderr = $params{stderr};
132    my $stdin  = $params{stdin};
133
134    open(my $OLD_STDIN,  '<&', \*STDIN)  or die "Could not clone STDIN: $!";
135    open(my $OLD_STDOUT, '>&', \*STDOUT) or die "Could not clone STDOUT: $!";
136    open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!";
137
138    my $die = sub {
139        my $caller1 = $params{caller1};
140        my $caller2 = $params{caller2};
141        my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2], ${ \__FILE__ } line ${ \__LINE__ }).\n";
142        print $OLD_STDERR $msg;
143        print STDERR $msg;
144        POSIX::_exit(127);
145    };
146
147    swap_io(\*STDIN,  $stdin,  $die) if $stdin;
148    swap_io(\*STDOUT, $stdout, $die) if $stdout;
149    $stdin ? swap_io(\*STDIN,  $stdin,  $die) : close(STDIN);
150
151    local $?;
152    my $pid;
153    my $ok = eval { $pid = system 1, map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd };
154    my $bad = $?;
155    my $err = $@;
156
157    swap_io($stdin ? \*STDIN : [0, \*STDIN], $OLD_STDIN, $die);
158    swap_io(\*STDERR, $OLD_STDERR, $die) if $stderr;
159    swap_io(\*STDOUT, $OLD_STDOUT, $die) if $stdout;
160
161    if ($cwd) {
162        chdir($cwd) or die "Could not chdir: $!";
163    }
164
165    die $err unless $ok;
166    die "Spawn resulted in code $bad" if $bad && $bad != $pid;
167    die "Failed to spawn" unless $pid;
168
169    $_->() for @{$params{run_in_parent} // []};
170
171    return $pid;
172}
173
1741;
175
176__END__
177
178=pod
179
180=encoding UTF-8
181
182=head1 NAME
183
184Test2::Harness::Util::IPC - Utilities for IPC management.
185
186=head1 DESCRIPTION
187
188This package provides low-level IPC tools for Test2::Harness.
189
190=head1 EXPORTS
191
192All exports are optional and must be specified at import time.
193
194=over 4
195
196=item $bool = USE_P_GROUPS()
197
198This is a shortcut for:
199
200    use Config qw/%Config/;
201    $Config{'d_setpgrp'};
202
203=item swap_io($from, $to)
204
205=item swap_io($from, $to, \&die)
206
207This will close and re-open the file handle designated by C<$from> so that it
208redirects to the handle specified in C<$to>. It preserves the file descriptor
209in the process, and throws an exception if it fails to do so.
210
211    swap_io(\*STDOUT, $fh);
212    # STDOUT now points to wherever $fh did, but maintains the file descriptor number '2'.
213
214As long as the file descriptor is greater than 0 it will open for writing. If
215the descriptor is 0 it will open for reading, allowing for a swap of C<STDIN>
216as well.
217
218Extra effort is made to insure errors go to the real C<STDERR>, specially when
219trying to swap out C<STDERR>. If you have trouble with this, or do not trust
220it, you can provide a custom coderef as a third argument, this coderef will be
221used instead of C<die()> to throw exceptions.
222
223Note that the custom die logic when you do not provide your own bypasses the
224exception catching mechanism and will exit your program. If this is not
225desirable then you should provide a custom die subref.
226
227=item $pid = run_cmd(command => [...], %params)
228
229This function will run the specified command and return a pid to you. When
230possible this will be done via C<fork()> and C<exec()>. When that is not
231possible it uses the C<system(1, ...)> trick to spawn a new process. Some
232parameters do not work in the second case, and are silently ignored.
233
234Parameters:
235
236=over 4
237
238=item command => [$command, sub { ... }, @args]
239
240=item command => sub { return ($command, @args) }
241
242This parameter is required. This should either be an arrayref of arguments for
243C<exec()>, or a coderef that returns a list of arguments for C<exec()>. On
244systems without fork/exec the arguments will be passed to
245C<system(1, $command, @args)> instead.
246
247If the command arrayref has a coderef in it, the coderef will be run and its
248return value(s) will be inserted in its place. This replacement happens
249post-chroot
250
251=item run_in_parent => [sub { ... }, sub { ... }]
252
253An arrayref of callbacks to be run in the parent process immedietly after the
254child process is started.
255
256=item run_in_child => [sub { ... }, sub { ... }]
257
258An arrayref of callbacks to be run in the child process immedietly after fork.
259This parameter is silently ignored on systems without fork/exec.
260
261=item env => { ENVVAR => $VAL, ... }
262
263A hashref of custom environment variables to set in the child process. In the
264fork/exec model this is done post-fork, in the spawn model this is done via
265local prior to the spawn.
266
267=item no_set_pgrp => $bool,
268
269Normall C<setpgrp(0,0)> is called on systems where it is supported. You can use
270this parameter to override the normal behavior. setpgrp() is not called in the
271spawn model, so this parameter is silently ignored there.
272
273=item chdir => 'path/to/dir'
274
275=item ch_dir => 'path/to/dir'
276
277chdir() to the specified directory for the new process. In the fork/exec model
278this is done post-fork in the child. In the spawn model this is done before the
279spawn, then a second chdir() puts the parent process back to its original dir
280after the spawn.
281
282=item stdout => $handle
283
284=item stderr => $handle
285
286=item stdin  => $handle
287
288Thise can be used to provide custom STDERR, STDOUT, and STDIN. In the fork/exec
289model these are swapped into place post-fork in the child. In the spawn model
290the swap occurs pre-spawn, then the old handles are swapped back post-spawn.
291
292=back
293
294=back
295
296=head1 SOURCE
297
298The source code repository for Test2-Harness can be found at
299F<http://github.com/Test-More/Test2-Harness/>.
300
301=head1 MAINTAINERS
302
303=over 4
304
305=item Chad Granum E<lt>exodist@cpan.orgE<gt>
306
307=back
308
309=head1 AUTHORS
310
311=over 4
312
313=item Chad Granum E<lt>exodist@cpan.orgE<gt>
314
315=back
316
317=head1 COPYRIGHT
318
319Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>.
320
321This program is free software; you can redistribute it and/or
322modify it under the same terms as Perl itself.
323
324See F<http://dev.perl.org/licenses/>
325
326=cut
327