home *** CD-ROM | disk | FTP | other *** search
/ Internet 1996 World Exposition / park.org.s3.amazonaws.com.7z / park.org.s3.amazonaws.com / cgi-bin / Japan / WIDE / chat2.pl < prev    next >
Perl Script  |  2017-09-21  |  11KB  |  411 lines
  1. # chat.pl: chat with a server
  2. # Based on: V2.01.alpha.7 91/06/16
  3. # Randal L. Schwartz (was <merlyn@iwarp.intel.com>)
  4. # multihome additions by A.Macpherson@bnr.co.uk
  5. # allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
  6. # $Id: chat2.pl,v 2.2 1993/12/14 11:09:03 lmjm Exp lmjm $
  7. # $Log: chat2.pl,v $
  8. # Revision 2.2  1993/12/14  11:09:03  lmjm
  9. # Only include sys/socket.ph if not already there.
  10. # Allow for system 5.
  11. #
  12. # Revision 2.1  1993/06/28  15:11:07  lmjm
  13. # Full 2.1 release
  14. #
  15.  
  16. package chat;
  17.  
  18. unless( defined &'PF_INET ){
  19.     eval "sub ATT { 0; } sub INTEL { 0; }";
  20.     do 'sys/socket.ph';
  21. }
  22.  
  23.  
  24. if( defined( &main'PF_INET ) ){
  25.     $pf_inet = &main'PF_INET;
  26.     $sock_stream = &main'SOCK_STREAM;
  27.     local($name, $aliases, $proto) = getprotobyname( 'tcp' );
  28.     $tcp_proto = $proto;
  29. }
  30. else {
  31.     # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
  32.     # but who the heck would change these anyway? (:-)
  33.     $pf_inet = 2;
  34.     $sock_stream = 1;
  35.     $tcp_proto = 6;
  36. }
  37.  
  38.  
  39. $sockaddr = 'S n a4 x8';
  40. chop( $thishost = `(hostname || uname -n || uuname -l) 2>/dev/null` );
  41.  
  42. # *S = symbol for current I/O, gets assigned *chatsymbol....
  43. $next = "chatsymbol000000"; # next one
  44. $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
  45.  
  46.  
  47. ## $handle = &chat'open_port("server.address",$port_number);
  48. ## opens a named or numbered TCP server
  49.  
  50. sub open_port { ## public
  51.     local($server, $port) = @_;
  52.  
  53.     local($serveraddr,$serverproc);
  54.  
  55.     # We may be multi-homed, start with 0, fixup once connexion is made
  56.     $thisaddr = "\0\0\0\0" ;
  57.     $thisproc = pack($sockaddr, 2, 0, $thisaddr);
  58.  
  59.     *S = ++$next;
  60.     if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
  61.         $serveraddr = pack('C4', $1, $2, $3, $4);
  62.     } else {
  63.         local(@x) = gethostbyname($server);
  64.         return undef unless @x;
  65.         $serveraddr = $x[4];
  66.     }
  67.     $serverproc = pack($sockaddr, 2, $port, $serveraddr);
  68.     unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
  69.         ($!) = ($!, close(S)); # close S while saving $!
  70.         return undef;
  71.     }
  72.     unless (bind(S, $thisproc)) {
  73.         ($!) = ($!, close(S)); # close S while saving $!
  74.         return undef;
  75.     }
  76.     unless (connect(S, $serverproc)) {
  77.         ($!) = ($!, close(S)); # close S while saving $!
  78.         return undef;
  79.     }
  80. # We opened with the local address set to ANY, at this stage we know
  81. # which interface we are using.  This is critical if our machine is
  82. # multi-homed, with IP forwarding off, so fix-up.
  83.     local($fam,$lport);
  84.     ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
  85.     $thisproc = pack($sockaddr, 2, 0, $thisaddr);
  86. # end of post-connect fixup
  87.     select((select(S), $| = 1)[0]);
  88.     $next; # return symbol for switcharound
  89. }
  90.  
  91. ## ($host, $port, $handle) = &chat'open_listen([$port_number]);
  92. ## opens a TCP port on the current machine, ready to be listened to
  93. ## if $port_number is absent or zero, pick a default port number
  94. ## process must be uid 0 to listen to a low port number
  95.  
  96. sub open_listen { ## public
  97.  
  98.     *S = ++$next;
  99.     local($thisport) = shift || 0;
  100.     local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
  101.     local(*NS) = "__" . time;
  102.     unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) {
  103.         ($!) = ($!, close(NS));
  104.         return undef;
  105.     }
  106.     unless (bind(NS, $thisproc_local)) {
  107.         ($!) = ($!, close(NS));
  108.         return undef;
  109.     }
  110.     unless (listen(NS, 1)) {
  111.         ($!) = ($!, close(NS));
  112.         return undef;
  113.     }
  114.     select((select(NS), $| = 1)[0]);
  115.     local($family, $port, @myaddr) =
  116.         unpack("S n C C C C x8", getsockname(NS));
  117.     $S{"needs_accept"} = *NS; # so expect will open it
  118.     (@myaddr, $port, $next); # returning this
  119. }
  120.  
  121. ## $handle = &chat'open_proc("command","arg1","arg2",...);
  122. ## opens a /bin/sh on a pseudo-tty
  123.  
  124. sub open_proc { ## public
  125.     local(@cmd) = @_;
  126.  
  127.     *S = ++$next;
  128.     local(*TTY) = "__TTY" . time;
  129.     local($pty,$tty) = &_getpty(S,TTY);
  130.     die "Cannot find a new pty" unless defined $pty;
  131.     $pid = fork;
  132.     die "Cannot fork: $!" unless defined $pid;
  133.     unless ($pid) {
  134.         close STDIN; close STDOUT; close STDERR;
  135.         setpgrp(0,$$);
  136.         if (open(DEVTTY, "/dev/tty")) {
  137.             ioctl(DEVTTY,0x20007471,0);        # XXX s/b &TIOCNOTTY
  138.             close DEVTTY;
  139.         }
  140.         open(STDIN,"<&TTY");
  141.         open(STDOUT,">&TTY");
  142.         open(STDERR,">&STDOUT");
  143.         die "Oops" unless fileno(STDERR) == 2;    # sanity
  144.         close(S);
  145.         exec @cmd;
  146.         die "Cannot exec @cmd: $!";
  147.     }
  148.     close(TTY);
  149.     $next; # return symbol for switcharound
  150. }
  151.  
  152. # &chat'read([$handle,] $buf, $ntoread )
  153. # blocking read. returns no. of bytes read and puts data in $buf.
  154. # If called with ntoread < 0 then just do the accept and return 0.
  155. sub read { ## public
  156.     if ($_[0] =~ /$nextpat/) {
  157.         *S = shift;
  158.     }
  159.     *chatreadbuf = shift;
  160.     $chatreadn = shift;
  161.     
  162.     if (defined $S{"needs_accept"}) { # is it a listen socket?
  163.         local(*NS) = $S{"needs_accept"};
  164.         delete $S{"needs_accept"};
  165.         $S{"needs_close"} = *NS;
  166.         unless(accept(S,NS)) {
  167.             ($!) = ($!, close(S), close(NS));
  168.             return undef;
  169.         }
  170.         select((select(S), $| = 1)[0]);
  171.     }
  172.     if( $chatreadn > 0 ){
  173.         return sysread(S, $chatreadbuf, $chatreadn );
  174.     }
  175. }
  176.  
  177. # $S is the read-ahead buffer
  178.  
  179. ## $return = &chat'expect([$handle,] $timeout_time,
  180. ##     $pat1, $body1, $pat2, $body2, ... )
  181. ## $handle is from previous &chat'open_*().
  182. ## $timeout_time is the time (either relative to the current time, or
  183. ## absolute, ala time(2)) at which a timeout event occurs.
  184. ## $pat1, $pat2, and so on are regexs which are matched against the input
  185. ## stream.  If a match is found, the entire matched string is consumed,
  186. ## and the corresponding body eval string is evaled.
  187. ##
  188. ## Each pat is a regular-expression (probably enclosed in single-quotes
  189. ## in the invocation).  ^ and $ will work, respecting the current value of $*.
  190. ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
  191. ## If pat is 'EOF', the body is executed if the process exits before
  192. ## the other patterns are seen.
  193. ##
  194. ## Pats are scanned in the order given, so later pats can contain
  195. ## general defaults that won't be examined unless the earlier pats
  196. ## have failed.
  197. ##
  198. ## The result of eval'ing body is returned as the result of
  199. ## the invocation.  Recursive invocations are not thought
  200. ## through, and may work only accidentally. :-)
  201. ##
  202. ## undef is returned if either a timeout or an eof occurs and no
  203. ## corresponding body has been defined.
  204. ## I/O errors of any sort are treated as eof.
  205.  
  206. $nextsubname = "expectloop000000"; # used for subroutines
  207.  
  208. sub expect { ## public
  209.     if ($_[0] =~ /$nextpat/) {
  210.         *S = shift;
  211.     }
  212.     local($endtime) = shift;
  213.  
  214.     local($timeout,$eof) = (1,1);
  215.     local($caller) = caller;
  216.     local($rmask, $nfound, $timeleft, $thisbuf);
  217.     local($cases, $pattern, $action, $subname);
  218.     $endtime += time if $endtime < 600_000_000;
  219.  
  220.     if (defined $S{"needs_accept"}) { # is it a listen socket?
  221.         local(*NS) = $S{"needs_accept"};
  222.         delete $S{"needs_accept"};
  223.         $S{"needs_close"} = *NS;
  224.         unless(accept(S,NS)) {
  225.             ($!) = ($!, close(S), close(NS));
  226.             return undef;
  227.         }
  228.         select((select(S), $| = 1)[0]);
  229.     }
  230.  
  231.     # now see whether we need to create a new sub:
  232.  
  233.     unless ($subname = $expect_subname{$caller,@_}) {
  234.         # nope.  make a new one:
  235.         $expect_subname{$caller,@_} = $subname = $nextsubname++;
  236.  
  237.         $cases .= <<"EDQ"; # header is funny to make everything elsif's
  238. sub $subname {
  239.     LOOP: {
  240.         if (0) { ; }
  241. EDQ
  242.         while (@_) {
  243.             ($pattern,$action) = splice(@_,0,2);
  244.             if ($pattern =~ /^eof$/i) {
  245.                 $cases .= <<"EDQ";
  246.         elsif (\$eof) {
  247.              package $caller;
  248.             $action;
  249.         }
  250. EDQ
  251.                 $eof = 0;
  252.             } elsif ($pattern =~ /^timeout$/i) {
  253.             $cases .= <<"EDQ";
  254.         elsif (\$timeout) {
  255.              package $caller;
  256.             $action;
  257.         }
  258. EDQ
  259.                 $timeout = 0;
  260.             } else {
  261.                 $pattern =~ s#/#\\/#g;
  262.             $cases .= <<"EDQ";
  263.         elsif (\$S =~ /$pattern/) {
  264.             \$S = \$';
  265.              package $caller;
  266.             $action;
  267.         }
  268. EDQ
  269.             }
  270.         }
  271.         $cases .= <<"EDQ" if $eof;
  272.         elsif (\$eof) {
  273.             undef;
  274.         }
  275. EDQ
  276.         $cases .= <<"EDQ" if $timeout;
  277.         elsif (\$timeout) {
  278.             undef;
  279.         }
  280. EDQ
  281.         $cases .= <<'ESQ';
  282.         else {
  283.             $rmask = "";
  284.             vec($rmask,fileno(S),1) = 1;
  285.             ($nfound, $rmask) =
  286.                  select($rmask, undef, undef, $endtime - time);
  287.             if ($nfound) {
  288.                 $nread = sysread(S, $thisbuf, 1024);
  289.                 if( $chat'debug ){
  290.                     print STDERR "sysread $nread ";
  291.                     print STDERR ">>$thisbuf<<\n";
  292.                 }
  293.                 if ($nread > 0) {
  294.                     $S .= $thisbuf;
  295.                 } else {
  296.                     $eof++, redo LOOP; # any error is also eof
  297.                 }
  298.             } else {
  299.                 $timeout++, redo LOOP; # timeout
  300.             }
  301.             redo LOOP;
  302.         }
  303.     }
  304. }
  305. ESQ
  306.         eval $cases; die "$cases:\n$@" if $@;
  307.     }
  308.     $eof = $timeout = 0;
  309.     do $subname();
  310. }
  311.  
  312. ## &chat'print([$handle,] @data)
  313. ## $handle is from previous &chat'open().
  314. ## like print $handle @data
  315.  
  316. sub print { ## public
  317.     if ($_[0] =~ /$nextpat/) {
  318.         *S = shift;
  319.     }
  320.     print S @_;
  321.     if( $chat'debug ){
  322.         print STDERR "printed:";
  323.         print STDERR @_;
  324.     }
  325. }
  326.  
  327. ## &chat'close([$handle,])
  328. ## $handle is from previous &chat'open().
  329. ## like close $handle
  330.  
  331. sub close { ## public
  332.     if ($_[0] =~ /$nextpat/) {
  333.          *S = shift;
  334.     }
  335.     close(S);
  336.     if (defined $S{"needs_close"}) { # is it a listen socket?
  337.         local(*NS) = $S{"needs_close"};
  338.         delete $S{"needs_close"};
  339.         close(NS);
  340.     }
  341. }
  342.  
  343. ## @ready_handles = &chat'select($timeout, @handles)
  344. ## select()'s the handles with a timeout value of $timeout seconds.
  345. ## Returns an array of handles that are ready for I/O.
  346. ## Both user handles and chat handles are supported (but beware of
  347. ## stdio's buffering for user handles).
  348.  
  349. sub select { ## public
  350.     local($timeout) = shift;
  351.     local(@handles) = @_;
  352.     local(%handlename) = ();
  353.     local(%ready) = ();
  354.     local($caller) = caller;
  355.     local($rmask) = "";
  356.     for (@handles) {
  357.         if (/$nextpat/o) { # one of ours... see if ready
  358.             local(*SYM) = $_;
  359.             if (length($SYM)) {
  360.                 $timeout = 0; # we have a winner
  361.                 $ready{$_}++;
  362.             }
  363.             $handlename{fileno($_)} = $_;
  364.         } else {
  365.             $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
  366.         }
  367.     }
  368.     for (sort keys %handlename) {
  369.         vec($rmask, $_, 1) = 1;
  370.     }
  371.     select($rmask, undef, undef, $timeout);
  372.     for (sort keys %handlename) {
  373.         $ready{$handlename{$_}}++ if vec($rmask,$_,1);
  374.     }
  375.     sort keys %ready;
  376. }
  377.  
  378. # ($pty,$tty) = $chat'_getpty(PTY,TTY):
  379. # internal procedure to get the next available pty.
  380. # opens pty on handle PTY, and matching tty on handle TTY.
  381. # returns undef if can't find a pty.
  382. # Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.
  383.  
  384. sub _getpty { ## private
  385.     local($_PTY,$_TTY) = @_;
  386.     $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
  387.     $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
  388.     local($pty, $tty, $kind);
  389.     if( -e "/dev/pts000" ){        ## mods by Joe Doupnik Dec 1992
  390.         $kind = "pts";        ## SVR4 Streams
  391.     } else {
  392.         $kind = "pty";        ## BSD Clist stuff
  393.     }
  394.     for $bank (112..127) {
  395.         next unless -e sprintf("/dev/$kind%c0", $bank);
  396.         for $unit (48..57) {
  397.             $pty = sprintf("/dev/$kind%c%c", $bank, $unit);
  398.             open($_PTY,"+>$pty") || next;
  399.             select((select($_PTY), $| = 1)[0]);
  400.             ($tty = $pty) =~ s/pty/tty/;
  401.             open($_TTY,"+>$tty") || next;
  402.             select((select($_TTY), $| = 1)[0]);
  403.             system "stty nl>$tty";
  404.             return ($pty,$tty);
  405.         }
  406.     }
  407.     undef;
  408. }
  409.  
  410. 1;
  411.