(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(filecreated "20-Sep-88 20:44:51" {erinyes}<lispusers>medley>simplechat.\;2
 12467  

      |changes| |to:|  (fns ttychat)

      |previous| |date:| "30-Oct-87 16:20:30" {erinyes}<lispusers>medley>simplechat.\;1)


; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.

(prettycomprint simplechatcoms)

(rpaqq simplechatcoms
 ((fns ttychat ttychat.eosop ttychat.login ttychat.typeout ttychat.close)
                           (vars (ttychat.ttbl nil))
                           (declare\: donteval@load doeval@compile dontcopy compilervars
                                  (addvars (nlama)
                                         (nlaml)
                                         (lama ttychat)))))
(defineq

(ttychat

  (cl:lambda
   (&optional host logoption)
                        (* \; "Edited 20-Sep-88 20:44 by masinter")

   (prog (connection streams openfn result)
         (or host (setq host defaultchathost))
         (cond
            ((not (or host (setq host (promptforword "
Host: " nil "Enter name of host to chat to, or <cr> to abort" nil nil nil (charcode (cr))))))
             (return nil)))
         (cond
            ((not (setq openfn (find.chat.protocol host)))   (* \; 

                                                           "Don't know how to talk to this host")

             (return (concat "Unknown Chat host: " host)))
            ((not (setq streams (apply* (progn (setq host (car openfn))
                                                             (* \; 

                                                    "Value returned was (CanonicalHostName OpenFn)")

                                               (cadr openfn))
                                       host)))
             (return "Failed"))
            (t (let* ((instream (car streams))
                      (outstream (cdr streams)))
                     (streamprop instream 'oldeosop (|fetch|
 endofstreamop |of|
 instream))
                     (|replace|
 endofstreamop |of|
 instream |with|
 (function 
                                                                                ttychat.eosop))
                     (cond
                        ((not (fmemb host chat.allhosts))
                         (setq chat.allhosts (cons host chat.allhosts))
                         (setq chat.hostmenu)))
                     (let (typeout (key (|fetch|
 (linebuffer keyboardstream) |of|
 
                                                                                       \\linebuf.ofd)
                                        )
                                 ch
                                 (state (list ':binary))
                                 (okey \\currentkeyaction)
                                 (nkey nil))
                          (cl:unwind-protect
                              (progn (cond
                                        ((eq key \\keyboard.stream)
                                         (setq \\currentkeyaction
                                          (setq nkey (let ((keyaction (keyactiontable 
                                                                             \\defaultkeyaction)))
                                                          (|for|
 pair |in|
 (currentinterrupts
                                                                                    keyaction)
                                                             |when|
 (leq (car pair)
                                                                             255)
                                                             |do|
 (intchar (car pair)
                                                                             nil nil keyaction))
                                                             (* \; 

                                                           " turn off all interrupts in charset 0")

                                                          (|for|
 pair |in|
 chat.interrupts
                                                             |do|
 (intchar (car pair)
                                                                             nil nil keyaction))
                                                          (|for|
 pair |in|
 chat.keyactions
                                                             |do|
 (keyaction (car pair)
                                                                             (cdr pair)
                                                                             keyaction))
                                                          keyaction)))))
                                     (printout t "[Connected to " host ", type ^] to escape]" t)
                                     (setq typeout
                                      (add.process `(ttychat.typeout

                                                     ',instream
                                                     ',(getstream t 'output)
                                                     ',state
                                                     ',(this.process))
                                             'name
                                             'chat.typeout))
                                     (and (neq logoption 'none)
                                          (ttychat.login
 instream outstream host logoption))
                                     (prog nil
                                       wait-for-typein
                                           (cond
                                              ((null (car state))
                                               (return nil)))
                                           (cond
                                              ((not (readp key))
                                               (go wait)))
                                       got-char
                                           (setq ch (bin key))
                                           (cond
                                              ((eq ch chat.controlchar)
                                               (setq ch (logand (bin key)
                                                               31)))
                                              ((eq ch chat.metachar)
                                               (setq ch (logor (bin key)
                                                               128)))
                                              ((eq ch (charcode "^]"))
                                               (forceoutput outstream)
                                               (selectq (askuser nil nil "Chat command:"
                                                               '((b . "inary")
                                                                 (t . "ext")
                                                                 (c . "lose")
                                                                 (" ")))
                                                   (b (rplaca state ':binary))
                                                   (t (rplaca state ':terminal))
                                                   (c (return nil))
                                                   nil)
                                               (terpri t)
                                               (go no-char))
                                              ((igeq ch \\maxthinchar)
                                               (cond
                                                  ((eq (lrsh ch 8)
                                                       1)
                                                   (setq ch (logor 128 (logand ch 127))))
                                                  (t (ringbells)
                                                     (go no-char)))))
                                           (bout outstream ch)
                                           (cond
                                              ((readp key)
                                               (go got-char)))
                                       no-char
                                           (cond
                                              ((null (car state))

                                               (* |;;| 

                                           "check here 'cause the other process might have aborted")


                                               (return nil)))
                                           (forceoutput outstream)
                                       wait
                                           (cond
                                              ((null (car state))
                                               (return nil)))
                                           (waitforinput 1000)
                                           (go wait-for-typein)))

                              (* |;;| "here be unwind protect clauses ")


                              (cond
                                 ((eq \\currentkeyaction nkey)
                                  (setq \\currentkeyaction okey)))
                              (add.process `(ttychat.close
 ',typeout ',instream
                                                   ',outstream)))))
               (return host))))))

(ttychat.eosop

(lambda (stream) (* \; "Edited 30-Oct-87 13:32 by Masinter") (* |;;;| "Return -1 to indicate EOS to CHAT, and restore the streams EOS op incase it's needed for other things.") (|replace| endofstreamop |of| stream |with| (or (streamprop stream (quote eosop)) (function \\eoserror))) -1)
)

(ttychat.login

(lambda (instream outstream host option) (* \; "Edited 30-Oct-87 13:47 by Masinter") (prog ((ostype (getostype host)) (loginfo (gethostinfo host (quote loginfo))) name/pass com) (or loginfo (return)) (setq name/pass (\\internal/getpassword host nil nil nil nil ostype)) (setq com (cond (option) ((assoc (quote attach) loginfo) (or (chat.loginfo instream host (car name/pass)) (quote login))) (t (* \; "Don't know how to do anything but login, so silly to try anything else") (quote login)))) (cond ((null (setq loginfo (assoc com loginfo))) (|printout| promptwindow t "Login option " com " not implemented for this type of host")) (t (|for| x |in| (cdr loginfo) |do| (selectq x (cr (bout outstream (charcode cr)) (forceoutput outstream)) (lf (bout outstream (charcode lf)) (forceoutput outstream)) (username (prin3 (car name/pass) outstream)) (password (prin3 (\\decrypt.pwd (cdr name/pass)) outstream)) (wait (* \; "Some systems do not permit typeahead") (cond ((not (chat.flush&wait instream)) (* \; "Couldn't sync, so wait longer.") (dismiss chat.wait.time))) (dismiss chat.wait.time)) (prin3 x outstream))) (forceoutput outstream)))))
)

(ttychat.typeout

(lambda (instream terminal state proc) (* \; "Edited 30-Oct-87 16:19 by masinter") (settermtable (or ttychat.ttbl (setq ttychat.ttbl (let ((tt (copytermtable (quote orig)))) (|for| i |from| 0 |to| 31 |do| (echochar i (quote real) tt)) (echochar (charcode lf) (quote ignore) tt) tt)))) (let (msg ch last-char space-width) (or (equal (charwidth (charcode "i") terminal) (charwidth (charcode "W") terminal)) (dspfont defaultfont terminal)) (setq space-width (charwidth (charcode space) terminal)) (|while| (igeq (setq ch (bin instream)) 0) |do| (* \; "Print any protocol related msgs that might have come along while we where asleep") (if (eq (car state) (quote :binary)) then (bout terminal ch) else (selcharq ch (lf (|if| (eq last-char (charcode cr)) |then| (* \; " ignore ") nil)) (^h (dspbackup space-width terminal)) (progn (setq last-char ch) (bout terminal ch)))))) (printout terminal "[Connection closed remotely]" t) (rplaca state nil) (* \; "tell other process we aborted") (wake.process proc t))
)

(ttychat.close

(lambda (typeout instream outstream) (* \; "Edited 30-Oct-87 14:39 by Masinter") (* |;;;| "Close the streams for a connection if they are open.") (del.process typeout) (cond ((openp instream) (closef instream))) (cond ((openp outstream) (closef outstream))))
)
)

(rpaqq ttychat.ttbl
 nil)
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 )

(addtovar nlaml
 )

(addtovar lama
 ttychat)
)
(putprops simplechat copyright ("Xerox Corporation" 1987 1988))
(declare\: dontcopy
  (filemap (nil (792 12210 (ttychat 802 . 9430) (ttychat.eosop 9432 . 9738) (ttychat.login 9740 . 10899)
 (ttychat.typeout 10901 . 11927) (ttychat.close 11929 . 12208)))))
stop