1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
package IPC::Run::Win32Pump;
=pod
=head1 NAME
IPC::Run::Win32Pump - helper processes to shovel data to/from parent, child
=head1 SYNOPSIS
Internal use only; see IPC::Run::Win32IO and best of luck to you.
=head1 DESCRIPTION
See L<IPC::Run::Win32Helper|IPC::Run::Win32Helper> for details. This
module is used in subprocesses that are spawned to shovel data to/from
parent processes from/to their child processes. Where possible, pumps
are optimized away.
NOTE: This is not a real module: it's a script in module form, designed
to be run like
$^X -MIPC::Run::Win32Pumper -e 1 ...
It parses a bunch of command line parameters from IPC::Run::Win32IO.
=cut
use strict;
use vars qw{$VERSION};
BEGIN {
$VERSION = '0.90';
}
use Win32API::File qw(
OsFHandleOpen
);
my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label );
BEGIN {
( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV;
## Rather than letting IPC::Run::Debug export all-0 constants
## when not debugging, we do it manually in order to not even
## load IPC::Run::Debug.
if ( $debug ) {
eval "use IPC::Run::Debug qw( :default _debug_init ); 1;"
or die $@;
}
else {
eval <<STUBS_END or die $@;
sub _debug {}
sub _debug_init {}
sub _debugging() { 0 }
sub _debugging_data() { 0 }
sub _debugging_details() { 0 }
sub _debugging_gory_details() { 0 }
1;
STUBS_END
}
}
## For some reason these get created with binmode on. AAargh, gotta #### REMOVE
## do it by hand below. #### REMOVE
if ( $debug ) { #### REMOVE
close STDERR; #### REMOVE
OsFHandleOpen( \*STDERR, $debug_fh, "w" ) #### REMOVE
or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$"; #### REMOVE
} #### REMOVE
close STDIN; #### REMOVE
OsFHandleOpen( \*STDIN, $stdin_fh, "r" ) #### REMOVE
or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$"; #### REMOVE
close STDOUT; #### REMOVE
OsFHandleOpen( \*STDOUT, $stdout_fh, "w" ) #### REMOVE
or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$"; #### REMOVE
binmode STDIN;
binmode STDOUT;
$| = 1;
select STDERR; $| = 1; select STDOUT;
$child_label ||= "pump";
_debug_init(
$parent_pid,
$parent_start_time,
$debug,
fileno STDERR,
$child_label,
);
_debug "Entered" if _debugging_details;
# No need to close all fds; win32 doesn't seem to pass any on to us.
$| = 1;
my $buf;
my $total_count = 0;
while (1) {
my $count = sysread STDIN, $buf, 10_000;
last unless $count;
if ( _debugging_gory_details ) {
my $msg = "'$buf'";
substr( $msg, 100, -1 ) = '...' if length $msg > 100;
$msg =~ s/\n/\\n/g;
$msg =~ s/\r/\\r/g;
$msg =~ s/\t/\\t/g;
$msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg;
_debug sprintf( "%5d chars revc: ", $count ), $msg;
}
$total_count += $count;
$buf =~ s/\r//g unless $binmode;
if ( _debugging_gory_details ) {
my $msg = "'$buf'";
substr( $msg, 100, -1 ) = '...' if length $msg > 100;
$msg =~ s/\n/\\n/g;
$msg =~ s/\r/\\r/g;
$msg =~ s/\t/\\t/g;
$msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg;
_debug sprintf( "%5d chars sent: ", $count ), $msg;
}
print $buf;
}
_debug "Exiting, transferred $total_count chars" if _debugging_details;
## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER,
## which should cause a "graceful shutdown in the background" on sockets.
## but that's only true if the process closes the socket manually, it
## seems; if the process exits and lets the OS clean up, the OS is not
## so kind. STDOUT is not always a socket, of course, but it won't hurt
## to close a pipe and may even help. With a closed source OS, who
## can tell?
##
## In any case, this close() is one of the main reasons we have helper
## processes; if the OS closed socket fds gracefully when an app exits,
## we'd just redirect the client directly to what is now the pump end
## of the socket. As it is, however, we need to let the client play with
## pipes, which don't have the abort-on-app-exit behavior, and then
## adapt to the sockets in the helper processes to allow the parent to
## select.
##
## Possible alternatives / improvements:
##
## 1) use helper threads instead of processes. I don't trust perl's threads
## as of 5.005 or 5.6 enough (which may be myopic of me).
##
## 2) figure out if/how to get at WaitForMultipleObjects() with pipe
## handles. May be able to take the Win32 handle and pass it to
## Win32::Event::wait_any, dunno.
##
## 3) Use Inline::C or a hand-tooled XS module to do helper threads.
## This would be faster than #1, but would require a ppm distro.
##
close STDOUT;
close STDERR;
1;
=pod
=head1 AUTHOR
Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc.
=head1 COPYRIGHT
Copyright 2001, Barrie Slaymaker, All Rights Reserved.
You may use this under the terms of either the GPL 2.0 ir the Artistic License.
=cut
|
