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