use strict;
use warnings;
package IPC::Run::Fused::Win32;
BEGIN {
$IPC::Run::Fused::Win32::AUTHORITY = 'cpan:KENTNL';
}
{
$IPC::Run::Fused::Win32::VERSION = '0.04000000';
}
use IO::Handle;
use Module::Runtime;
# ABSTRACT: Implementation of IPC::Run::Fused for Win32
sub _fail { goto \&IPC::Run::Fused::_fail }
BEGIN {
Module::Runtime::require_module('Socket');
Socket->import();
}
sub run_fused {
my ( $read_handle, @params ) = @_;
if ( ref $params[0] and ref $params[0] eq 'CODE' ) {
goto \&_run_fused_coderef;
}
goto \&_run_fused_job;
}
sub _run_fused_job {
my ( $read_handle, @params ) = @_;
my $config = _run_fused_jobdecode(@params);
Module::Runtime::require_module('File::Which');
$config->{which} = File::Which::which( $config->{executable} );
local $IPC::Run::Fused::FAIL_CONTEXT{which} = $config->{which};
local $IPC::Run::Fused::FAIL_CONTEXT{executable} = $config->{executable};
local $IPC::Run::Fused::FAIL_CONTEXT{command} = $config->{command};
if ( not $config->{which} ) {
_fail('Failed to resolve executable to path');
}
Module::Runtime::require_module('Win32::Job');
pipe( $_[0], my $writer );
if ( my $pid = fork() ) {
return $pid;
}
my $job = Win32::Job->new();
$job->spawn(
$config->{which},
$config->{command},
{
stdout => $writer,
stderr => $writer,
}
) or _fail('Could not spawn job');
my $result = $job->run( -1, 0 );
if ( not $result ) {
my $status = $job->status();
if ( exists $status->{exitcode} and $status->{exitcode} == 293 ) {
_fail('Process used more than allotted time');
}
_fail( 'Child process terminated with exit code' . $status->{exitcode} );
}
exit;
}
sub _run_fused_jobdecode {
my (@params) = @_;
if ( ref $params[0] and ref $params[0] eq 'SCALAR' ) {
my $command = ${ $params[0] };
$command =~ s/^\s*//;
return {
command => $command,
executable => _win32_command_find_invocant($command),
};
}
return {
executable => $params[0],
command => _win32_escape_command(@params),
};
}
sub _run_fused_coderef {
my ( $read_handle, $code ) = @_;
my ( $reader, $writer );
socketpair( $reader, $writer, AF_UNIX, SOCK_STREAM, PF_UNSPEC ), and shutdown( $reader, 1 ), and shutdown( $writer, 0 ),
or _fail("creating socketpair");
if ( my $pid = fork() ) {
$_[0] = $reader;
return $pid;
}
close *STDERR;
close *STDOUT;
open *STDOUT, '>>&=', $writer or _fail('Assigning to STDOUT');
open *STDERR, '>>&=', $writer or _fail('Assigning to STDERR');
$code->();
exit;
}
our $BACKSLASH = chr(92);
our $DBLBACKSLASH = $BACKSLASH x 2;
our $DOS_SPECIAL_CHARS = {
chr(92) => [ 'backslash ', $BACKSLASH x 2 ],
chr(34) => [ 'double-quotes', $BACKSLASH . chr(34) ],
#chr(60) => ['open angle bracket', $backslash . chr(60)],
#chr(62) => ['close angle bracket', $backslash . chr(62)],
};
our $DOS_REV_CHARS = {
map { ( $DOS_SPECIAL_CHARS->{$_}->[1], [ $DOS_SPECIAL_CHARS->{$_}->[0], $_ ] ) }
keys %{$DOS_SPECIAL_CHARS}
};
sub _win32_escape_command_char {
return $_[0] unless exists $DOS_SPECIAL_CHARS->{ $_[0] };
return $DOS_SPECIAL_CHARS->{ $_[0] }->[1];
}
sub _win32_escape_command_token {
my $chars = join q{}, map { _win32_escape_command_char($_) } split //, shift;
return qq{"$chars"};
}
sub _win32_escape_command {
return join q{ }, map { _win32_escape_command_token($_) } @_;
}
sub _win32_command_find_invocant {
my ($command) = "$_[0]";
my $first = "";
my @chars = split //, $command;
my $inquote;
while (@chars) {
my $char = $chars[0];
my $dchar = $chars[0] . $chars[1];
if ( not $inquote and $char eq q{"} ) {
$inquote = 1;
shift @chars;
next;
}
if ( $inquote and $char eq q{"} ) {
$inquote = undef;
shift @chars;
next;
}
if ( exists $DOS_REV_CHARS->{$dchar} ) {
$first .= $DOS_REV_CHARS->{$dchar}->[1];
shift @chars;
shift @chars;
next;
}
if ( $char eq q{ } and not $inquote ) {
if ( not length $first ) {
shift @chars;
next;
}
return $first;
}
if ( $char eq q{ } and $inquote ) {
$first .= $char;
shift @chars;
next;
}
$first .= $char;
shift @chars;
}
if ($inquote) {
_fail('Could not parse command from commandline');
}
return $first;
}
1;
__END__
=pod
=head1 NAME
IPC::Run::Fused::Win32 - Implementation of IPC::Run::Fused for Win32
=head1 VERSION
version 0.04000000
=head1 METHODS
=head2 run_fused
run_fused( $fh, $executable, @params ) || die "$@";
run_fused( $fh, \$command_string ) || die "$@";
run_fused( $fh, sub { .. } ) || die "$@";
# Recommended
run_fused( my $fh, $executable, @params ) || die "$@";
# Somewhat supported
run_fused( my $fh, \$command_string ) || die "$@";
$fh will be clobbered like 'open' does, and $cmd, @args will be passed, as-is, through to exec() or system().
$fh will point to an IO::Handle attached to the end of a pipe running back to the called application.
the command will be run in a fork, and stderr and stdout "fused" into a singluar pipe.
B<NOTE:> at present, STDIN's FD is left unchanged, and child processes will inherit parent STDIN's, and will thus block ( somewhere ) waiting for response.
=head1 AUTHOR
Kent Fredric <kentnl@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Kent Fredric.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut