]> gb7djk.dxcluster.net Git - spider.git/blob - perl/Msg.pm
fix it up a bit
[spider.git] / perl / Msg.pm
1 #
2 # This has been taken from the 'Advanced Perl Programming' book by Sriram Srinivasan 
3 #
4 # I am presuming that the code is distributed on the same basis as perl itself.
5 #
6 # I have modified it to suit my devious purposes (Dirk Koopman G1TLH)
7 #
8 # $Id$
9 #
10
11 package Msg;
12
13 use strict;
14
15 use vars qw($VERSION $BRANCH);
16 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
17 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
18 $main::build += $VERSION;
19 $main::branch += $BRANCH;
20
21 use IO::Select;
22 use IO::Socket;
23 use DXDebug;
24 use Timer;
25
26 use vars qw(%rd_callbacks %wt_callbacks %er_callbacks $rd_handles $wt_handles $er_handles $now %conns $noconns $blocking_supported $cnum $total_in $total_out);
27
28 %rd_callbacks = ();
29 %wt_callbacks = ();
30 %er_callbacks = ();
31 $rd_handles   = IO::Select->new();
32 $wt_handles   = IO::Select->new();
33 $er_handles   = IO::Select->new();
34 $total_in = $total_out = 0;
35
36 $now = time;
37
38 BEGIN {
39     # Checks if blocking is supported
40     eval {
41                 local $^W;
42         require POSIX; POSIX->import(qw(O_NONBLOCK F_SETFL F_GETFL))
43     };
44         if ($@ || $main::is_win) {
45 #               print STDERR "POSIX Blocking *** NOT *** supported $@\n";
46                 $blocking_supported = 0;
47         } else {
48                 $blocking_supported = 1;
49 #               print STDERR "POSIX Blocking enabled\n";
50         }
51
52
53         # import as many of these errno values as are available
54         eval {
55                 local $^W;
56                 require Errno; Errno->import(qw(EAGAIN EINPROGRESS EWOULDBLOCK));
57         };
58
59         unless ($^O eq 'MSWin32') {
60                 if ($] >= 5.6) {
61                         eval {
62                                 local $^W;
63                                 require Socket; Socket->import(qw(IPPROTO_TCP TCP_NODELAY));
64                         };
65                 } else {
66                         dbg("IPPROTO_TCP and TCP_NODELAY manually defined");
67                         eval 'sub IPPROTO_TCP {     6 };';
68                         eval 'sub TCP_NODELAY {     1 };';
69                 }
70         }
71         # http://support.microsoft.com/support/kb/articles/Q150/5/37.asp
72         # defines EINPROGRESS as 10035.  We provide it here because some
73         # Win32 users report POSIX::EINPROGRESS is not vendor-supported.
74         if ($^O eq 'MSWin32') { 
75                 eval '*EINPROGRESS = sub { 10036 };';
76                 eval '*EWOULDBLOCK = *EAGAIN = sub { 10035 };';
77                 eval '*F_GETFL     = sub {     0 };';
78                 eval '*F_SETFL     = sub {     0 };';
79                 eval '*IPPROTO_TCP     = sub {     6 };';
80                 eval '*TCP_NODELAY     = sub {     1 };';
81                 $blocking_supported = 0;   # it appears that this DOESN'T work :-(
82         } 
83 }
84
85 my $w = $^W;
86 $^W = 0;
87 my $eagain = eval {EAGAIN()};
88 my $einprogress = eval {EINPROGRESS()};
89 my $ewouldblock = eval {EWOULDBLOCK()};
90 $^W = $w;
91 $cnum = 0;
92
93
94 #
95 #-----------------------------------------------------------------
96 # Generalised initializer
97
98 sub new
99 {
100     my ($pkg, $rproc) = @_;
101         my $obj = ref($pkg);
102         my $class = $obj || $pkg;
103
104     my $conn = {
105         rproc => $rproc,
106                 inqueue => [],
107                 outqueue => [],
108                 state => 0,
109                 lineend => "\r\n",
110                 csort => 'telnet',
111                 timeval => 60,
112                 blocking => 0,
113                 cnum => (($cnum < 999) ? (++$cnum) : ($cnum = 1)),
114     };
115
116         $noconns++;
117         
118         dbg("Connection created ($noconns)") if isdbg('connll');
119         return bless $conn, $class;
120 }
121
122 sub set_error
123 {
124         my $conn = shift;
125         my $callback = shift;
126         $conn->{eproc} = $callback;
127         set_event_handler($conn->{sock}, error => $callback) if exists $conn->{sock};
128 }
129
130 sub set_rproc
131 {
132         my $conn = shift;
133         my $callback = shift;
134         $conn->{rproc} = $callback;
135 }
136
137 sub blocking
138 {
139         return unless $blocking_supported;
140
141         # Make the handle stop blocking, the Windows way.
142         if ($main::is_win) { 
143           # 126 is FIONBIO (some docs say 0x7F << 16)
144                 ioctl( $_[0],
145                            0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
146                            "$_[1]"
147                          );
148         } else {
149                 my $flags = fcntl ($_[0], F_GETFL, 0);
150                 if ($_[1]) {
151                         $flags &= ~O_NONBLOCK;
152                 } else {
153                         $flags |= O_NONBLOCK;
154                 }
155                 fcntl ($_[0], F_SETFL, $flags);
156         }
157 }
158
159 # save it
160 sub conns
161 {
162         my $pkg = shift;
163         my $call = shift;
164         my $ref;
165         
166         if (ref $pkg) {
167                 $call = $pkg->{call} unless $call;
168                 return undef unless $call;
169                 dbg("changing $pkg->{call} to $call") if isdbg('connll') && exists $pkg->{call} && $call ne $pkg->{call};
170                 delete $conns{$pkg->{call}} if exists $pkg->{call} && exists $conns{$pkg->{call}} && $pkg->{call} ne $call; 
171                 $pkg->{call} = $call;
172                 $ref = $conns{$call} = $pkg;
173                 dbg("Connection $pkg->{cnum} $call stored") if isdbg('connll');
174         } else {
175                 $ref = $conns{$call};
176         }
177         return $ref;
178 }
179
180 # this is only called by any dependent processes going away unexpectedly
181 sub pid_gone
182 {
183         my ($pkg, $pid) = @_;
184         
185         my @pid = grep {$_->{pid} == $pid} values %conns;
186         foreach my $p (@pid) {
187                 &{$p->{eproc}}($p, "$pid has gorn") if exists $p->{eproc};
188                 $p->disconnect;
189         }
190 }
191
192 #-----------------------------------------------------------------
193 # Send side routines
194 sub connect {
195     my ($pkg, $to_host, $to_port, $rproc) = @_;
196
197     # Create a connection end-point object
198     my $conn = $pkg;
199         unless (ref $pkg) {
200                 $conn = $pkg->new($rproc);
201         }
202         $conn->{peerhost} = $to_host;
203         $conn->{peerport} = $to_port;
204         $conn->{sort} = 'Outgoing';
205         
206     # Create a new internet socket
207     my $sock = IO::Socket::INET->new();
208     return undef unless $sock;
209         
210         my $proto = getprotobyname('tcp');
211         $sock->socket(AF_INET, SOCK_STREAM, $proto) or return undef;
212         
213         blocking($sock, 0);
214         $conn->{blocking} = 0;
215
216         # does the host resolve?
217         my $ip = gethostbyname($to_host);
218         return undef unless $ip;
219         
220         my $r = connect($sock, pack_sockaddr_in($to_port, $ip));
221         return undef unless $r || _err_will_block($!);
222         
223         $conn->{sock} = $sock;
224     
225     if ($conn->{rproc}) {
226         my $callback = sub {$conn->_rcv};
227         set_event_handler ($sock, read => $callback);
228     }
229     return $conn;
230 }
231
232 sub start_program
233 {
234         my ($conn, $line, $sort) = @_;
235         my $pid;
236         
237         local $^F = 10000;              # make sure it ain't closed on exec
238         my ($a, $b) = IO::Socket->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
239         if ($a && $b) {
240                 $a->autoflush(1);
241                 $b->autoflush(1);
242                 $pid = fork;
243                 if (defined $pid) {
244                         if ($pid) {
245                                 close $b;
246                                 $conn->{sock} = $a;
247                                 $conn->{csort} = $sort;
248                                 $conn->{lineend} = "\cM" if $sort eq 'ax25';
249                                 $conn->{pid} = $pid;
250                                 if ($conn->{rproc}) {
251                                         my $callback = sub {$conn->_rcv};
252                                         Msg::set_event_handler ($a, read => $callback);
253                                 }
254                                 dbg("connect $conn->{cnum}: started pid: $conn->{pid} as $line") if isdbg('connect');
255                         } else {
256                                 $^W = 0;
257                                 dbgclose();
258                                 STDIN->close;
259                                 STDOUT->close;
260                                 STDOUT->close;
261                                 *STDIN = IO::File->new_from_fd($b, 'r') or die;
262                                 *STDOUT = IO::File->new_from_fd($b, 'w') or die;
263                                 *STDERR = IO::File->new_from_fd($b, 'w') or die;
264                                 close $a;
265                                 unless ($main::is_win) {
266                                         #                                               $SIG{HUP} = 'IGNORE';
267                                         $SIG{HUP} = $SIG{CHLD} = $SIG{TERM} = $SIG{INT} = 'DEFAULT';
268                                         alarm(0);
269                                 }
270                                 exec "$line" or dbg("exec '$line' failed $!");
271                         } 
272                 } else {
273                         dbg("cannot fork for $line");
274                 }
275         } else {
276                 dbg("no socket pair $! for $line");
277         }
278         return $pid;
279 }
280
281 sub disconnect 
282 {
283     my $conn = shift;
284         return if exists $conn->{disconnecting};
285
286         $conn->{disconnecting} = 1;
287     my $sock = delete $conn->{sock};
288         $conn->{state} = 'E';
289         $conn->{timeout}->del if $conn->{timeout};
290
291         # be careful to delete the correct one
292         my $call;
293         if ($call = $conn->{call}) {
294                 my $ref = $conns{$call};
295                 delete $conns{$call} if $ref && $ref == $conn;
296         }
297         $call ||= 'unallocated';
298         dbg("Connection $conn->{cnum} $call disconnected") if isdbg('connll');
299         
300         # get rid of any references
301         for (keys %$conn) {
302                 if (ref($conn->{$_})) {
303                         delete $conn->{$_};
304                 }
305         }
306
307         if (defined($sock)) {
308                 set_event_handler ($sock, read => undef, write => undef, error => undef);
309                 shutdown($sock, 3);
310                 close($sock);
311         }
312         
313         unless ($main::is_win) {
314                 kill 'TERM', $conn->{pid} if exists $conn->{pid};
315         }
316 }
317
318 sub send_now {
319     my ($conn, $msg) = @_;
320     $conn->enqueue($msg);
321     $conn->_send (1); # 1 ==> flush
322 }
323
324 sub send_later {
325     my ($conn, $msg) = @_;
326     $conn->enqueue($msg);
327     my $sock = $conn->{sock};
328     return unless defined($sock);
329     set_event_handler ($sock, write => sub {$conn->_send(0)});
330 }
331
332 sub enqueue {
333     my $conn = shift;
334     push (@{$conn->{outqueue}}, defined $_[0] ? $_[0] : '');
335 }
336
337 sub _send {
338     my ($conn, $flush) = @_;
339     my $sock = $conn->{sock};
340     return unless defined($sock);
341     my $rq = $conn->{outqueue};
342
343     # If $flush is set, set the socket to blocking, and send all
344     # messages in the queue - return only if there's an error
345     # If $flush is 0 (deferred mode) make the socket non-blocking, and
346     # return to the event loop only after every message, or if it
347     # is likely to block in the middle of a message.
348
349         if ($conn->{blocking} != $flush) {
350                 blocking($sock, $flush);
351                 $conn->{blocking} = $flush;
352         }
353     my $offset = (exists $conn->{send_offset}) ? $conn->{send_offset} : 0;
354
355     while (@$rq) {
356         my $msg            = $rq->[0];
357                 my $mlth           = length($msg);
358         my $bytes_to_write = $mlth - $offset;
359         my $bytes_written  = 0;
360                 confess("Negative Length! msg: '$msg' lth: $mlth offset: $offset") if $bytes_to_write < 0;
361         while ($bytes_to_write > 0) {
362             $bytes_written = syswrite ($sock, $msg,
363                                        $bytes_to_write, $offset);
364             if (!defined($bytes_written)) {
365                 if (_err_will_block($!)) {
366                     # Should happen only in deferred mode. Record how
367                     # much we have already sent.
368                     $conn->{send_offset} = $offset;
369                     # Event handler should already be set, so we will
370                     # be called back eventually, and will resume sending
371                     return 1;
372                 } else {    # Uh, oh
373                                         &{$conn->{eproc}}($conn, $!) if exists $conn->{eproc};
374                                         $conn->disconnect;
375                     return 0; # fail. Message remains in queue ..
376                 }
377             } elsif (isdbg('raw')) {
378                                 my $call = $conn->{call} || 'none';
379                                 dbgdump('raw', "$call send $bytes_written: ", $msg);
380                         }
381                         $total_out      += $bytes_written;
382             $offset         += $bytes_written;
383             $bytes_to_write -= $bytes_written;
384         }
385         delete $conn->{send_offset};
386         $offset = 0;
387         shift @$rq;
388         #last unless $flush; # Go back to select and wait
389                             # for it to fire again.
390     }
391     # Call me back if queue has not been drained.
392     unless (@$rq) {
393         set_event_handler ($sock, write => undef);
394                 if (exists $conn->{close_on_empty}) {
395                         &{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
396                         $conn->disconnect; 
397                 }
398     }
399     1;  # Success
400 }
401
402 sub dup_sock
403 {
404         my $conn = shift;
405         my $oldsock = $conn->{sock};
406         my $rc = $rd_callbacks{$oldsock};
407         my $wc = $wt_callbacks{$oldsock};
408         my $ec = $er_callbacks{$oldsock};
409         my $sock = $oldsock->new_from_fd($oldsock, "w+");
410         if ($sock) {
411                 set_event_handler($oldsock, read=>undef, write=>undef, error=>undef);
412                 $conn->{sock} = $sock;
413                 set_event_handler($sock, read=>$rc, write=>$wc, error=>$ec);
414                 $oldsock->close;
415         }
416 }
417
418 sub _err_will_block {
419         return 0 unless $blocking_supported;
420         return ($_[0] == $eagain || $_[0] == $ewouldblock || $_[0] == $einprogress);
421 }
422
423 sub close_on_empty
424 {
425         my $conn = shift;
426         $conn->{close_on_empty} = 1;
427 }
428
429 #-----------------------------------------------------------------
430 # Receive side routines
431
432 sub new_server {
433     @_ == 4 || die "Msg->new_server (myhost, myport, login_proc\n";
434     my ($pkg, $my_host, $my_port, $login_proc) = @_;
435         my $self = $pkg->new($login_proc);
436         
437     $self->{sock} = IO::Socket::INET->new (
438                                           LocalAddr => "$my_host:$my_port",
439 #                                          LocalPort => $my_port,
440                                           Listen    => SOMAXCONN,
441                                           Proto     => 'tcp',
442                                           Reuse => 1);
443     die "Could not create socket: $! \n" unless $self->{sock};
444     set_event_handler ($self->{sock}, read => sub { $self->new_client }  );
445         return $self;
446 }
447
448
449 sub nolinger
450 {
451         my $conn = shift;
452
453         unless ($main::is_win) {
454                 if (isdbg('sock')) {
455                         my ($l, $t) = unpack "ll", getsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER); 
456                         my $k = unpack 'l', getsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE);
457                         my $n = $main::is_win ? 0 : unpack "l", getsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY);
458                         dbg("Linger is: $l $t, keepalive: $k, nagle: $n");
459                 }
460                 
461                 eval {setsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE, 1)} or dbg("setsockopt keepalive: $!");
462                 eval {setsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER, pack("ll", 0, 0))} or dbg("setsockopt linger: $!");
463                 eval {setsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY, 1)} or eval {setsockopt($conn->{sock}, SOL_SOCKET, TCP_NODELAY, 1)} or dbg("setsockopt tcp_nodelay: $!");
464                 $conn->{sock}->autoflush(0);
465
466                 if (isdbg('sock')) {
467                         my ($l, $t) = unpack "ll", getsockopt($conn->{sock}, SOL_SOCKET, SO_LINGER); 
468                         my $k = unpack 'l', getsockopt($conn->{sock}, SOL_SOCKET, SO_KEEPALIVE);
469                         my $n = $main::is_win ? 0 : unpack "l", getsockopt($conn->{sock}, IPPROTO_TCP, TCP_NODELAY);
470                         dbg("Linger is: $l $t, keepalive: $k, nagle: $n");
471                 }
472         } 
473 }
474
475 sub dequeue
476 {
477         my $conn = shift;
478
479         if ($conn->{msg} =~ /\n/) {
480                 my @lines = split /\r?\n/, $conn->{msg};
481                 if ($conn->{msg} =~ /\n$/) {
482                         delete $conn->{msg};
483                 } else {
484                         $conn->{msg} = pop @lines;
485                 }
486                 for (@lines) {
487                         &{$conn->{rproc}}($conn, defined $_ ? $_ : '');
488                 }
489         }
490 }
491
492 sub _rcv {                     # Complement to _send
493     my $conn = shift; # $rcv_now complement of $flush
494     # Find out how much has already been received, if at all
495     my ($msg, $offset, $bytes_to_read, $bytes_read);
496     my $sock = $conn->{sock};
497     return unless defined($sock);
498
499         my @lines;
500         if ($conn->{blocking}) {
501                 blocking($sock, 0);
502                 $conn->{blocking} = 0;
503         }
504         $bytes_read = sysread ($sock, $msg, 1024, 0);
505         if (defined ($bytes_read)) {
506                 if ($bytes_read > 0) {
507                         $total_in += $bytes_read;
508                         if (isdbg('raw')) {
509                                 my $call = $conn->{call} || 'none';
510                                 dbgdump('raw', "$call read $bytes_read: ", $msg);
511                         }
512                         if ($conn->{echo}) {
513                                 my @ch = split //, $msg;
514                                 my $out;
515                                 for (@ch) {
516                                         if (/[\cH\x7f]/) {
517                                                 $out .= "\cH \cH";
518                                                 $conn->{msg} =~ s/.$//;
519                                         } else {
520                                                 $out .= $_;
521                                                 $conn->{msg} .= $_;
522                                         }
523                                 }
524                                 if (defined $out) {
525                                         set_event_handler ($sock, write => sub{$conn->_send(0)});
526                                         push @{$conn->{outqueue}}, $out;
527                                 }
528                         } else {
529                                 $conn->{msg} .= $msg;
530                         }
531                 } 
532         } else {
533                 if (_err_will_block($!)) {
534                         return ; 
535                 } else {
536                         $bytes_read = 0;
537                 }
538     }
539
540 FINISH:
541     if (defined $bytes_read && $bytes_read == 0) {
542                 &{$conn->{eproc}}($conn, $!) if exists $conn->{eproc};
543                 $conn->disconnect;
544     } else {
545                 unless ($conn->{disable_read}) {
546                         $conn->dequeue if exists $conn->{msg};
547                 }
548         }
549 }
550
551 sub new_client {
552         my $server_conn = shift;
553     my $sock = $server_conn->{sock}->accept();
554         if ($sock) {
555                 my $conn = $server_conn->new($server_conn->{rproc});
556                 $conn->{sock} = $sock;
557                 blocking($sock, 0);
558                 $conn->nolinger;
559                 $conn->{blocking} = 0;
560                 my ($rproc, $eproc) = &{$server_conn->{rproc}} ($conn, $conn->{peerhost} = $sock->peerhost(), $conn->{peerport} = $sock->peerport());
561                 $conn->{sort} = 'Incoming';
562                 if ($eproc) {
563                         $conn->{eproc} = $eproc;
564                         set_event_handler ($sock, error => $eproc);
565                 }
566                 if ($rproc) {
567                         $conn->{rproc} = $rproc;
568                         my $callback = sub {$conn->_rcv};
569                         set_event_handler ($sock, read => $callback);
570                 } else {  # Login failed
571                         &{$conn->{eproc}}($conn, undef) if exists $conn->{eproc};
572                         $conn->disconnect();
573                 }
574         } else {
575                 dbg("Msg: error on accept ($!)") if isdbg('err');
576         }
577 }
578
579 sub close_server
580 {
581         my $conn = shift;
582         set_event_handler ($conn->{sock}, read => undef, write => undef, error => undef );
583         $conn->{sock}->close;
584 }
585
586 # close all clients (this is for forking really)
587 sub close_all_clients
588 {
589         foreach my $conn (values %conns) {
590                 $conn->disconnect;
591         }
592 }
593
594 sub disable_read
595 {
596         my $conn = shift;
597         set_event_handler ($conn->{sock}, read => undef);
598         return $_[0] ? $conn->{disable_read} = $_[0] : $_[0];
599 }
600
601 #
602 #----------------------------------------------------
603 # Event loop routines used by both client and server
604
605 sub set_event_handler {
606     shift unless ref($_[0]); # shift if first arg is package name
607     my ($handle, %args) = @_;
608     my $callback;
609     if (exists $args{'write'}) {
610         $callback = $args{'write'};
611         if ($callback) {
612             $wt_callbacks{$handle} = $callback;
613             $wt_handles->add($handle);
614         } else {
615             delete $wt_callbacks{$handle};
616             $wt_handles->remove($handle);
617         }
618     }
619     if (exists $args{'read'}) {
620         $callback = $args{'read'};
621         if ($callback) {
622             $rd_callbacks{$handle} = $callback;
623             $rd_handles->add($handle);
624         } else {
625             delete $rd_callbacks{$handle};
626             $rd_handles->remove($handle);
627        }
628     }
629     if (exists $args{'error'}) {
630         $callback = $args{'error'};
631         if ($callback) {
632             $er_callbacks{$handle} = $callback;
633             $er_handles->add($handle);
634         } else {
635             delete $er_callbacks{$handle};
636             $er_handles->remove($handle);
637        }
638     }
639 }
640
641 sub event_loop {
642     my ($pkg, $loop_count, $timeout, $wronly) = @_; # event_loop(1) to process events once
643     my ($conn, $r, $w, $e, $rset, $wset, $eset);
644     while (1) {
645  
646        # Quit the loop if no handles left to process
647                 if ($wronly) {
648                         last unless $wt_handles->count();
649         
650                         ($rset, $wset, $eset) = IO::Select->select(undef, $wt_handles, undef, $timeout);
651                         
652                         foreach $w (@$wset) {
653                                 &{$wt_callbacks{$w}}($w) if exists $wt_callbacks{$w};
654                         }
655                 } else {
656                         
657                         last unless ($rd_handles->count() || $wt_handles->count());
658         
659                         ($rset, $wset, $eset) = IO::Select->select($rd_handles, $wt_handles, $er_handles, $timeout);
660                         
661                         foreach $e (@$eset) {
662                                 &{$er_callbacks{$e}}($e) if exists $er_callbacks{$e};
663                         }
664                         foreach $r (@$rset) {
665                                 &{$rd_callbacks{$r}}($r) if exists $rd_callbacks{$r};
666                         }
667                         foreach $w (@$wset) {
668                                 &{$wt_callbacks{$w}}($w) if exists $wt_callbacks{$w};
669                         }
670                 }
671
672                 Timer::handler;
673                 
674         if (defined($loop_count)) {
675             last unless --$loop_count;
676         }
677     }
678 }
679
680 sub sleep
681 {
682         my ($pkg, $interval) = @_;
683         my $now = time;
684         while (time - $now < $interval) {
685                 $pkg->event_loop(10, 0.01);
686         }
687 }
688
689 sub DESTROY
690 {
691         my $conn = shift;
692         my $call = $conn->{call} || 'unallocated';
693         my $host = $conn->{peerhost} || '';
694         my $port = $conn->{peerport} || '';
695         dbg("Connection $conn->{cnum} $call [$host $port] being destroyed") if isdbg('connll');
696         $noconns--;
697 }
698
699 1;
700
701 __END__
702