Commit | Line | Data |
a0d0e21e |
1 | =head1 NAME |
2 | |
184e9718 |
3 | perlipc - Perl interprocess communication (signals, fifos, pipes, safe subprocesses, sockets, and semaphores) |
a0d0e21e |
4 | |
5 | =head1 DESCRIPTION |
6 | |
4633a7c4 |
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 |
18 | triggered automatically by the kernel when special events transpire, like |
54310121 |
19 | a child process exiting, your process running out of stack space, or |
4633a7c4 |
20 | hitting file size limit. |
21 | |
22 | For example, to trap an interrupt signal, set up a handler like this. |
7b05b7e3 |
23 | Do as little as you possibly can in your handler; notice how all we do is |
24 | set a global variable and then raise an exception. That's because on most |
25 | systems, libraries are not re-entrant; particularly, memory allocation and |
26 | I/O routines are not. That means that doing nearly I<anything> in your |
27 | handler could in theory trigger a memory fault and subsequent core dump. |
4633a7c4 |
28 | |
29 | sub catch_zap { |
30 | my $signame = shift; |
31 | $shucks++; |
32 | die "Somebody sent me a SIG$signame"; |
54310121 |
33 | } |
4633a7c4 |
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++; |
54310121 |
48 | } |
4633a7c4 |
49 | |
6a3992aa |
50 | So to check whether signal 17 and SIGALRM were the same, do just this: |
4633a7c4 |
51 | |
52 | print "signal #17 = $signame[17]\n"; |
54310121 |
53 | if ($signo{ALRM}) { |
4633a7c4 |
54 | print "SIGALRM is $signo{ALRM}\n"; |
54310121 |
55 | } |
4633a7c4 |
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; |
54310121 |
68 | } |
4633a7c4 |
69 | sub more_functions { |
70 | # interrupts still ignored, for now... |
54310121 |
71 | } |
4633a7c4 |
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 |
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 |
54310121 |
86 | or has changed its UID. |
a0d0e21e |
87 | |
4633a7c4 |
88 | unless (kill 0 => $kid_pid) { |
89 | warn "something wicked happened to $kid_pid"; |
54310121 |
90 | } |
a0d0e21e |
91 | |
4633a7c4 |
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 |
97 | But that will be problematic for the more complicated handlers that need |
54310121 |
98 | to reinstall 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 |
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 | |
54310121 |
105 | sub REAPER { |
4633a7c4 |
106 | $waitedpid = wait; |
6a3992aa |
107 | # loathe sysV: it makes us not only reinstate |
108 | # the handler, but place it after the wait |
54310121 |
109 | $SIG{CHLD} = \&REAPER; |
4633a7c4 |
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"; |
54310121 |
117 | sub REAPER { |
4633a7c4 |
118 | my $child; |
4633a7c4 |
119 | while ($child = waitpid(-1,WNOHANG)) { |
120 | $Kid_Status{$child} = $?; |
54310121 |
121 | } |
6a3992aa |
122 | $SIG{CHLD} = \&REAPER; # still loathe sysV |
4633a7c4 |
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 | |
54310121 |
137 | eval { |
4633a7c4 |
138 | local $SIG{ALRM} = sub { die "alarm clock restart" }; |
54310121 |
139 | alarm 10; |
4633a7c4 |
140 | flock(FH, 2); # blocking write lock |
54310121 |
141 | alarm 0; |
4633a7c4 |
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 |
54310121 |
154 | just like a regular, connected anonymous pipes, except that the |
4633a7c4 |
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"; |
54310121 |
163 | if ( system('mknod', $path, 'p') |
4633a7c4 |
164 | && system('mkfifo', $path) ) |
165 | { |
166 | die "mk{nod,fifo} $path failed; |
54310121 |
167 | } |
4633a7c4 |
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 |
54310121 |
172 | on the other end. |
4633a7c4 |
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 |
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; |
54310121 |
188 | system('mknod', $FIFO, 'p') |
4633a7c4 |
189 | && die "can't mknod $FIFO: $!"; |
54310121 |
190 | } |
4633a7c4 |
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 |
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 |
205 | intend to write to: |
206 | |
54310121 |
207 | open(SPOOLER, "| cat -v | lpr -h 2>/dev/null") |
4633a7c4 |
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; |
54310121 |
220 | } |
a2eb9003 |
221 | close STATUS || die "bad netstat: $! $?"; |
4633a7c4 |
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 | |
54310121 |
234 | You might notice that you could use backticks for much the |
4633a7c4 |
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 |
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 | |
68dc0745 |
261 | =head2 Filehandles |
262 | |
263 | Both the main process and the child process share the same STDIN, |
264 | STDOUT and STDERR filehandles. If both processes try to access them |
265 | at once, strange things can happen. You may want to close or reopen |
266 | the filehandles for the child. You can get around this by opening |
267 | your pipe with open(), but on some systems this means that the child |
268 | process cannot outlive the parent. |
269 | |
270 | =head2 Background Processes |
271 | |
272 | You can run a command in the background with: |
273 | |
7b05b7e3 |
274 | system("cmd &"); |
68dc0745 |
275 | |
276 | The command's STDOUT and STDERR (and possibly STDIN, depending on your |
277 | shell) will be the same as the parent's. You won't need to catch |
278 | SIGCHLD because of the double-fork taking place (see below for more |
279 | details). |
280 | |
281 | =head2 Complete Dissociation of Child from Parent |
282 | |
283 | In some cases (starting server processes, for instance) you'll want to |
284 | complete dissociate the child process from the parent. The following |
285 | process is reported to work on most Unixish systems. Non-Unix users |
286 | should check their Your_OS::Process module for other solutions. |
287 | |
288 | =over 4 |
289 | |
290 | =item * |
291 | |
7a2e2cd6 |
292 | Open /dev/tty and use the TIOCNOTTY ioctl on it. See L<tty(4)> |
68dc0745 |
293 | for details. |
294 | |
295 | =item * |
296 | |
297 | Change directory to / |
298 | |
299 | =item * |
300 | |
301 | Reopen STDIN, STDOUT, and STDERR so they're not connected to the old |
302 | tty. |
303 | |
304 | =item * |
305 | |
306 | Background yourself like this: |
307 | |
308 | fork && exit; |
309 | |
310 | =back |
311 | |
4633a7c4 |
312 | =head2 Safe Pipe Opens |
313 | |
314 | Another interesting approach to IPC is making your single program go |
315 | multiprocess and communicate between (or even amongst) yourselves. The |
316 | open() function will accept a file argument of either C<"-|"> or C<"|-"> |
317 | to do a very interesting thing: it forks a child connected to the |
318 | filehandle you've opened. The child is running the same program as the |
319 | parent. This is useful for safely opening a file when running under an |
320 | assumed UID or GID, for example. If you open a pipe I<to> minus, you can |
321 | write to the filehandle you opened and your kid will find it in his |
322 | STDIN. If you open a pipe I<from> minus, you can read from the filehandle |
323 | you opened whatever your kid writes to his STDOUT. |
324 | |
325 | use English; |
326 | my $sleep_count = 0; |
327 | |
54310121 |
328 | do { |
c07a80fd |
329 | $pid = open(KID_TO_WRITE, "|-"); |
4633a7c4 |
330 | unless (defined $pid) { |
331 | warn "cannot fork: $!"; |
332 | die "bailing out" if $sleep_count++ > 6; |
333 | sleep 10; |
54310121 |
334 | } |
4633a7c4 |
335 | } until defined $pid; |
336 | |
337 | if ($pid) { # parent |
c07a80fd |
338 | print KID_TO_WRITE @some_data; |
339 | close(KID_TO_WRITE) || warn "kid exited $?"; |
4633a7c4 |
340 | } else { # child |
341 | ($EUID, $EGID) = ($UID, $GID); # suid progs only |
54310121 |
342 | open (FILE, "> /safe/file") |
4633a7c4 |
343 | || die "can't open /safe/file: $!"; |
344 | while (<STDIN>) { |
345 | print FILE; # child's STDIN is parent's KID |
54310121 |
346 | } |
4633a7c4 |
347 | exit; # don't forget this |
54310121 |
348 | } |
4633a7c4 |
349 | |
350 | Another common use for this construct is when you need to execute |
351 | something without the shell's interference. With system(), it's |
54310121 |
352 | straightforward, but you can't use a pipe open or backticks safely. |
4633a7c4 |
353 | That's because there's no way to stop the shell from getting its hands on |
354 | your arguments. Instead, use lower-level control to call exec() directly. |
355 | |
54310121 |
356 | Here's a safe backtick or pipe open for read: |
4633a7c4 |
357 | |
358 | # add error processing as above |
c07a80fd |
359 | $pid = open(KID_TO_READ, "-|"); |
4633a7c4 |
360 | |
361 | if ($pid) { # parent |
c07a80fd |
362 | while (<KID_TO_READ>) { |
4633a7c4 |
363 | # do something interesting |
54310121 |
364 | } |
c07a80fd |
365 | close(KID_TO_READ) || warn "kid exited $?"; |
4633a7c4 |
366 | |
367 | } else { # child |
368 | ($EUID, $EGID) = ($UID, $GID); # suid only |
369 | exec($program, @options, @args) |
370 | || die "can't exec program: $!"; |
371 | # NOTREACHED |
54310121 |
372 | } |
4633a7c4 |
373 | |
374 | |
375 | And here's a safe pipe open for writing: |
376 | |
377 | # add error processing as above |
c07a80fd |
378 | $pid = open(KID_TO_WRITE, "|-"); |
4633a7c4 |
379 | $SIG{ALRM} = sub { die "whoops, $program pipe broke" }; |
380 | |
381 | if ($pid) { # parent |
382 | for (@data) { |
c07a80fd |
383 | print KID_TO_WRITE; |
54310121 |
384 | } |
c07a80fd |
385 | close(KID_TO_WRITE) || warn "kid exited $?"; |
4633a7c4 |
386 | |
387 | } else { # child |
388 | ($EUID, $EGID) = ($UID, $GID); |
389 | exec($program, @options, @args) |
390 | || die "can't exec program: $!"; |
391 | # NOTREACHED |
54310121 |
392 | } |
4633a7c4 |
393 | |
394 | Note that these operations are full Unix forks, which means they may not be |
395 | correctly implemented on alien systems. Additionally, these are not true |
54310121 |
396 | multithreading. If you'd like to learn more about threading, see the |
184e9718 |
397 | F<modules> file mentioned below in the SEE ALSO section. |
4633a7c4 |
398 | |
7b05b7e3 |
399 | =head2 Bidirectional Communication with Another Process |
4633a7c4 |
400 | |
401 | While this works reasonably well for unidirectional communication, what |
402 | about bidirectional communication? The obvious thing you'd like to do |
403 | doesn't actually work: |
404 | |
c07a80fd |
405 | open(PROG_FOR_READING_AND_WRITING, "| some program |") |
4633a7c4 |
406 | |
54310121 |
407 | and if you forget to use the B<-w> flag, then you'll miss out |
4633a7c4 |
408 | entirely on the diagnostic message: |
409 | |
410 | Can't do bidirectional pipe at -e line 1. |
411 | |
412 | If you really want to, you can use the standard open2() library function |
7b05b7e3 |
413 | to catch both ends. There's also an open3() for tridirectional I/O so you |
4633a7c4 |
414 | can also catch your child's STDERR, but doing so would then require an |
415 | awkward select() loop and wouldn't allow you to use normal Perl input |
416 | operations. |
417 | |
418 | If you look at its source, you'll see that open2() uses low-level |
419 | primitives like Unix pipe() and exec() to create all the connections. |
420 | While it might have been slightly more efficient by using socketpair(), it |
421 | would have then been even less portable than it already is. The open2() |
422 | and open3() functions are unlikely to work anywhere except on a Unix |
423 | system or some other one purporting to be POSIX compliant. |
424 | |
425 | Here's an example of using open2(): |
426 | |
427 | use FileHandle; |
428 | use IPC::Open2; |
429 | $pid = open2( \*Reader, \*Writer, "cat -u -n" ); |
430 | Writer->autoflush(); # default here, actually |
431 | print Writer "stuff\n"; |
432 | $got = <Reader>; |
433 | |
6a3992aa |
434 | The problem with this is that Unix buffering is really going to |
435 | ruin your day. Even though your C<Writer> filehandle is auto-flushed, |
4633a7c4 |
436 | and the process on the other end will get your data in a timely manner, |
6a3992aa |
437 | you can't usually do anything to force it to give it back to you |
54310121 |
438 | in a similarly quick fashion. In this case, we could, because we |
4633a7c4 |
439 | gave I<cat> a B<-u> flag to make it unbuffered. But very few Unix |
440 | commands are designed to operate over pipes, so this seldom works |
54310121 |
441 | unless you yourself wrote the program on the other end of the |
4633a7c4 |
442 | double-ended pipe. |
443 | |
54310121 |
444 | A solution to this is the nonstandard F<Comm.pl> library. It uses |
4633a7c4 |
445 | pseudo-ttys to make your program behave more reasonably: |
446 | |
447 | require 'Comm.pl'; |
448 | $ph = open_proc('cat -n'); |
449 | for (1..10) { |
450 | print $ph "a line\n"; |
451 | print "got back ", scalar <$ph>; |
452 | } |
a0d0e21e |
453 | |
4633a7c4 |
454 | This way you don't have to have control over the source code of the |
54310121 |
455 | program you're using. The F<Comm> library also has expect() |
456 | and interact() functions. Find the library (and we hope its |
4633a7c4 |
457 | successor F<IPC::Chat>) at your nearest CPAN archive as detailed |
184e9718 |
458 | in the SEE ALSO section below. |
a0d0e21e |
459 | |
4633a7c4 |
460 | =head1 Sockets: Client/Server Communication |
a0d0e21e |
461 | |
6a3992aa |
462 | While not limited to Unix-derived operating systems (e.g., WinSock on PCs |
4633a7c4 |
463 | provides socket support, as do some VMS libraries), you may not have |
184e9718 |
464 | sockets on your system, in which case this section probably isn't going to do |
6a3992aa |
465 | you much good. With sockets, you can do both virtual circuits (i.e., TCP |
466 | streams) and datagrams (i.e., UDP packets). You may be able to do even more |
4633a7c4 |
467 | depending on your system. |
468 | |
469 | The Perl function calls for dealing with sockets have the same names as |
470 | the corresponding system calls in C, but their arguments tend to differ |
471 | for two reasons: first, Perl filehandles work differently than C file |
472 | descriptors. Second, Perl already knows the length of its strings, so you |
473 | don't need to pass that information. |
a0d0e21e |
474 | |
4633a7c4 |
475 | One of the major problems with old socket code in Perl was that it used |
476 | hard-coded values for some of the constants, which severely hurt |
477 | portability. If you ever see code that does anything like explicitly |
478 | setting C<$AF_INET = 2>, you know you're in for big trouble: An |
479 | immeasurably superior approach is to use the C<Socket> module, which more |
480 | reliably grants access to various constants and functions you'll need. |
a0d0e21e |
481 | |
68dc0745 |
482 | If you're not writing a server/client for an existing protocol like |
483 | NNTP or SMTP, you should give some thought to how your server will |
484 | know when the client has finished talking, and vice-versa. Most |
485 | protocols are based on one-line messages and responses (so one party |
4a6725af |
486 | knows the other has finished when a "\n" is received) or multi-line |
68dc0745 |
487 | messages and responses that end with a period on an empty line |
488 | ("\n.\n" terminates a message/response). |
489 | |
4633a7c4 |
490 | =head2 Internet TCP Clients and Servers |
a0d0e21e |
491 | |
4633a7c4 |
492 | Use Internet-domain sockets when you want to do client-server |
493 | communication that might extend to machines outside of your own system. |
494 | |
495 | Here's a sample TCP client using Internet-domain sockets: |
496 | |
497 | #!/usr/bin/perl -w |
498 | require 5.002; |
499 | use strict; |
500 | use Socket; |
501 | my ($remote,$port, $iaddr, $paddr, $proto, $line); |
502 | |
503 | $remote = shift || 'localhost'; |
504 | $port = shift || 2345; # random port |
505 | if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } |
506 | die "No port" unless $port; |
507 | $iaddr = inet_aton($remote) || die "no host: $remote"; |
508 | $paddr = sockaddr_in($port, $iaddr); |
509 | |
510 | $proto = getprotobyname('tcp'); |
511 | socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; |
512 | connect(SOCK, $paddr) || die "connect: $!"; |
54310121 |
513 | while (defined($line = <SOCK>)) { |
4633a7c4 |
514 | print $line; |
54310121 |
515 | } |
4633a7c4 |
516 | |
517 | close (SOCK) || die "close: $!"; |
518 | exit; |
519 | |
520 | And here's a corresponding server to go along with it. We'll |
521 | leave the address as INADDR_ANY so that the kernel can choose |
54310121 |
522 | the appropriate interface on multihomed hosts. If you want sit |
c07a80fd |
523 | on a particular interface (like the external side of a gateway |
524 | or firewall machine), you should fill this in with your real address |
525 | instead. |
526 | |
527 | #!/usr/bin/perl -Tw |
528 | require 5.002; |
529 | use strict; |
530 | BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } |
531 | use Socket; |
532 | use Carp; |
533 | |
54310121 |
534 | sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } |
c07a80fd |
535 | |
536 | my $port = shift || 2345; |
537 | my $proto = getprotobyname('tcp'); |
6a3992aa |
538 | $port = $1 if $port =~ /(\d+)/; # untaint port number |
539 | |
c07a80fd |
540 | socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; |
54310121 |
541 | setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, |
c07a80fd |
542 | pack("l", 1)) || die "setsockopt: $!"; |
543 | bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; |
544 | listen(Server,SOMAXCONN) || die "listen: $!"; |
545 | |
546 | logmsg "server started on port $port"; |
547 | |
548 | my $paddr; |
549 | |
550 | $SIG{CHLD} = \&REAPER; |
551 | |
552 | for ( ; $paddr = accept(Client,Server); close Client) { |
553 | my($port,$iaddr) = sockaddr_in($paddr); |
554 | my $name = gethostbyaddr($iaddr,AF_INET); |
555 | |
54310121 |
556 | logmsg "connection from $name [", |
557 | inet_ntoa($iaddr), "] |
c07a80fd |
558 | at port $port"; |
559 | |
54310121 |
560 | print Client "Hello there, $name, it's now ", |
c07a80fd |
561 | scalar localtime, "\n"; |
54310121 |
562 | } |
c07a80fd |
563 | |
54310121 |
564 | And here's a multithreaded version. It's multithreaded in that |
565 | like most typical servers, it spawns (forks) a slave server to |
c07a80fd |
566 | handle the client request so that the master server can quickly |
567 | go back to service a new client. |
4633a7c4 |
568 | |
569 | #!/usr/bin/perl -Tw |
570 | require 5.002; |
571 | use strict; |
572 | BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } |
a0d0e21e |
573 | use Socket; |
4633a7c4 |
574 | use Carp; |
a0d0e21e |
575 | |
4633a7c4 |
576 | sub spawn; # forward declaration |
54310121 |
577 | sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" } |
a0d0e21e |
578 | |
4633a7c4 |
579 | my $port = shift || 2345; |
580 | my $proto = getprotobyname('tcp'); |
80aa6872 |
581 | $port = $1 if $port =~ /(\d+)/; # untaint port number |
54310121 |
582 | |
c07a80fd |
583 | socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; |
54310121 |
584 | setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, |
c07a80fd |
585 | pack("l", 1)) || die "setsockopt: $!"; |
586 | bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!"; |
587 | listen(Server,SOMAXCONN) || die "listen: $!"; |
a0d0e21e |
588 | |
4633a7c4 |
589 | logmsg "server started on port $port"; |
a0d0e21e |
590 | |
4633a7c4 |
591 | my $waitedpid = 0; |
592 | my $paddr; |
a0d0e21e |
593 | |
54310121 |
594 | sub REAPER { |
4633a7c4 |
595 | $waitedpid = wait; |
6a3992aa |
596 | $SIG{CHLD} = \&REAPER; # loathe sysV |
4633a7c4 |
597 | logmsg "reaped $waitedpid" . ($? ? " with exit $?" : ''); |
598 | } |
599 | |
600 | $SIG{CHLD} = \&REAPER; |
601 | |
54310121 |
602 | for ( $waitedpid = 0; |
603 | ($paddr = accept(Client,Server)) || $waitedpid; |
604 | $waitedpid = 0, close Client) |
4633a7c4 |
605 | { |
6a3992aa |
606 | next if $waitedpid and not $paddr; |
4633a7c4 |
607 | my($port,$iaddr) = sockaddr_in($paddr); |
608 | my $name = gethostbyaddr($iaddr,AF_INET); |
609 | |
54310121 |
610 | logmsg "connection from $name [", |
611 | inet_ntoa($iaddr), "] |
4633a7c4 |
612 | at port $port"; |
a0d0e21e |
613 | |
54310121 |
614 | spawn sub { |
4633a7c4 |
615 | print "Hello there, $name, it's now ", scalar localtime, "\n"; |
54310121 |
616 | exec '/usr/games/fortune' |
4633a7c4 |
617 | or confess "can't exec fortune: $!"; |
618 | }; |
a0d0e21e |
619 | |
54310121 |
620 | } |
a0d0e21e |
621 | |
4633a7c4 |
622 | sub spawn { |
623 | my $coderef = shift; |
a0d0e21e |
624 | |
54310121 |
625 | unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') { |
4633a7c4 |
626 | confess "usage: spawn CODEREF"; |
a0d0e21e |
627 | } |
4633a7c4 |
628 | |
629 | my $pid; |
630 | if (!defined($pid = fork)) { |
631 | logmsg "cannot fork: $!"; |
632 | return; |
633 | } elsif ($pid) { |
634 | logmsg "begat $pid"; |
6a3992aa |
635 | return; # I'm the parent |
4633a7c4 |
636 | } |
6a3992aa |
637 | # else I'm the child -- go spawn |
4633a7c4 |
638 | |
c07a80fd |
639 | open(STDIN, "<&Client") || die "can't dup client to stdin"; |
640 | open(STDOUT, ">&Client") || die "can't dup client to stdout"; |
4633a7c4 |
641 | ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr"; |
642 | exit &$coderef(); |
54310121 |
643 | } |
4633a7c4 |
644 | |
645 | This server takes the trouble to clone off a child version via fork() for |
646 | each incoming request. That way it can handle many requests at once, |
647 | which you might not always want. Even if you don't fork(), the listen() |
648 | will allow that many pending connections. Forking servers have to be |
649 | particularly careful about cleaning up their dead children (called |
650 | "zombies" in Unix parlance), because otherwise you'll quickly fill up your |
651 | process table. |
652 | |
653 | We suggest that you use the B<-T> flag to use taint checking (see L<perlsec>) |
654 | even if we aren't running setuid or setgid. This is always a good idea |
655 | for servers and other programs run on behalf of someone else (like CGI |
656 | scripts), because it lessens the chances that people from the outside will |
657 | be able to compromise your system. |
658 | |
659 | Let's look at another TCP client. This one connects to the TCP "time" |
660 | service on a number of different machines and shows how far their clocks |
661 | differ from the system on which it's being run: |
662 | |
663 | #!/usr/bin/perl -w |
664 | require 5.002; |
665 | use strict; |
666 | use Socket; |
667 | |
668 | my $SECS_of_70_YEARS = 2208988800; |
54310121 |
669 | sub ctime { scalar localtime(shift) } |
4633a7c4 |
670 | |
54310121 |
671 | my $iaddr = gethostbyname('localhost'); |
672 | my $proto = getprotobyname('tcp'); |
673 | my $port = getservbyname('time', 'tcp'); |
4633a7c4 |
674 | my $paddr = sockaddr_in(0, $iaddr); |
675 | my($host); |
676 | |
677 | $| = 1; |
678 | printf "%-24s %8s %s\n", "localhost", 0, ctime(time()); |
679 | |
680 | foreach $host (@ARGV) { |
681 | printf "%-24s ", $host; |
682 | my $hisiaddr = inet_aton($host) || die "unknown host"; |
683 | my $hispaddr = sockaddr_in($port, $hisiaddr); |
684 | socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die "socket: $!"; |
685 | connect(SOCKET, $hispaddr) || die "bind: $!"; |
686 | my $rtime = ' '; |
687 | read(SOCKET, $rtime, 4); |
688 | close(SOCKET); |
689 | my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; |
690 | printf "%8d %s\n", $histime - time, ctime($histime); |
a0d0e21e |
691 | } |
692 | |
4633a7c4 |
693 | =head2 Unix-Domain TCP Clients and Servers |
694 | |
a2eb9003 |
695 | That's fine for Internet-domain clients and servers, but what about local |
4633a7c4 |
696 | communications? While you can use the same setup, sometimes you don't |
697 | want to. Unix-domain sockets are local to the current host, and are often |
54310121 |
698 | used internally to implement pipes. Unlike Internet domain sockets, Unix |
4633a7c4 |
699 | domain sockets can show up in the file system with an ls(1) listing. |
700 | |
701 | $ ls -l /dev/log |
702 | srw-rw-rw- 1 root 0 Oct 31 07:23 /dev/log |
a0d0e21e |
703 | |
4633a7c4 |
704 | You can test for these with Perl's B<-S> file test: |
705 | |
706 | unless ( -S '/dev/log' ) { |
707 | die "something's wicked with the print system"; |
54310121 |
708 | } |
4633a7c4 |
709 | |
710 | Here's a sample Unix-domain client: |
711 | |
712 | #!/usr/bin/perl -w |
713 | require 5.002; |
714 | use Socket; |
715 | use strict; |
716 | my ($rendezvous, $line); |
717 | |
718 | $rendezvous = shift || '/tmp/catsock'; |
719 | socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!"; |
9607fc9c |
720 | connect(SOCK, sockaddr_un($rendezvous)) || die "connect: $!"; |
54310121 |
721 | while (defined($line = <SOCK>)) { |
4633a7c4 |
722 | print $line; |
54310121 |
723 | } |
4633a7c4 |
724 | exit; |
725 | |
54310121 |
726 | And here's a corresponding server. |
4633a7c4 |
727 | |
728 | #!/usr/bin/perl -Tw |
729 | require 5.002; |
730 | use strict; |
731 | use Socket; |
732 | use Carp; |
733 | |
734 | BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } |
735 | |
736 | my $NAME = '/tmp/catsock'; |
737 | my $uaddr = sockaddr_un($NAME); |
738 | my $proto = getprotobyname('tcp'); |
739 | |
c07a80fd |
740 | socket(Server,PF_UNIX,SOCK_STREAM,0) || die "socket: $!"; |
4633a7c4 |
741 | unlink($NAME); |
c07a80fd |
742 | bind (Server, $uaddr) || die "bind: $!"; |
743 | listen(Server,SOMAXCONN) || die "listen: $!"; |
4633a7c4 |
744 | |
745 | logmsg "server started on $NAME"; |
746 | |
747 | $SIG{CHLD} = \&REAPER; |
748 | |
54310121 |
749 | for ( $waitedpid = 0; |
750 | accept(Client,Server) || $waitedpid; |
751 | $waitedpid = 0, close Client) |
4633a7c4 |
752 | { |
753 | next if $waitedpid; |
754 | logmsg "connection on $NAME"; |
54310121 |
755 | spawn sub { |
4633a7c4 |
756 | print "Hello there, it's now ", scalar localtime, "\n"; |
757 | exec '/usr/games/fortune' or die "can't exec fortune: $!"; |
758 | }; |
54310121 |
759 | } |
4633a7c4 |
760 | |
761 | As you see, it's remarkably similar to the Internet domain TCP server, so |
762 | much so, in fact, that we've omitted several duplicate functions--spawn(), |
763 | logmsg(), ctime(), and REAPER()--which are exactly the same as in the |
764 | other server. |
765 | |
766 | So why would you ever want to use a Unix domain socket instead of a |
767 | simpler named pipe? Because a named pipe doesn't give you sessions. You |
768 | can't tell one process's data from another's. With socket programming, |
769 | you get a separate session for each client: that's why accept() takes two |
770 | arguments. |
771 | |
772 | For example, let's say that you have a long running database server daemon |
773 | that you want folks from the World Wide Web to be able to access, but only |
774 | if they go through a CGI interface. You'd have a small, simple CGI |
775 | program that does whatever checks and logging you feel like, and then acts |
776 | as a Unix-domain client and connects to your private server. |
777 | |
7b05b7e3 |
778 | =head1 TCP Clients with IO::Socket |
779 | |
780 | For those preferring a higher-level interface to socket programming, the |
781 | IO::Socket module provides an object-oriented approach. IO::Socket is |
782 | included as part of the standard Perl distribution as of the 5.004 |
783 | release. If you're running an earlier version of Perl, just fetch |
784 | IO::Socket from CPAN, where you'll also find find modules providing easy |
785 | interfaces to the following systems: DNS, FTP, Ident (RFC 931), NIS and |
786 | NISPlus, NNTP, Ping, POP3, SMTP, SNMP, SSLeay, Telnet, and Time--just |
787 | to name a few. |
788 | |
789 | =head2 A Simple Client |
790 | |
791 | Here's a client that creates a TCP connection to the "daytime" |
792 | service at port 13 of the host name "localhost" and prints out everything |
793 | that the server there cares to provide. |
794 | |
795 | #!/usr/bin/perl -w |
796 | use IO::Socket; |
797 | $remote = IO::Socket::INET->new( |
798 | Proto => "tcp", |
799 | PeerAddr => "localhost", |
800 | PeerPort => "daytime(13)", |
801 | ) |
802 | or die "cannot connect to daytime port at localhost"; |
803 | while ( <$remote> ) { print } |
804 | |
805 | When you run this program, you should get something back that |
806 | looks like this: |
807 | |
808 | Wed May 14 08:40:46 MDT 1997 |
809 | |
810 | Here are what those parameters to the C<new> constructor mean: |
811 | |
812 | =over |
813 | |
814 | =item C<Proto> |
815 | |
816 | This is which protocol to use. In this case, the socket handle returned |
817 | will be connected to a TCP socket, because we want a stream-oriented |
818 | connection, that is, one that acts pretty much like a plain old file. |
819 | Not all sockets are this of this type. For example, the UDP protocol |
820 | can be used to make a datagram socket, used for message-passing. |
821 | |
822 | =item C<PeerAddr> |
823 | |
824 | This is the name or Internet address of the remote host the server is |
825 | running on. We could have specified a longer name like C<"www.perl.com">, |
826 | or an address like C<"204.148.40.9">. For demonstration purposes, we've |
827 | used the special hostname C<"localhost">, which should always mean the |
828 | current machine you're running on. The corresponding Internet address |
829 | for localhost is C<"127.1">, if you'd rather use that. |
830 | |
831 | =item C<PeerPort> |
832 | |
833 | This is the service name or port number we'd like to connect to. |
834 | We could have gotten away with using just C<"daytime"> on systems with a |
835 | well-configured system services file,[FOOTNOTE: The system services file |
836 | is in I</etc/services> under Unix] but just in case, we've specified the |
837 | port number (13) in parentheses. Using just the number would also have |
838 | worked, but constant numbers make careful programmers nervous. |
839 | |
840 | =back |
841 | |
842 | Notice how the return value from the C<new> constructor is used as |
843 | a filehandle in the C<while> loop? That's what's called an indirect |
844 | filehandle, a scalar variable containing a filehandle. You can use |
845 | it the same way you would a normal filehandle. For example, you |
846 | can read one line from it this way: |
847 | |
848 | $line = <$handle>; |
849 | |
850 | all remaining lines from is this way: |
851 | |
852 | @lines = <$handle>; |
853 | |
854 | and send a line of data to it this way: |
855 | |
856 | print $handle "some data\n"; |
857 | |
858 | =head2 A Webget Client |
859 | |
860 | Here's a simple client that takes a remote host to fetch a document |
861 | from, and then a list of documents to get from that host. This is a |
862 | more interesting client than the previous one because it first sends |
863 | something to the server before fetching the server's response. |
864 | |
865 | #!/usr/bin/perl -w |
866 | use IO::Socket; |
867 | unless (@ARGV > 1) { die "usage: $0 host document ..." } |
868 | $host = shift(@ARGV); |
869 | foreach $document ( @ARGV ) { |
870 | $remote = IO::Socket::INET->new( Proto => "tcp", |
871 | PeerAddr => $host, |
872 | PeerPort => "http(80)", |
873 | ); |
874 | unless ($remote) { die "cannot connect to http daemon on $host" } |
875 | $remote->autoflush(1); |
876 | print $remote "GET $document HTTP/1.0\n\n"; |
877 | while ( <$remote> ) { print } |
878 | close $remote; |
879 | } |
880 | |
881 | The web server handing the "http" service, which is assumed to be at |
882 | its standard port, number 80. If your the web server you're trying to |
883 | connect to is at a different port (like 1080 or 8080), you should specify |
884 | as the named-parameter pair, C<PeerPort =E<gt> 8080>. The C<autoflush> |
885 | method is used on the socket because otherwise the system would buffer |
886 | up the output we sent it. (If you're on a Mac, you'll also need to |
887 | change every C<"\n"> in your code that sends data over the network to |
888 | be a C<"\015\012"> instead.) |
889 | |
890 | Connecting to the server is only the first part of the process: once you |
891 | have the connection, you have to use the server's language. Each server |
892 | on the network has its own little command language that it expects as |
893 | input. The string that we send to the server starting with "GET" is in |
894 | HTTP syntax. In this case, we simply request each specified document. |
895 | Yes, we really are making a new connection for each document, even though |
896 | it's the same host. That's the way you always used to have to speak HTTP. |
897 | Recent versions of web browsers may request that the remote server leave |
898 | the connection open a little while, but the server doesn't have to honor |
899 | such a request. |
900 | |
901 | Here's an example of running that program, which we'll call I<webget>: |
902 | |
903 | shell_prompt$ webget www.perl.com /guanaco.html |
904 | HTTP/1.1 404 File Not Found |
905 | Date: Thu, 08 May 1997 18:02:32 GMT |
906 | Server: Apache/1.2b6 |
907 | Connection: close |
908 | Content-type: text/html |
909 | |
910 | <HEAD><TITLE>404 File Not Found</TITLE></HEAD> |
911 | <BODY><H1>File Not Found</H1> |
912 | The requested URL /guanaco.html was not found on this server.<P> |
913 | </BODY> |
914 | |
915 | Ok, so that's not very interesting, because it didn't find that |
916 | particular document. But a long response wouldn't have fit on this page. |
917 | |
918 | For a more fully-featured version of this program, you should look to |
919 | the I<lwp-request> program included with the LWP modules from CPAN. |
920 | |
921 | =head2 Interactive Client with IO::Socket |
922 | |
923 | Well, that's all fine if you want to send one command and get one answer, |
924 | but what about setting up something fully interactive, somewhat like |
925 | the way I<telnet> works? That way you can type a line, get the answer, |
926 | type a line, get the answer, etc. |
927 | |
928 | This client is more complicated than the two we've done so far, but if |
929 | you're on a system that supports the powerful C<fork> call, the solution |
930 | isn't that rough. Once you've made the connection to whatever service |
931 | you'd like to chat with, call C<fork> to clone your process. Each of |
932 | these two identical process has a very simple job to do: the parent |
933 | copies everything from the socket to standard output, while the child |
934 | simultaneously copies everything from standard input to the socket. |
935 | To accomplish the same thing using just one process would be I<much> |
936 | harder, because it's easier to code two processes to do one thing than it |
937 | is to code one process to do two things. (This keep-it-simple principle |
938 | is one of the cornerstones of the Unix philosophy, and good software |
939 | engineering as well, which is probably why it's spread to other systems |
940 | as well.) |
941 | |
942 | Here's the code: |
943 | |
944 | #!/usr/bin/perl -w |
945 | use strict; |
946 | use IO::Socket; |
947 | my ($host, $port, $kidpid, $handle, $line); |
948 | |
949 | unless (@ARGV == 2) { die "usage: $0 host port" } |
950 | ($host, $port) = @ARGV; |
951 | |
952 | # create a tcp connection to the specified host and port |
953 | $handle = IO::Socket::INET->new(Proto => "tcp", |
954 | PeerAddr => $host, |
955 | PeerPort => $port) |
956 | or die "can't connect to port $port on $host: $!"; |
957 | |
958 | $handle->autoflush(1); # so output gets there right away |
959 | print STDERR "[Connected to $host:$port]\n"; |
960 | |
961 | # split the program into two processes, identical twins |
962 | die "can't fork: $!" unless defined($kidpid = fork()); |
963 | |
964 | # the if{} block runs only in the parent process |
965 | if ($kidpid) { |
966 | # copy the socket to standard output |
967 | while (defined ($line = <$handle>)) { |
968 | print STDOUT $line; |
969 | } |
970 | kill("TERM", $kidpid); # send SIGTERM to child |
971 | } |
972 | # the else{} block runs only in the child process |
973 | else { |
974 | # copy standard input to the socket |
975 | while (defined ($line = <STDIN>)) { |
976 | print $handle $line; |
977 | } |
978 | } |
979 | |
980 | The C<kill> function in the parent's C<if> block is there to send a |
981 | signal to our child process (current running in the C<else> block) |
982 | as soon as the remote server has closed its end of the connection. |
983 | |
984 | The C<kill> at the end of the parent's block is there to eliminate the |
985 | child process as soon as the server we connect to closes its end. |
986 | |
987 | If the remote server sends data a byte at time, and you need that |
988 | data immediately without waiting for a newline (which might not happen), |
989 | you may wish to replace the C<while> loop in the parent with the |
990 | following: |
991 | |
992 | my $byte; |
993 | while (sysread($handle, $byte, 1) == 1) { |
994 | print STDOUT $byte; |
995 | } |
996 | |
997 | Making a system call for each byte you want to read is not very efficient |
998 | (to put it mildly) but is the simplest to explain and works reasonably |
999 | well. |
1000 | |
1001 | =head1 TCP Servers with IO::Socket |
1002 | |
1003 | Setting up server is little bit more involved than running a client. |
1004 | The model is that the server creates a special kind of socket that |
1005 | does nothing but listen on a particular port for incoming connections. |
1006 | It does this by calling the C<IO::Socket::INET-E<gt>new()> method with |
1007 | slightly different arguments than the client did. |
1008 | |
1009 | =over |
1010 | |
1011 | =item Proto |
1012 | |
1013 | This is which protocol to use. Like our clients, we'll |
1014 | still specify C<"tcp"> here. |
1015 | |
1016 | =item LocalPort |
1017 | |
1018 | We specify a local |
1019 | port in the C<LocalPort> argument, which we didn't do for the client. |
1020 | This is service name or port number for which you want to be the |
1021 | server. (Under Unix, ports under 1024 are restricted to the |
1022 | superuser.) In our sample, we'll use port 9000, but you can use |
1023 | any port that's not currently in use on your system. If you try |
1024 | to use one already in used, you'll get an "Address already in use" |
1025 | message. Under Unix, the C<netstat -a> command will show |
1026 | which services current have servers. |
1027 | |
1028 | =item Listen |
1029 | |
1030 | The C<Listen> parameter is set to the maximum number of |
1031 | pending connections we can accept until we turn away incoming clients. |
1032 | Think of it as a call-waiting queue for your telephone. |
1033 | The low-level Socket module has a special symbol for the system maximum, which |
1034 | is SOMAXCONN. |
1035 | |
1036 | =item Reuse |
1037 | |
1038 | The C<Reuse> parameter is needed so that we restart our server |
1039 | manually without waiting a few minutes to allow system buffers to |
1040 | clear out. |
1041 | |
1042 | =back |
1043 | |
1044 | Once the generic server socket has been created using the parameters |
1045 | listed above, the server then waits for a new client to connect |
1046 | to it. The server blocks in the C<accept> method, which eventually an |
1047 | bidirectional connection to the remote client. (Make sure to autoflush |
1048 | this handle to circumvent buffering.) |
1049 | |
1050 | To add to user-friendliness, our server prompts the user for commands. |
1051 | Most servers don't do this. Because of the prompt without a newline, |
1052 | you'll have to use the C<sysread> variant of the interactive client above. |
1053 | |
1054 | This server accepts one of five different commands, sending output |
1055 | back to the client. Note that unlike most network servers, this one |
1056 | only handles one incoming client at a time. Multithreaded servers are |
1057 | covered in Chapter 6 of the Camel or in the perlipc(1) manpage. |
1058 | |
1059 | Here's the code. We'll |
1060 | |
1061 | #!/usr/bin/perl -w |
1062 | use IO::Socket; |
1063 | use Net::hostent; # for OO version of gethostbyaddr |
1064 | |
1065 | $PORT = 9000; # pick something not in use |
1066 | |
1067 | $server = IO::Socket::INET->new( Proto => 'tcp', |
1068 | LocalPort => $PORT, |
1069 | Listen => SOMAXCONN, |
1070 | Reuse => 1); |
1071 | |
1072 | die "can't setup server" unless $server; |
1073 | print "[Server $0 accepting clients]\n"; |
1074 | |
1075 | while ($client = $server->accept()) { |
1076 | $client->autoflush(1); |
1077 | print $client "Welcome to $0; type help for command list.\n"; |
1078 | $hostinfo = gethostbyaddr($client->peeraddr); |
1079 | printf "[Connect from %s]\n", $hostinfo->name || $client->peerhost; |
1080 | print $client "Command? "; |
1081 | while ( <$client>) { |
1082 | next unless /\S/; # blank line |
1083 | if (/quit|exit/i) { last; } |
1084 | elsif (/date|time/i) { printf $client "%s\n", scalar localtime; } |
1085 | elsif (/who/i ) { print $client `who 2>&1`; } |
1086 | elsif (/cookie/i ) { print $client `/usr/games/fortune 2>&1`; } |
1087 | elsif (/motd/i ) { print $client `cat /etc/motd 2>&1`; } |
1088 | else { |
1089 | print $client "Commands: quit date who cookie motd\n"; |
1090 | } |
1091 | } continue { |
1092 | print $client "Command? "; |
1093 | } |
1094 | close $client; |
1095 | } |
1096 | |
1097 | =head1 UDP: Message Passing |
4633a7c4 |
1098 | |
1099 | Another kind of client-server setup is one that uses not connections, but |
1100 | messages. UDP communications involve much lower overhead but also provide |
1101 | less reliability, as there are no promises that messages will arrive at |
1102 | all, let alone in order and unmangled. Still, UDP offers some advantages |
1103 | over TCP, including being able to "broadcast" or "multicast" to a whole |
1104 | bunch of destination hosts at once (usually on your local subnet). If you |
1105 | find yourself overly concerned about reliability and start building checks |
6a3992aa |
1106 | into your message system, then you probably should use just TCP to start |
4633a7c4 |
1107 | with. |
1108 | |
1109 | Here's a UDP program similar to the sample Internet TCP client given |
7b05b7e3 |
1110 | earlier. However, instead of checking one host at a time, the UDP version |
4633a7c4 |
1111 | will check many of them asynchronously by simulating a multicast and then |
1112 | using select() to do a timed-out wait for I/O. To do something similar |
1113 | with TCP, you'd have to use a different socket handle for each host. |
1114 | |
1115 | #!/usr/bin/perl -w |
1116 | use strict; |
1117 | require 5.002; |
1118 | use Socket; |
1119 | use Sys::Hostname; |
1120 | |
54310121 |
1121 | my ( $count, $hisiaddr, $hispaddr, $histime, |
1122 | $host, $iaddr, $paddr, $port, $proto, |
4633a7c4 |
1123 | $rin, $rout, $rtime, $SECS_of_70_YEARS); |
1124 | |
1125 | $SECS_of_70_YEARS = 2208988800; |
1126 | |
1127 | $iaddr = gethostbyname(hostname()); |
1128 | $proto = getprotobyname('udp'); |
1129 | $port = getservbyname('time', 'udp'); |
1130 | $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick |
1131 | |
1132 | socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!"; |
1133 | bind(SOCKET, $paddr) || die "bind: $!"; |
1134 | |
1135 | $| = 1; |
1136 | printf "%-12s %8s %s\n", "localhost", 0, scalar localtime time; |
1137 | $count = 0; |
1138 | for $host (@ARGV) { |
1139 | $count++; |
1140 | $hisiaddr = inet_aton($host) || die "unknown host"; |
1141 | $hispaddr = sockaddr_in($port, $hisiaddr); |
1142 | defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!"; |
1143 | } |
1144 | |
1145 | $rin = ''; |
1146 | vec($rin, fileno(SOCKET), 1) = 1; |
1147 | |
1148 | # timeout after 10.0 seconds |
1149 | while ($count && select($rout = $rin, undef, undef, 10.0)) { |
1150 | $rtime = ''; |
1151 | ($hispaddr = recv(SOCKET, $rtime, 4, 0)) || die "recv: $!"; |
1152 | ($port, $hisiaddr) = sockaddr_in($hispaddr); |
1153 | $host = gethostbyaddr($hisiaddr, AF_INET); |
1154 | $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ; |
1155 | printf "%-12s ", $host; |
1156 | printf "%8d %s\n", $histime - time, scalar localtime($histime); |
1157 | $count--; |
1158 | } |
1159 | |
1160 | =head1 SysV IPC |
1161 | |
1162 | While System V IPC isn't so widely used as sockets, it still has some |
1163 | interesting uses. You can't, however, effectively use SysV IPC or |
1164 | Berkeley mmap() to have shared memory so as to share a variable amongst |
1165 | several processes. That's because Perl would reallocate your string when |
1166 | you weren't wanting it to. |
1167 | |
54310121 |
1168 | Here's a small example showing shared memory usage. |
a0d0e21e |
1169 | |
1170 | $IPC_PRIVATE = 0; |
1171 | $IPC_RMID = 0; |
1172 | $size = 2000; |
1173 | $key = shmget($IPC_PRIVATE, $size , 0777 ); |
4633a7c4 |
1174 | die unless defined $key; |
a0d0e21e |
1175 | |
1176 | $message = "Message #1"; |
1177 | shmwrite($key, $message, 0, 60 ) || die "$!"; |
1178 | shmread($key,$buff,0,60) || die "$!"; |
1179 | |
1180 | print $buff,"\n"; |
1181 | |
1182 | print "deleting $key\n"; |
1183 | shmctl($key ,$IPC_RMID, 0) || die "$!"; |
1184 | |
1185 | Here's an example of a semaphore: |
1186 | |
1187 | $IPC_KEY = 1234; |
1188 | $IPC_RMID = 0; |
1189 | $IPC_CREATE = 0001000; |
1190 | $key = semget($IPC_KEY, $nsems , 0666 | $IPC_CREATE ); |
1191 | die if !defined($key); |
1192 | print "$key\n"; |
1193 | |
a2eb9003 |
1194 | Put this code in a separate file to be run in more than one process. |
a0d0e21e |
1195 | Call the file F<take>: |
1196 | |
1197 | # create a semaphore |
1198 | |
1199 | $IPC_KEY = 1234; |
1200 | $key = semget($IPC_KEY, 0 , 0 ); |
1201 | die if !defined($key); |
1202 | |
1203 | $semnum = 0; |
1204 | $semflag = 0; |
1205 | |
1206 | # 'take' semaphore |
1207 | # wait for semaphore to be zero |
1208 | $semop = 0; |
1209 | $opstring1 = pack("sss", $semnum, $semop, $semflag); |
1210 | |
1211 | # Increment the semaphore count |
1212 | $semop = 1; |
1213 | $opstring2 = pack("sss", $semnum, $semop, $semflag); |
1214 | $opstring = $opstring1 . $opstring2; |
1215 | |
1216 | semop($key,$opstring) || die "$!"; |
1217 | |
a2eb9003 |
1218 | Put this code in a separate file to be run in more than one process. |
a0d0e21e |
1219 | Call this file F<give>: |
1220 | |
4633a7c4 |
1221 | # 'give' the semaphore |
a0d0e21e |
1222 | # run this in the original process and you will see |
1223 | # that the second process continues |
1224 | |
1225 | $IPC_KEY = 1234; |
1226 | $key = semget($IPC_KEY, 0, 0); |
1227 | die if !defined($key); |
1228 | |
1229 | $semnum = 0; |
1230 | $semflag = 0; |
1231 | |
1232 | # Decrement the semaphore count |
1233 | $semop = -1; |
1234 | $opstring = pack("sss", $semnum, $semop, $semflag); |
1235 | |
1236 | semop($key,$opstring) || die "$!"; |
1237 | |
7b05b7e3 |
1238 | The SysV IPC code above was written long ago, and it's definitely |
1239 | clunky looking. It should at the very least be made to C<use strict> |
1240 | and C<require "sys/ipc.ph">. Better yet, check out the IPC::SysV modules |
1241 | on CPAN. |
4633a7c4 |
1242 | |
1243 | =head1 NOTES |
1244 | |
1245 | If you are running under version 5.000 (dubious) or 5.001, you can still |
1246 | use most of the examples in this document. You may have to remove the |
1247 | C<use strict> and some of the my() statements for 5.000, and for both |
a2eb9003 |
1248 | you'll have to load in version 1.2 or older of the F<Socket.pm> module, which |
1249 | is included in I<perl5.002>. |
4633a7c4 |
1250 | |
1251 | Most of these routines quietly but politely return C<undef> when they fail |
1252 | instead of causing your program to die right then and there due to an |
1253 | uncaught exception. (Actually, some of the new I<Socket> conversion |
1254 | functions croak() on bad arguments.) It is therefore essential |
a2eb9003 |
1255 | that you should check the return values of these functions. Always begin |
4633a7c4 |
1256 | your socket programs this way for optimal success, and don't forget to add |
1257 | B<-T> taint checking flag to the pound-bang line for servers: |
1258 | |
1259 | #!/usr/bin/perl -w |
1260 | require 5.002; |
1261 | use strict; |
1262 | use sigtrap; |
1263 | use Socket; |
1264 | |
1265 | =head1 BUGS |
1266 | |
1267 | All these routines create system-specific portability problems. As noted |
1268 | elsewhere, Perl is at the mercy of your C libraries for much of its system |
1269 | behaviour. It's probably safest to assume broken SysV semantics for |
6a3992aa |
1270 | signals and to stick with simple TCP and UDP socket operations; e.g., don't |
a2eb9003 |
1271 | try to pass open file descriptors over a local UDP datagram socket if you |
4633a7c4 |
1272 | want your code to stand a chance of being portable. |
1273 | |
7b05b7e3 |
1274 | Because few vendors provide C libraries that are safely re-entrant, |
1275 | the prudent programmer will do little else within a handler beyond |
1276 | setting a numeric variable that already exists; or, if locked into |
1277 | a slow (restarting) system call, using die() to raise an exception |
1278 | and longjmp(3) out. In fact, even these may in some cases cause a |
1279 | core dump. It's probably best to avoid signals except where they are |
1280 | absolutely inevitable. This perilous problems will be addressed in a |
1281 | future release of Perl. |
4633a7c4 |
1282 | |
1283 | =head1 AUTHOR |
1284 | |
1285 | Tom Christiansen, with occasional vestiges of Larry Wall's original |
7b05b7e3 |
1286 | version and suggestions from the Perl Porters. |
4633a7c4 |
1287 | |
1288 | =head1 SEE ALSO |
1289 | |
7b05b7e3 |
1290 | There's a lot more to networking than this, but this should get you |
1291 | started. |
1292 | |
1293 | For intrepid programmers, the classic textbook I<Unix Network Programming> |
1294 | by Richard Stevens (published by Addison-Wesley). Note that most books |
1295 | on networking address networking from the perspective of a C programmer; |
1296 | translation to Perl is left as an exercise for the reader. |
1297 | |
1298 | The IO::Socket(3) manpage describes the object library, and the Socket(3) |
1299 | manpage describes the low-level interface to sockets. Besides the obvious |
1300 | functions in L<perlfunc>, you should also check out the F<modules> file |
1301 | at your nearest CPAN site. (See L<perlmodlib> or best yet, the F<Perl |
1302 | FAQ> for a description of what CPAN is and where to get it.) |
1303 | |
4633a7c4 |
1304 | Section 5 of the F<modules> file is devoted to "Networking, Device Control |
6a3992aa |
1305 | (modems), and Interprocess Communication", and contains numerous unbundled |
4633a7c4 |
1306 | modules numerous networking modules, Chat and Expect operations, CGI |
1307 | programming, DCE, FTP, IPC, NNTP, Proxy, Ptty, RPC, SNMP, SMTP, Telnet, |
1308 | Threads, and ToolTalk--just to name a few. |