Commit | Line | Data |
---|---|---|
a0d0e21e LW |
1 | =head1 NAME |
2 | ||
184e9718 | 3 | perlipc - Perl interprocess communication (signals, fifos, pipes, safe subprocesses, sockets, and semaphores) |
a0d0e21e LW |
4 | |
5 | =head1 DESCRIPTION | |
6 | ||
4633a7c4 LW |
7 | The basic IPC facilities of Perl are built out of the good old Unix |
8 | signals, named pipes, pipe opens, the Berkeley socket routines, and SysV | |
9 | IPC calls. Each is used in slightly different situations. | |
10 | ||
11 | =head1 Signals | |
12 | ||
13 | Perl uses a simple signal handling model: the %SIG hash contains names or | |
14 | references of user-installed signal handlers. These handlers will be called | |
15 | with an argument which is the name of the signal that triggered it. A | |
16 | signal may be generated intentionally from a particular keyboard sequence like | |
a2eb9003 | 17 | control-C or control-Z, sent to you from another process, or |
4633a7c4 LW |
18 | triggered automatically by the kernel when special events transpire, like |
19 | a child process exiting, your process running out of stack space, or | |
20 | hitting file size limit. | |
21 | ||
22 | For example, to trap an interrupt signal, set up a handler like this. | |
a2eb9003 | 23 | Notice how all we do is set a global variable and then raise an |
4633a7c4 LW |
24 | exception. That's because on most systems libraries are not |
25 | re-entrant, so calling any print() functions (or even anything that needs to | |
26 | malloc(3) more memory) could in theory trigger a memory fault | |
27 | and subsequent core dump. | |
28 | ||
29 | sub catch_zap { | |
30 | my $signame = shift; | |
31 | $shucks++; | |
32 | die "Somebody sent me a SIG$signame"; | |
33 | } | |
34 | $SIG{INT} = 'catch_zap'; # could fail in modules | |
35 | $SIG{INT} = \&catch_zap; # best strategy | |
36 | ||
37 | The names of the signals are the ones listed out by C<kill -l> on your | |
38 | system, or you can retrieve them from the Config module. Set up an | |
39 | @signame list indexed by number to get the name and a %signo table | |
40 | indexed by name to get the number: | |
41 | ||
42 | use Config; | |
43 | defined $Config{sig_name} || die "No sigs?"; | |
44 | foreach $name (split(' ', $Config{sig_name})) { | |
45 | $signo{$name} = $i; | |
46 | $signame[$i] = $name; | |
47 | $i++; | |
48 | } | |
49 | ||
6a3992aa | 50 | So to check whether signal 17 and SIGALRM were the same, do just this: |
4633a7c4 LW |
51 | |
52 | print "signal #17 = $signame[17]\n"; | |
53 | if ($signo{ALRM}) { | |
54 | print "SIGALRM is $signo{ALRM}\n"; | |
55 | } | |
56 | ||
57 | You may also choose to assign the strings C<'IGNORE'> or C<'DEFAULT'> as | |
58 | the handler, in which case Perl will try to discard the signal or do the | |
59 | default thing. Some signals can be neither trapped nor ignored, such as | |
60 | the KILL and STOP (but not the TSTP) signals. One strategy for | |
61 | temporarily ignoring signals is to use a local() statement, which will be | |
62 | automatically restored once your block is exited. (Remember that local() | |
63 | values are "inherited" by functions called from within that block.) | |
64 | ||
65 | sub precious { | |
66 | local $SIG{INT} = 'IGNORE'; | |
67 | &more_functions; | |
68 | } | |
69 | sub more_functions { | |
70 | # interrupts still ignored, for now... | |
71 | } | |
72 | ||
73 | Sending a signal to a negative process ID means that you send the signal | |
74 | to the entire Unix process-group. This code send a hang-up signal to all | |
75 | processes in the current process group I<except for> the current process | |
76 | itself: | |
77 | ||
78 | { | |
79 | local $SIG{HUP} = 'IGNORE'; | |
80 | kill HUP => -$$; | |
81 | # snazzy writing of: kill('HUP', -$$) | |
82 | } | |
a0d0e21e | 83 | |
4633a7c4 LW |
84 | Another interesting signal to send is signal number zero. This doesn't |
85 | actually affect another process, but instead checks whether it's alive | |
86 | or has changed its UID. | |
a0d0e21e | 87 | |
4633a7c4 LW |
88 | unless (kill 0 => $kid_pid) { |
89 | warn "something wicked happened to $kid_pid"; | |
90 | } | |
a0d0e21e | 91 | |
4633a7c4 LW |
92 | You might also want to employ anonymous functions for simple signal |
93 | handlers: | |
a0d0e21e | 94 | |
4633a7c4 | 95 | $SIG{INT} = sub { die "\nOutta here!\n" }; |
a0d0e21e | 96 | |
4633a7c4 LW |
97 | But that will be problematic for the more complicated handlers that need |
98 | to re-install themselves. Because Perl's signal mechanism is currently | |
184e9718 | 99 | based on the signal(3) function from the C library, you may sometimes be so |
4633a7c4 LW |
100 | misfortunate as to run on systems where that function is "broken", that |
101 | is, it behaves in the old unreliable SysV way rather than the newer, more | |
102 | reasonable BSD and POSIX fashion. So you'll see defensive people writing | |
103 | signal handlers like this: | |
a0d0e21e | 104 | |
4633a7c4 | 105 | sub REAPER { |
4633a7c4 | 106 | $waitedpid = wait; |
6a3992aa DL |
107 | # loathe sysV: it makes us not only reinstate |
108 | # the handler, but place it after the wait | |
109 | $SIG{CHLD} = \&REAPER; | |
4633a7c4 LW |
110 | } |
111 | $SIG{CHLD} = \&REAPER; | |
112 | # now do something that forks... | |
113 | ||
114 | or even the more elaborate: | |
115 | ||
6a3992aa | 116 | use POSIX ":sys_wait_h"; |
4633a7c4 LW |
117 | sub REAPER { |
118 | my $child; | |
4633a7c4 LW |
119 | while ($child = waitpid(-1,WNOHANG)) { |
120 | $Kid_Status{$child} = $?; | |
121 | } | |
6a3992aa | 122 | $SIG{CHLD} = \&REAPER; # still loathe sysV |
4633a7c4 LW |
123 | } |
124 | $SIG{CHLD} = \&REAPER; | |
125 | # do something that forks... | |
126 | ||
127 | Signal handling is also used for timeouts in Unix, While safely | |
128 | protected within an C<eval{}> block, you set a signal handler to trap | |
129 | alarm signals and then schedule to have one delivered to you in some | |
130 | number of seconds. Then try your blocking operation, clearing the alarm | |
131 | when it's done but not before you've exited your C<eval{}> block. If it | |
132 | goes off, you'll use die() to jump out of the block, much as you might | |
133 | using longjmp() or throw() in other languages. | |
134 | ||
135 | Here's an example: | |
136 | ||
137 | eval { | |
138 | local $SIG{ALRM} = sub { die "alarm clock restart" }; | |
139 | alarm 10; | |
140 | flock(FH, 2); # blocking write lock | |
141 | alarm 0; | |
142 | }; | |
143 | if ($@ and $@ !~ /alarm clock restart/) { die } | |
144 | ||
145 | For more complex signal handling, you might see the standard POSIX | |
146 | module. Lamentably, this is almost entirely undocumented, but | |
147 | the F<t/lib/posix.t> file from the Perl source distribution has some | |
148 | examples in it. | |
149 | ||
150 | =head1 Named Pipes | |
151 | ||
152 | A named pipe (often referred to as a FIFO) is an old Unix IPC | |
153 | mechanism for processes communicating on the same machine. It works | |
154 | just like a regular, connected anonymous pipes, except that the | |
155 | processes rendezvous using a filename and don't have to be related. | |
156 | ||
157 | To create a named pipe, use the Unix command mknod(1) or on some | |
158 | systems, mkfifo(1). These may not be in your normal path. | |
159 | ||
160 | # system return val is backwards, so && not || | |
161 | # | |
162 | $ENV{PATH} .= ":/etc:/usr/etc"; | |
163 | if ( system('mknod', $path, 'p') | |
164 | && system('mkfifo', $path) ) | |
165 | { | |
166 | die "mk{nod,fifo} $path failed; | |
167 | } | |
168 | ||
169 | ||
170 | A fifo is convenient when you want to connect a process to an unrelated | |
171 | one. When you open a fifo, the program will block until there's something | |
172 | on the other end. | |
173 | ||
174 | For example, let's say you'd like to have your F<.signature> file be a | |
175 | named pipe that has a Perl program on the other end. Now every time any | |
6a3992aa | 176 | program (like a mailer, news reader, finger program, etc.) tries to read |
4633a7c4 | 177 | from that file, the reading program will block and your program will |
6a3992aa | 178 | supply the new signature. We'll use the pipe-checking file test B<-p> |
4633a7c4 LW |
179 | to find out whether anyone (or anything) has accidentally removed our fifo. |
180 | ||
181 | chdir; # go home | |
182 | $FIFO = '.signature'; | |
183 | $ENV{PATH} .= ":/etc:/usr/games"; | |
184 | ||
185 | while (1) { | |
186 | unless (-p $FIFO) { | |
187 | unlink $FIFO; | |
188 | system('mknod', $FIFO, 'p') | |
189 | && die "can't mknod $FIFO: $!"; | |
190 | } | |
191 | ||
192 | # next line blocks until there's a reader | |
193 | open (FIFO, "> $FIFO") || die "can't write $FIFO: $!"; | |
194 | print FIFO "John Smith (smith\@host.org)\n", `fortune -s`; | |
195 | close FIFO; | |
6a3992aa | 196 | sleep 2; # to avoid dup signals |
4633a7c4 | 197 | } |
a0d0e21e | 198 | |
a0d0e21e | 199 | |
4633a7c4 LW |
200 | =head1 Using open() for IPC |
201 | ||
202 | Perl's basic open() statement can also be used for unidirectional interprocess | |
203 | communication by either appending or prepending a pipe symbol to the second | |
a2eb9003 | 204 | argument to open(). Here's how to start something up in a child process you |
4633a7c4 LW |
205 | intend to write to: |
206 | ||
207 | open(SPOOLER, "| cat -v | lpr -h 2>/dev/null") | |
208 | || die "can't fork: $!"; | |
209 | local $SIG{PIPE} = sub { die "spooler pipe broke" }; | |
210 | print SPOOLER "stuff\n"; | |
211 | close SPOOLER || die "bad spool: $! $?"; | |
212 | ||
213 | And here's how to start up a child process you intend to read from: | |
214 | ||
215 | open(STATUS, "netstat -an 2>&1 |") | |
216 | || die "can't fork: $!"; | |
217 | while (<STATUS>) { | |
218 | next if /^(tcp|udp)/; | |
219 | print; | |
220 | } | |
a2eb9003 | 221 | close STATUS || die "bad netstat: $! $?"; |
4633a7c4 LW |
222 | |
223 | If one can be sure that a particular program is a Perl script that is | |
224 | expecting filenames in @ARGV, the clever programmer can write something | |
225 | like this: | |
226 | ||
227 | $ program f1 "cmd1|" - f2 "cmd2|" f3 < tmpfile | |
228 | ||
229 | and irrespective of which shell it's called from, the Perl program will | |
230 | read from the file F<f1>, the process F<cmd1>, standard input (F<tmpfile> | |
231 | in this case), the F<f2> file, the F<cmd2> command, and finally the F<f3> | |
232 | file. Pretty nifty, eh? | |
233 | ||
6a3992aa | 234 | You might notice that you could use back-ticks for much the |
4633a7c4 LW |
235 | same effect as opening a pipe for reading: |
236 | ||
237 | print grep { !/^(tcp|udp)/ } `netstat -an 2>&1`; | |
238 | die "bad netstat" if $?; | |
239 | ||
240 | While this is true on the surface, it's much more efficient to process the | |
241 | file one line or record at a time because then you don't have to read the | |
242 | whole thing into memory at once. It also gives you finer control of the | |
243 | whole process, letting you to kill off the child process early if you'd | |
244 | like. | |
245 | ||
246 | Be careful to check both the open() and the close() return values. If | |
247 | you're I<writing> to a pipe, you should also trap SIGPIPE. Otherwise, | |
248 | think of what happens when you start up a pipe to a command that doesn't | |
249 | exist: the open() will in all likelihood succeed (it only reflects the | |
250 | fork()'s success), but then your output will fail--spectacularly. Perl | |
251 | can't know whether the command worked because your command is actually | |
252 | running in a separate process whose exec() might have failed. Therefore, | |
6a3992aa | 253 | while readers of bogus commands return just a quick end of file, writers |
4633a7c4 LW |
254 | to bogus command will trigger a signal they'd better be prepared to |
255 | handle. Consider: | |
256 | ||
257 | open(FH, "|bogus"); | |
258 | print FH "bang\n"; | |
259 | close FH; | |
260 | ||
261 | =head2 Safe Pipe Opens | |
262 | ||
263 | Another interesting approach to IPC is making your single program go | |
264 | multiprocess and communicate between (or even amongst) yourselves. The | |
265 | open() function will accept a file argument of either C<"-|"> or C<"|-"> | |
266 | to do a very interesting thing: it forks a child connected to the | |
267 | filehandle you've opened. The child is running the same program as the | |
268 | parent. This is useful for safely opening a file when running under an | |
269 | assumed UID or GID, for example. If you open a pipe I<to> minus, you can | |
270 | write to the filehandle you opened and your kid will find it in his | |
271 | STDIN. If you open a pipe I<from> minus, you can read from the filehandle | |
272 | you opened whatever your kid writes to his STDOUT. | |
273 | ||
274 | use English; | |
275 | my $sleep_count = 0; | |
276 | ||
277 | do { | |
c07a80fd | 278 | $pid = open(KID_TO_WRITE, "|-"); |
4633a7c4 LW |
279 | unless (defined $pid) { |
280 | warn "cannot fork: $!"; | |
281 | die "bailing out" if $sleep_count++ > 6; | |
282 | sleep 10; | |
283 | } | |
284 | } until defined $pid; | |
285 | ||
286 | if ($pid) { # parent | |
c07a80fd | 287 | print KID_TO_WRITE @some_data; |
288 | close(KID_TO_WRITE) || warn "kid exited $?"; | |
4633a7c4 LW |
289 | } else { # child |
290 | ($EUID, $EGID) = ($UID, $GID); # suid progs only | |
291 | open (FILE, "> /safe/file") | |
292 | || die "can't open /safe/file: $!"; | |
293 | while (<STDIN>) { | |
294 | print FILE; # child's STDIN is parent's KID | |
295 | } | |
296 | exit; # don't forget this | |
297 | } | |
298 | ||
299 | Another common use for this construct is when you need to execute | |
300 | something without the shell's interference. With system(), it's | |
6a3992aa | 301 | straightforward, but you can't use a pipe open or back-ticks safely. |
4633a7c4 LW |
302 | That's because there's no way to stop the shell from getting its hands on |
303 | your arguments. Instead, use lower-level control to call exec() directly. | |
304 | ||
6a3992aa | 305 | Here's a safe back-tick or pipe open for read: |
4633a7c4 LW |
306 | |
307 | # add error processing as above | |
c07a80fd | 308 | $pid = open(KID_TO_READ, "-|"); |
4633a7c4 LW |
309 | |
310 | if ($pid) { # parent | |
c07a80fd | 311 | while (<KID_TO_READ>) { |
4633a7c4 LW |
312 | # do something interesting |
313 | } | |
c07a80fd | 314 | close(KID_TO_READ) || warn "kid exited $?"; |
4633a7c4 LW |
315 | |
316 | } else { # child | |
317 | ($EUID, $EGID) = ($UID, $GID); # suid only | |
318 | exec($program, @options, @args) | |
319 | || die "can't exec program: $!"; | |
320 | # NOTREACHED | |
321 | } | |
322 | ||
323 | ||
324 | And here's a safe pipe open for writing: | |
325 | ||
326 | # add error processing as above | |
c07a80fd | 327 | $pid = open(KID_TO_WRITE, "|-"); |
4633a7c4 LW |
328 | $SIG{ALRM} = sub { die "whoops, $program pipe broke" }; |
329 | ||
330 | if ($pid) { # parent | |
331 | for (@data) { | |
c07a80fd | 332 | print KID_TO_WRITE; |
4633a7c4 | 333 | } |
c07a80fd | 334 | close(KID_TO_WRITE) || warn "kid exited $?"; |
4633a7c4 LW |
335 | |
336 | } else { # child | |
337 | ($EUID, $EGID) = ($UID, $GID); | |
338 | exec($program, @options, @args) | |
339 | || die "can't exec program: $!"; | |
340 | # NOTREACHED | |
341 | } | |
342 | ||
343 | Note that these operations are full Unix forks, which means they may not be | |
344 | correctly implemented on alien systems. Additionally, these are not true | |
6a3992aa | 345 | multi-threading. If you'd like to learn more about threading, see the |
184e9718 | 346 | F<modules> file mentioned below in the SEE ALSO section. |
4633a7c4 LW |
347 | |
348 | =head2 Bidirectional Communication | |
349 | ||
350 | While this works reasonably well for unidirectional communication, what | |
351 | about bidirectional communication? The obvious thing you'd like to do | |
352 | doesn't actually work: | |
353 | ||
c07a80fd | 354 | open(PROG_FOR_READING_AND_WRITING, "| some program |") |
4633a7c4 | 355 | |
c07a80fd | 356 | and if you forget to use the B<-w> flag, then you'll miss out |
4633a7c4 LW |
357 | entirely on the diagnostic message: |
358 | ||
359 | Can't do bidirectional pipe at -e line 1. | |
360 | ||
361 | If you really want to, you can use the standard open2() library function | |
6a3992aa | 362 | to catch both ends. There's also an open3() for tri-directional I/O so you |
4633a7c4 LW |
363 | can also catch your child's STDERR, but doing so would then require an |
364 | awkward select() loop and wouldn't allow you to use normal Perl input | |
365 | operations. | |
366 | ||
367 | If you look at its source, you'll see that open2() uses low-level | |
368 | primitives like Unix pipe() and exec() to create all the connections. | |
369 | While it might have been slightly more efficient by using socketpair(), it | |
370 | would have then been even less portable than it already is. The open2() | |
371 | and open3() functions are unlikely to work anywhere except on a Unix | |
372 | system or some other one purporting to be POSIX compliant. | |
373 | ||
374 | Here's an example of using open2(): | |
375 | ||
376 | use FileHandle; | |
377 | use IPC::Open2; | |
378 | $pid = open2( \*Reader, \*Writer, "cat -u -n" ); | |
379 | Writer->autoflush(); # default here, actually | |
380 | print Writer "stuff\n"; | |
381 | $got = <Reader>; | |
382 | ||
6a3992aa DL |
383 | The problem with this is that Unix buffering is really going to |
384 | ruin your day. Even though your C<Writer> filehandle is auto-flushed, | |
4633a7c4 | 385 | and the process on the other end will get your data in a timely manner, |
6a3992aa | 386 | you can't usually do anything to force it to give it back to you |
4633a7c4 LW |
387 | in a similarly quick fashion. In this case, we could, because we |
388 | gave I<cat> a B<-u> flag to make it unbuffered. But very few Unix | |
389 | commands are designed to operate over pipes, so this seldom works | |
390 | unless you yourself wrote the program on the other end of the | |
391 | double-ended pipe. | |
392 | ||
393 | A solution to this is the non-standard F<Comm.pl> library. It uses | |
394 | pseudo-ttys to make your program behave more reasonably: | |
395 | ||
396 | require 'Comm.pl'; | |
397 | $ph = open_proc('cat -n'); | |
398 | for (1..10) { | |
399 | print $ph "a line\n"; | |
400 | print "got back ", scalar <$ph>; | |
401 | } | |
a0d0e21e | 402 | |
4633a7c4 LW |
403 | This way you don't have to have control over the source code of the |
404 | program you're using. The F<Comm> library also has expect() | |
6a3992aa | 405 | and interact() functions. Find the library (and we hope its |
4633a7c4 | 406 | successor F<IPC::Chat>) at your nearest CPAN archive as detailed |
184e9718 | 407 | in the SEE ALSO section below. |
a0d0e21e | 408 | |
4633a7c4 | 409 | =head1 Sockets: Client/Server Communication |
a0d0e21e | 410 | |
6a3992aa | 411 | While not limited to Unix-derived operating systems (e.g., WinSock on PCs |
4633a7c4 | 412 | provides socket support, as do some VMS libraries), you may not have |
184e9718 | 413 | sockets on your system, in which case this section probably isn't going to do |
6a3992aa DL |
414 | you much good. With sockets, you can do both virtual circuits (i.e., TCP |
415 | streams) and datagrams (i.e., UDP packets). You may be able to do even more | |
4633a7c4 LW |
416 | depending on your system. |
417 | ||
418 | The Perl function calls for dealing with sockets have the same names as | |
419 | the corresponding system calls in C, but their arguments tend to differ | |
420 | for two reasons: first, Perl filehandles work differently than C file | |
421 | descriptors. Second, Perl already knows the length of its strings, so you | |
422 | don't need to pass that information. | |
a0d0e21e | 423 | |
4633a7c4 LW |
424 | One of the major problems with old socket code in Perl was that it used |
425 | hard-coded values for some of the constants, which severely hurt | |
426 | portability. If you ever see code that does anything like explicitly | |
427 | setting C<$AF_INET = 2>, you know you're in for big trouble: An | |
428 | immeasurably superior approach is to use the C<Socket> module, which more | |
429 | reliably grants access to various constants and functions you'll need. | |
a0d0e21e | 430 | |
4633a7c4 | 431 | =head2 Internet TCP Clients and Servers |
a0d0e21e | 432 | |
4633a7c4 LW |
433 | Use Internet-domain sockets when you want to do client-server |
434 | communication that might extend to machines outside of your own system. | |
435 | ||
436 | Here's a sample TCP client using Internet-domain sockets: | |
437 | ||
438 | #!/usr/bin/perl -w | |
439 | require 5.002; | |
440 | use strict; | |
441 | use Socket; | |
442 | my ($remote,$port, $iaddr, $paddr, $proto, $line); | |
443 | ||
444 | $remote = shift || 'localhost'; | |
445 | $port = shift || 2345; # random port | |
446 | if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } | |
447 | die "No port" unless $port; | |
448 | $iaddr = inet_aton($remote) || die "no host: $remote"; | |
449 | $paddr = sockaddr_in($port, $iaddr); | |
450 | ||
451 | $proto = getprotobyname('tcp'); | |
452 | socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; | |
453 | connect(SOCK, $paddr) || die "connect: $!"; | |
454 | while ($line = <SOCK>) { | |
455 | print $line; | |
456 | } | |
457 | ||
458 | close (SOCK) || die "close: $!"; | |
459 | exit; | |
460 | ||
461 | And here's a corresponding server to go along with it. We'll | |
462 | leave the address as INADDR_ANY so that the kernel can choose | |
6a3992aa | 463 | the appropriate interface on multi-homed hosts. If you want sit |
c07a80fd | 464 | on a particular interface (like the external side of a gateway |
465 | or firewall machine), you should fill this in with your real address | |
466 | instead. | |
467 | ||
468 | #!/usr/bin/perl -Tw | |
469 | require 5.002; | |
470 | use strict; | |
471 | BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } | |
472 | use Socket; | |
473 | use Carp; | |
474 | ||
475 | sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } | |
476 | ||
477 | my $port = shift || 2345; | |
478 | my $proto = getprotobyname('tcp'); | |
6a3992aa DL |
479 | $port = $1 if $port =~ /(\d+)/; # untaint port number |
480 | ||
c07a80fd | 481 | socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; |
482 | setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, | |
483 | pack("l", 1)) || die "setsockopt: $!"; | |
484 | bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; | |
485 | listen(Server,SOMAXCONN) || die "listen: $!"; | |
486 | ||
487 | logmsg "server started on port $port"; | |
488 | ||
489 | my $paddr; | |
490 | ||
491 | $SIG{CHLD} = \&REAPER; | |
492 | ||
493 | for ( ; $paddr = accept(Client,Server); close Client) { | |
494 | my($port,$iaddr) = sockaddr_in($paddr); | |
495 | my $name = gethostbyaddr($iaddr,AF_INET); | |
496 | ||
497 | logmsg "connection from $name [", | |
498 | inet_ntoa($iaddr), "] | |
499 | at port $port"; | |
500 | ||
80aa6872 | 501 | print Client "Hello there, $name, it's now ", |
c07a80fd | 502 | scalar localtime, "\n"; |
503 | } | |
504 | ||
6a3992aa | 505 | And here's a multi-threaded version. It's multi-threaded in that |
c07a80fd | 506 | like most typical servers, it spawns (forks) a slave server to |
507 | handle the client request so that the master server can quickly | |
508 | go back to service a new client. | |
4633a7c4 LW |
509 | |
510 | #!/usr/bin/perl -Tw | |
511 | require 5.002; | |
512 | use strict; | |
513 | BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } | |
a0d0e21e | 514 | use Socket; |
4633a7c4 | 515 | use Carp; |
a0d0e21e | 516 | |
4633a7c4 LW |
517 | sub spawn; # forward declaration |
518 | sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } | |
a0d0e21e | 519 | |
4633a7c4 LW |
520 | my $port = shift || 2345; |
521 | my $proto = getprotobyname('tcp'); | |
80aa6872 | 522 | $port = $1 if $port =~ /(\d+)/; # untaint port number |
523 | ||
c07a80fd | 524 | socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; |
525 | setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, | |
526 | pack("l", 1)) || die "setsockopt: $!"; | |
527 | bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; | |
528 | listen(Server,SOMAXCONN) || die "listen: $!"; | |
a0d0e21e | 529 | |
4633a7c4 | 530 | logmsg "server started on port $port"; |
a0d0e21e | 531 | |
4633a7c4 LW |
532 | my $waitedpid = 0; |
533 | my $paddr; | |
a0d0e21e | 534 | |
4633a7c4 | 535 | sub REAPER { |
4633a7c4 | 536 | $waitedpid = wait; |
6a3992aa | 537 | $SIG{CHLD} = \&REAPER; # loathe sysV |
4633a7c4 LW |
538 | logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ''); |
539 | } | |
540 | ||
541 | $SIG{CHLD} = \&REAPER; | |
542 | ||
543 | for ( $waitedpid = 0; | |
c07a80fd | 544 | ($paddr = accept(Client,Server)) || $waitedpid; |
545 | $waitedpid = 0, close Client) | |
4633a7c4 | 546 | { |
6a3992aa | 547 | next if $waitedpid and not $paddr; |
4633a7c4 LW |
548 | my($port,$iaddr) = sockaddr_in($paddr); |
549 | my $name = gethostbyaddr($iaddr,AF_INET); | |
550 | ||
551 | logmsg "connection from $name [", | |
552 | inet_ntoa($iaddr), "] | |
553 | at port $port"; | |
a0d0e21e | 554 | |
4633a7c4 LW |
555 | spawn sub { |
556 | print "Hello there, $name, it's now ", scalar localtime, "\n"; | |
557 | exec '/usr/games/fortune' | |
558 | or confess "can't exec fortune: $!"; | |
559 | }; | |
a0d0e21e | 560 | |
4633a7c4 | 561 | } |
a0d0e21e | 562 | |
4633a7c4 LW |
563 | sub spawn { |
564 | my $coderef = shift; | |
a0d0e21e | 565 | |
4633a7c4 LW |
566 | unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { |
567 | confess "usage: spawn CODEREF"; | |
a0d0e21e | 568 | } |
4633a7c4 LW |
569 | |
570 | my $pid; | |
571 | if (!defined($pid = fork)) { | |
572 | logmsg "cannot fork: $!"; | |
573 | return; | |
574 | } elsif ($pid) { | |
575 | logmsg "begat $pid"; | |
6a3992aa | 576 | return; # I'm the parent |
4633a7c4 | 577 | } |
6a3992aa | 578 | # else I'm the child -- go spawn |
4633a7c4 | 579 | |
c07a80fd | 580 | open(STDIN, "<&Client") || die "can't dup client to stdin"; |
581 | open(STDOUT, ">&Client") || die "can't dup client to stdout"; | |
4633a7c4 LW |
582 | ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr"; |
583 | exit &$coderef(); | |
584 | } | |
585 | ||
586 | This server takes the trouble to clone off a child version via fork() for | |
587 | each incoming request. That way it can handle many requests at once, | |
588 | which you might not always want. Even if you don't fork(), the listen() | |
589 | will allow that many pending connections. Forking servers have to be | |
590 | particularly careful about cleaning up their dead children (called | |
591 | "zombies" in Unix parlance), because otherwise you'll quickly fill up your | |
592 | process table. | |
593 | ||
594 | We suggest that you use the B<-T> flag to use taint checking (see L<perlsec>) | |
595 | even if we aren't running setuid or setgid. This is always a good idea | |
596 | for servers and other programs run on behalf of someone else (like CGI | |
597 | scripts), because it lessens the chances that people from the outside will | |
598 | be able to compromise your system. | |
599 | ||
600 | Let's look at another TCP client. This one connects to the TCP "time" | |
601 | service on a number of different machines and shows how far their clocks | |
602 | differ from the system on which it's being run: | |
603 | ||
604 | #!/usr/bin/perl -w | |
605 | require 5.002; | |
606 | use strict; | |
607 | use Socket; | |
608 | ||
609 | my $SECS_of_70_YEARS = 2208988800; | |
610 | sub ctime { scalar localtime(shift) } | |
611 | ||
612 | my $iaddr = gethostbyname('localhost'); | |
613 | my $proto = getprotobyname('tcp'); | |
614 | my $port = getservbyname('time', 'tcp'); | |
615 | my $paddr = sockaddr_in(0, $iaddr); | |
616 | my($host); | |
617 | ||
618 | $| = 1; | |
619 | printf "%-24s %8s %s\n", "localhost", 0, ctime(time()); | |
620 | ||
621 | foreach $host (@ARGV) { | |
622 | printf "%-24s ", $host; | |
623 | my $hisiaddr = inet_aton($host) || die "unknown host"; | |
624 | my $hispaddr = sockaddr_in($port, $hisiaddr); | |
625 | socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; | |
626 | connect(SOCKET, $hispaddr) || die "bind: $!"; | |
627 | my $rtime = ' '; | |
628 | read(SOCKET, $rtime, 4); | |
629 | close(SOCKET); | |
630 | my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; | |
631 | printf "%8d %s\n", $histime - time, ctime($histime); | |
a0d0e21e LW |
632 | } |
633 | ||
4633a7c4 LW |
634 | =head2 Unix-Domain TCP Clients and Servers |
635 | ||
a2eb9003 | 636 | That's fine for Internet-domain clients and servers, but what about local |
4633a7c4 LW |
637 | communications? While you can use the same setup, sometimes you don't |
638 | want to. Unix-domain sockets are local to the current host, and are often | |
639 | used internally to implement pipes. Unlike Internet domain sockets, UNIX | |
640 | domain sockets can show up in the file system with an ls(1) listing. | |
641 | ||
642 | $ ls -l /dev/log | |
643 | srw-rw-rw- 1 root 0 Oct 31 07:23 /dev/log | |
a0d0e21e | 644 | |
4633a7c4 LW |
645 | You can test for these with Perl's B<-S> file test: |
646 | ||
647 | unless ( -S '/dev/log' ) { | |
648 | die "something's wicked with the print system"; | |
649 | } | |
650 | ||
651 | Here's a sample Unix-domain client: | |
652 | ||
653 | #!/usr/bin/perl -w | |
654 | require 5.002; | |
655 | use Socket; | |
656 | use strict; | |
657 | my ($rendezvous, $line); | |
658 | ||
659 | $rendezvous = shift || '/tmp/catsock'; | |
660 | socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!"; | |
9607fc9c | 661 | connect(SOCK, sockaddr_un($rendezvous)) || die "connect: $!"; |
4633a7c4 LW |
662 | while ($line = <SOCK>) { |
663 | print $line; | |
664 | } | |
665 | exit; | |
666 | ||
667 | And here's a corresponding server. | |
668 | ||
669 | #!/usr/bin/perl -Tw | |
670 | require 5.002; | |
671 | use strict; | |
672 | use Socket; | |
673 | use Carp; | |
674 | ||
675 | BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } | |
676 | ||
677 | my $NAME = '/tmp/catsock'; | |
678 | my $uaddr = sockaddr_un($NAME); | |
679 | my $proto = getprotobyname('tcp'); | |
680 | ||
c07a80fd | 681 | socket(Server,PF_UNIX,SOCK_STREAM,0) || die "socket: $!"; |
4633a7c4 | 682 | unlink($NAME); |
c07a80fd | 683 | bind (Server, $uaddr) || die "bind: $!"; |
684 | listen(Server,SOMAXCONN) || die "listen: $!"; | |
4633a7c4 LW |
685 | |
686 | logmsg "server started on $NAME"; | |
687 | ||
688 | $SIG{CHLD} = \&REAPER; | |
689 | ||
690 | for ( $waitedpid = 0; | |
c07a80fd | 691 | accept(Client,Server) || $waitedpid; |
692 | $waitedpid = 0, close Client) | |
4633a7c4 LW |
693 | { |
694 | next if $waitedpid; | |
695 | logmsg "connection on $NAME"; | |
696 | spawn sub { | |
697 | print "Hello there, it's now ", scalar localtime, "\n"; | |
698 | exec '/usr/games/fortune' or die "can't exec fortune: $!"; | |
699 | }; | |
700 | } | |
701 | ||
702 | As you see, it's remarkably similar to the Internet domain TCP server, so | |
703 | much so, in fact, that we've omitted several duplicate functions--spawn(), | |
704 | logmsg(), ctime(), and REAPER()--which are exactly the same as in the | |
705 | other server. | |
706 | ||
707 | So why would you ever want to use a Unix domain socket instead of a | |
708 | simpler named pipe? Because a named pipe doesn't give you sessions. You | |
709 | can't tell one process's data from another's. With socket programming, | |
710 | you get a separate session for each client: that's why accept() takes two | |
711 | arguments. | |
712 | ||
713 | For example, let's say that you have a long running database server daemon | |
714 | that you want folks from the World Wide Web to be able to access, but only | |
715 | if they go through a CGI interface. You'd have a small, simple CGI | |
716 | program that does whatever checks and logging you feel like, and then acts | |
717 | as a Unix-domain client and connects to your private server. | |
718 | ||
719 | =head2 UDP: Message Passing | |
720 | ||
721 | Another kind of client-server setup is one that uses not connections, but | |
722 | messages. UDP communications involve much lower overhead but also provide | |
723 | less reliability, as there are no promises that messages will arrive at | |
724 | all, let alone in order and unmangled. Still, UDP offers some advantages | |
725 | over TCP, including being able to "broadcast" or "multicast" to a whole | |
726 | bunch of destination hosts at once (usually on your local subnet). If you | |
727 | find yourself overly concerned about reliability and start building checks | |
6a3992aa | 728 | into your message system, then you probably should use just TCP to start |
4633a7c4 LW |
729 | with. |
730 | ||
731 | Here's a UDP program similar to the sample Internet TCP client given | |
732 | above. However, instead of checking one host at a time, the UDP version | |
733 | will check many of them asynchronously by simulating a multicast and then | |
734 | using select() to do a timed-out wait for I/O. To do something similar | |
735 | with TCP, you'd have to use a different socket handle for each host. | |
736 | ||
737 | #!/usr/bin/perl -w | |
738 | use strict; | |
739 | require 5.002; | |
740 | use Socket; | |
741 | use Sys::Hostname; | |
742 | ||
743 | my ( $count, $hisiaddr, $hispaddr, $histime, | |
744 | $host, $iaddr, $paddr, $port, $proto, | |
745 | $rin, $rout, $rtime, $SECS_of_70_YEARS); | |
746 | ||
747 | $SECS_of_70_YEARS = 2208988800; | |
748 | ||
749 | $iaddr = gethostbyname(hostname()); | |
750 | $proto = getprotobyname('udp'); | |
751 | $port = getservbyname('time', 'udp'); | |
752 | $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick | |
753 | ||
754 | socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!"; | |
755 | bind(SOCKET, $paddr) || die "bind: $!"; | |
756 | ||
757 | $| = 1; | |
758 | printf "%-12s %8s %s\n", "localhost", 0, scalar localtime time; | |
759 | $count = 0; | |
760 | for $host (@ARGV) { | |
761 | $count++; | |
762 | $hisiaddr = inet_aton($host) || die "unknown host"; | |
763 | $hispaddr = sockaddr_in($port, $hisiaddr); | |
764 | defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!"; | |
765 | } | |
766 | ||
767 | $rin = ''; | |
768 | vec($rin, fileno(SOCKET), 1) = 1; | |
769 | ||
770 | # timeout after 10.0 seconds | |
771 | while ($count && select($rout = $rin, undef, undef, 10.0)) { | |
772 | $rtime = ''; | |
773 | ($hispaddr = recv(SOCKET, $rtime, 4, 0)) || die "recv: $!"; | |
774 | ($port, $hisiaddr) = sockaddr_in($hispaddr); | |
775 | $host = gethostbyaddr($hisiaddr, AF_INET); | |
776 | $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; | |
777 | printf "%-12s ", $host; | |
778 | printf "%8d %s\n", $histime - time, scalar localtime($histime); | |
779 | $count--; | |
780 | } | |
781 | ||
782 | =head1 SysV IPC | |
783 | ||
784 | While System V IPC isn't so widely used as sockets, it still has some | |
785 | interesting uses. You can't, however, effectively use SysV IPC or | |
786 | Berkeley mmap() to have shared memory so as to share a variable amongst | |
787 | several processes. That's because Perl would reallocate your string when | |
788 | you weren't wanting it to. | |
789 | ||
790 | ||
791 | Here's a small example showing shared memory usage. | |
a0d0e21e LW |
792 | |
793 | $IPC_PRIVATE = 0; | |
794 | $IPC_RMID = 0; | |
795 | $size = 2000; | |
796 | $key = shmget($IPC_PRIVATE, $size , 0777 ); | |
4633a7c4 | 797 | die unless defined $key; |
a0d0e21e LW |
798 | |
799 | $message = "Message #1"; | |
800 | shmwrite($key, $message, 0, 60 ) || die "$!"; | |
801 | shmread($key,$buff,0,60) || die "$!"; | |
802 | ||
803 | print $buff,"\n"; | |
804 | ||
805 | print "deleting $key\n"; | |
806 | shmctl($key ,$IPC_RMID, 0) || die "$!"; | |
807 | ||
808 | Here's an example of a semaphore: | |
809 | ||
810 | $IPC_KEY = 1234; | |
811 | $IPC_RMID = 0; | |
812 | $IPC_CREATE = 0001000; | |
813 | $key = semget($IPC_KEY, $nsems , 0666 | $IPC_CREATE ); | |
814 | die if !defined($key); | |
815 | print "$key\n"; | |
816 | ||
a2eb9003 | 817 | Put this code in a separate file to be run in more than one process. |
a0d0e21e LW |
818 | Call the file F<take>: |
819 | ||
820 | # create a semaphore | |
821 | ||
822 | $IPC_KEY = 1234; | |
823 | $key = semget($IPC_KEY, 0 , 0 ); | |
824 | die if !defined($key); | |
825 | ||
826 | $semnum = 0; | |
827 | $semflag = 0; | |
828 | ||
829 | # 'take' semaphore | |
830 | # wait for semaphore to be zero | |
831 | $semop = 0; | |
832 | $opstring1 = pack("sss", $semnum, $semop, $semflag); | |
833 | ||
834 | # Increment the semaphore count | |
835 | $semop = 1; | |
836 | $opstring2 = pack("sss", $semnum, $semop, $semflag); | |
837 | $opstring = $opstring1 . $opstring2; | |
838 | ||
839 | semop($key,$opstring) || die "$!"; | |
840 | ||
a2eb9003 | 841 | Put this code in a separate file to be run in more than one process. |
a0d0e21e LW |
842 | Call this file F<give>: |
843 | ||
4633a7c4 | 844 | # 'give' the semaphore |
a0d0e21e LW |
845 | # run this in the original process and you will see |
846 | # that the second process continues | |
847 | ||
848 | $IPC_KEY = 1234; | |
849 | $key = semget($IPC_KEY, 0, 0); | |
850 | die if !defined($key); | |
851 | ||
852 | $semnum = 0; | |
853 | $semflag = 0; | |
854 | ||
855 | # Decrement the semaphore count | |
856 | $semop = -1; | |
857 | $opstring = pack("sss", $semnum, $semop, $semflag); | |
858 | ||
859 | semop($key,$opstring) || die "$!"; | |
860 | ||
4633a7c4 LW |
861 | =head1 WARNING |
862 | ||
863 | The SysV IPC code above was written long ago, and it's definitely clunky | |
864 | looking. It should at the very least be made to C<use strict> and | |
865 | C<require "sys/ipc.ph">. Better yet, perhaps someone should create an | |
866 | C<IPC::SysV> module the way we have the C<Socket> module for normal | |
867 | client-server communications. | |
868 | ||
869 | (... time passes) | |
870 | ||
871 | Voila! Check out the IPC::SysV modules written by Jack Shirazi. You can | |
872 | find them at a CPAN store near you. | |
873 | ||
874 | =head1 NOTES | |
875 | ||
876 | If you are running under version 5.000 (dubious) or 5.001, you can still | |
877 | use most of the examples in this document. You may have to remove the | |
878 | C<use strict> and some of the my() statements for 5.000, and for both | |
a2eb9003 | 879 | you'll have to load in version 1.2 or older of the F<Socket.pm> module, which |
880 | is included in I<perl5.002>. | |
4633a7c4 LW |
881 | |
882 | Most of these routines quietly but politely return C<undef> when they fail | |
883 | instead of causing your program to die right then and there due to an | |
884 | uncaught exception. (Actually, some of the new I<Socket> conversion | |
885 | functions croak() on bad arguments.) It is therefore essential | |
a2eb9003 | 886 | that you should check the return values of these functions. Always begin |
4633a7c4 LW |
887 | your socket programs this way for optimal success, and don't forget to add |
888 | B<-T> taint checking flag to the pound-bang line for servers: | |
889 | ||
890 | #!/usr/bin/perl -w | |
891 | require 5.002; | |
892 | use strict; | |
893 | use sigtrap; | |
894 | use Socket; | |
895 | ||
896 | =head1 BUGS | |
897 | ||
898 | All these routines create system-specific portability problems. As noted | |
899 | elsewhere, Perl is at the mercy of your C libraries for much of its system | |
900 | behaviour. It's probably safest to assume broken SysV semantics for | |
6a3992aa | 901 | signals and to stick with simple TCP and UDP socket operations; e.g., don't |
a2eb9003 | 902 | try to pass open file descriptors over a local UDP datagram socket if you |
4633a7c4 LW |
903 | want your code to stand a chance of being portable. |
904 | ||
905 | Because few vendors provide C libraries that are safely | |
906 | re-entrant, the prudent programmer will do little else within | |
907 | a handler beyond die() to raise an exception and longjmp(3) out. | |
908 | ||
909 | =head1 AUTHOR | |
910 | ||
911 | Tom Christiansen, with occasional vestiges of Larry Wall's original | |
912 | version. | |
913 | ||
914 | =head1 SEE ALSO | |
915 | ||
916 | Besides the obvious functions in L<perlfunc>, you should also check out | |
917 | the F<modules> file at your nearest CPAN site. (See L<perlmod> or best | |
918 | yet, the F<Perl FAQ> for a description of what CPAN is and where to get it.) | |
919 | Section 5 of the F<modules> file is devoted to "Networking, Device Control | |
6a3992aa | 920 | (modems), and Interprocess Communication", and contains numerous unbundled |
4633a7c4 LW |
921 | modules numerous networking modules, Chat and Expect operations, CGI |
922 | programming, DCE, FTP, IPC, NNTP, Proxy, Ptty, RPC, SNMP, SMTP, Telnet, | |
923 | Threads, and ToolTalk--just to name a few. |