Return to ipc.cl CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / dist-1.3 / fi

Annotation of 43BSDReno/contrib/emacs-18.55/dist-1.3/fi/ipc.cl, revision 1.1

1.1     ! root        1: ;;                                     -[Mon Nov 28 13:35:34 1988 by layer]-
        !             2: ;;
        !             3: ;; Allegro CL IPC interface
        !             4: ;;
        !             5: ;; copyright (c) 1987, 1988 Franz Inc, Berkeley, Ca.
        !             6: ;;
        !             7: ;; The software, data and information contained herein are proprietary
        !             8: ;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
        !             9: ;; given in confidence by Franz, Inc. pursuant to a written license
        !            10: ;; agreement, and stored only in accordance with the terms of such license.
        !            11: ;;
        !            12: ;; Restricted Rights Legend
        !            13: ;; ------------------------
        !            14: ;; Use, duplication, and disclosure by the Government are subject to
        !            15: ;; restrictions of Restricted Rights for Commercial Software developed
        !            16: ;; at private expense as specified in DOD FAR 52.227-7013 (c) (1) (ii).
        !            17: ;;
        !            18: ;;
        !            19: ;; $Header: ipc.cl,v 1.20 89/02/14 17:14:34 layer Exp $
        !            20: ;; $Locker:  $
        !            21: ;;
        !            22: ;; This code is a preliminary IPC interface for ExCL. The functionality
        !            23: ;; will be extended apace, but right now it only implements a Common Lisp
        !            24: ;; Server.  The server can be started by a CL and it establishes a daemon
        !            25: ;; listening to a socket.  Any process wanting to talk to the lisp
        !            26: ;; can connect to the socket and a new Lisp Listener will be started.
        !            27: 
        !            28: (provide :ipc)
        !            29: 
        !            30: (in-package :ipc :use '(:lisp :excl :ff :mp))
        !            31: 
        !            32: (export '(start-lisp-listener-daemon open-network-stream
        !            33:          *unix-domain* *inet-port*))
        !            34: 
        !            35: (require :process)
        !            36: (require :foreign)
        !            37: (require :cstructs)
        !            38: 
        !            39: (defvar *unix-domain* t
        !            40:   "If non-nil then use a UNIX domain socket, otherwise use an internet
        !            41: domain port (see *inet-port* variable).")
        !            42: 
        !            43: (defparameter *inet-port* 6789
        !            44:   "The internet service port number on which Lisp listens for connections.
        !            45: The value is this variable is only used when *unix-domain* is non-nil, in
        !            46: which case a UNIX domain socket is used.")
        !            47: 
        !            48: (defconstant *af-unix* 1
        !            49:   "The AF_UNIX constant from /usr/include/sys/socket.h.")
        !            50: 
        !            51: (defconstant *af-inet* 2
        !            52:   "The AF_INET constant from /usr/include/sys/socket.h.")
        !            53: 
        !            54: (defconstant *sock-stream* 1
        !            55:   "The SOCK_STREAM constant from /usr/include/sys/socket.h.")
        !            56: 
        !            57: (defvar *junk-name* (make-array 1))
        !            58: (defvar *junk-address* (make-array 1 :element-type '(unsigned-byte 32)))
        !            59: 
        !            60: (defun entry-point-exists-p (string)
        !            61:   (setf (aref *junk-name* 0) string)
        !            62:   (setf (aref *junk-address* 0) 0)
        !            63:   (= 0 (get-entry-points *junk-name* *junk-address*)))
        !            64: 
        !            65: (defvar lisp-listener-daemon-ff-loaded nil)
        !            66: (defvar lisp-listener-daemon nil)
        !            67: 
        !            68: (defparameter *needed-funcs*
        !            69:   (mapcar #'convert-to-lang
        !            70:          '("socket" "bind" "listen" "accept" "getsockname" "gethostbyname"
        !            71:            "connect" "bcopy" "bcmp" "bzero")))
        !            72: 
        !            73: (eval-when (load eval)
        !            74:   (unless lisp-listener-daemon-ff-loaded
        !            75:     (unless (eql (excl::machine-code) '#.comp::machine-code-tek4300)
        !            76:       (unless (or (eq '#.comp::machine-code-apollo (excl::machine-code))
        !            77:                  (dolist (name *needed-funcs* t)
        !            78:                    (if (not (entry-point-exists-p name))
        !            79:                        (return nil))))
        !            80:        (princ ";  Loading from C library...")
        !            81:        (force-output)
        !            82:        (unless (load "" :verbose nil :unreferenced-lib-names *needed-funcs*)
        !            83:          (error "foreign load failed"))
        !            84:        (princ "done")
        !            85:        (terpri)))
        !            86:     (setq lisp-listener-daemon-ff-loaded t)
        !            87:     (defforeign-list '((getuid) (socket) (bind) (accept)
        !            88:                       (getsockname) (gethostbyname) (select)
        !            89:                       (connect) (bcopy) (bzero) (bcmp) (perror)
        !            90:                       (unix-listen :entry-point #,(convert-to-lang "listen"))
        !            91:                       (unix-close :entry-point #,(convert-to-lang "close")))
        !            92:        :print nil)))
        !            93: 
        !            94: (defcstruct sockaddr-in
        !            95:   (family :unsigned-short)
        !            96:   (port :unsigned-short)
        !            97:   (addr :unsigned-long)
        !            98:   (zero 8 :unsigned-byte))
        !            99: 
        !           100: (defcstruct sockaddr-un
        !           101:   (family :unsigned-short)
        !           102:   (path 109 :char))
        !           103: 
        !           104: (defcstruct timeval
        !           105:   (sec :long)
        !           106:   (usec :long))
        !           107: 
        !           108: (defcstruct unsigned-long
        !           109:   (unsigned-long :unsigned-long))
        !           110: 
        !           111: ;; from /usr/include/netdb.h
        !           112: (defcstruct (hostent :malloc)
        !           113:   (name * :char)
        !           114:   (aliases * * :char)
        !           115:   (addrtype :long)
        !           116:   (length :long)
        !           117:   (addr * :char))
        !           118: 
        !           119: (defun start-lisp-listener-daemon ()
        !           120:   "This function starts a process which listens to a socket for attempts to
        !           121: connect, and starts a lisp listener for each connection.  If the Lisp
        !           122: listener ever completes, it makes sure files are closed."
        !           123:   (unless lisp-listener-daemon
        !           124:     (setq lisp-listener-daemon
        !           125:       (process-run-function "TCP Listener Socket Daemon"
        !           126:                            'lisp-listener-socket-daemon))
        !           127:     (setf (getf (process-property-list lisp-listener-daemon) ':no-interrupts)
        !           128:           t)))
        !           129: 
        !           130: (defvar *socket-pathname* nil)
        !           131: 
        !           132: (defun lisp-listener-socket-daemon ()
        !           133:   (let (listen-socket-fd
        !           134:        (listen-sockaddr
        !           135:         (if *unix-domain*
        !           136:             (make-cstruct 'sockaddr-un)
        !           137:           (make-cstruct 'sockaddr-in)))
        !           138:        (timeval (make-cstruct 'timeval))
        !           139:        (mask-obj (make-cstruct 'unsigned-long))
        !           140:        (int (make-cstruct 'unsigned-long))
        !           141:        mask
        !           142:        stream
        !           143:        proc-name
        !           144:        fd)
        !           145:     
        !           146:     (unless *socket-pathname*
        !           147:       (format nil "~a/~a" (sys:getenv "HOME") ".excl_to_emacs"))
        !           148: 
        !           149:     (setf (timeval-sec timeval) 0
        !           150:          (timeval-usec timeval) 0)
        !           151:     (unwind-protect
        !           152:        (progn
        !           153:          (if *unix-domain* (errorset (delete-file *socket-pathname*)))
        !           154:          (setq listen-socket-fd (socket
        !           155:                                  (if *unix-domain* *af-unix* *af-inet*)
        !           156:                                  *sock-stream*
        !           157:                                  0))
        !           158:          (when (< listen-socket-fd 0)
        !           159:            (perror "socket")
        !           160:            (setq listen-socket-fd nil)
        !           161:            (return-from lisp-listener-socket-daemon nil))
        !           162:          (mp::mpwatchfor listen-socket-fd)
        !           163: 
        !           164:          ;; Compute a select mask for the daemon's socket.
        !           165:          (setq mask (ash 1 listen-socket-fd))
        !           166: 
        !           167:          (if* *unix-domain*
        !           168:             then (setf (sockaddr-un-family listen-sockaddr) *af-unix*)
        !           169:                  ;; Set pathname.
        !           170:                  (dotimes (i (length *socket-pathname*)
        !           171:                            (setf (sockaddr-un-path listen-sockaddr i) 0))
        !           172:                    (setf (sockaddr-un-path listen-sockaddr i)
        !           173:                      (char-int (elt *socket-pathname* i))))
        !           174:             else ;; a crock:
        !           175:                  (bzero listen-sockaddr (ff::cstruct-len 'sockaddr-in))
        !           176:                  (setf (sockaddr-in-family listen-sockaddr) *af-inet*
        !           177:                        (sockaddr-in-port listen-sockaddr) *inet-port*))
        !           178:          
        !           179:          (unless (zerop (bind listen-socket-fd
        !           180:                               listen-sockaddr
        !           181:                               (if *unix-domain*
        !           182:                                   (+ (length *socket-pathname*) 2)
        !           183:                                 (ff::cstruct-len 'sockaddr-in))))
        !           184:            (perror "bind")
        !           185:            (return-from lisp-listener-socket-daemon nil))
        !           186: 
        !           187:          (unless (zerop (unix-listen listen-socket-fd 5))
        !           188:            (perror "listen")
        !           189:            (return-from lisp-listener-socket-daemon nil))
        !           190:          (loop
        !           191:           (process-wait "waiting for a connection"
        !           192:                         #'(lambda (mask mask-obj timeout)
        !           193:                             (setf (unsigned-long-unsigned-long mask-obj) mask)
        !           194:                             (not (zerop (select 32 mask-obj 0 0 timeout))))
        !           195:                         mask mask-obj timeval)
        !           196:           (setf (unsigned-long-unsigned-long int)
        !           197:             (if *unix-domain*
        !           198:                 (ff::cstruct-len 'sockaddr-un)
        !           199:               (ff::cstruct-len 'sockaddr-in)))
        !           200:           (setq fd (accept listen-socket-fd listen-sockaddr int))
        !           201:           (when (< fd 0)
        !           202:             (perror "accept")
        !           203:             (return-from lisp-listener-socket-daemon nil))
        !           204:           
        !           205:           (setq stream
        !           206:             (excl::make-buffered-terminal-stream fd fd t t))
        !           207:           
        !           208:           ;; the first thing that comes over the stream is the name of the
        !           209:           ;; emacs buffer which was created--we name the process the same.
        !           210:           (setq proc-name (read stream))
        !           211:           
        !           212:           (if* *unix-domain*
        !           213:              then (process-run-function
        !           214:                    proc-name
        !           215:                    'lisp-listener-with-stream-as-terminal-io stream)
        !           216:              else (let ((hostaddr (logand
        !           217:                                    (sockaddr-in-addr listen-sockaddr) #xff)))
        !           218:                     (format t ";;; starting listener-~d (host ~d)~%" fd
        !           219:                             hostaddr)
        !           220:                     (if* (and nil
        !           221:                               ;; the next line checks that the connection
        !           222:                               ;; is coming from the current machine
        !           223:                               (not (eql 1 hostaddr))
        !           224:                               )
        !           225:                        then (format t ";;; access denied for addr ~s~%"
        !           226:                                     hostaddr)
        !           227:                             (refuse-connection fd)
        !           228:                        else (process-run-function
        !           229:                              proc-name
        !           230:                              'lisp-listener-with-stream-as-terminal-io
        !           231:                              stream))))))
        !           232:       (when listen-socket-fd
        !           233:        (mp::mpunwatchfor listen-socket-fd)
        !           234:        (unix-close listen-socket-fd)
        !           235:        (setq lisp-listener-daemon nil)))))
        !           236: 
        !           237: (defun refuse-connection (fd &aux s)
        !           238:   (setq s (excl::make-buffered-terminal-stream fd fd t t))
        !           239:   (setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
        !           240:   (format s "connection refused.~%")
        !           241:   (force-output s)
        !           242:   (setf (excl::sm_bterm-out-pos s) 0)
        !           243:   (close s))
        !           244: 
        !           245: (defun lisp-listener-with-stream-as-terminal-io (s)
        !           246:   (unwind-protect
        !           247:       (progn
        !           248:        (setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
        !           249:        (tpl:start-interactive-top-level
        !           250:         s 'tpl:top-level-read-eval-print-loop nil))
        !           251:     ;; This next crock is to prevent the force-output done by close from
        !           252:     ;; signalling an error if there are characters buffered to the output
        !           253:     ;; stream, which there will be if the remote client closed the connection.
        !           254:     ;; This should be changed to a clear-output once that works on a buffered
        !           255:     ;; terminal stream.
        !           256:     (setf (excl::sm_bterm-out-pos s) 0)
        !           257:     (close s)))
        !           258: 
        !           259: (defun open-network-stream (&key host port socket-file)
        !           260:   "Open a stream to a port, which is a TCP/IP communication channel.  There
        !           261: are two types of ports supported, UNIX and INTERNET domain.  The domain is
        !           262: chosen based on the keyword arguments actually used: HOST and PORT are for
        !           263: internet domain ports and SOCKET-FILE is for unix domain ports."
        !           264:   (if (and (or (null host) (null port))
        !           265:           (null socket-file))
        !           266:       (error "Must either supply HOST and PORT *or* SOCKET-FILE keywords."))
        !           267:   (if* socket-file
        !           268:      then ;; UNIX domain
        !           269:          (let ((server (make-cstruct 'sockaddr-un))
        !           270:                socket-fd)
        !           271:            (setf (sockaddr-un-family server) *af-unix*)
        !           272:            (dotimes (i (length socket-file)
        !           273:                      (setf (sockaddr-un-path server i) 0))
        !           274:              (setf (sockaddr-un-path server i)
        !           275:                (char-int (elt socket-file i))))
        !           276:            (setq socket-fd (socket *af-unix* *sock-stream* 0))
        !           277:            (if (< (connect socket-fd server (+ 2 (length socket-file))) 0)
        !           278:                (error "connect failed to ~s" socket-file))
        !           279:            (excl::make-buffered-terminal-stream socket-fd socket-fd t t))
        !           280:      else ;; INTERNET domain
        !           281:          (let (sock server hostaddress)
        !           282:            ;; Open a socket
        !           283:            (when (< (setf sock (socket *af-inet* *sock-stream* 0)) 0)
        !           284:              (error "couldn't open socket"))
        !           285:            ;; construct a socket address
        !           286:            (setf server (make-cstruct 'sockaddr-in))
        !           287:            (bzero server (ff::cstruct-len 'sockaddr-in))
        !           288:            (when (= (setf hostaddress (gethostbyname host)) 0)
        !           289:              (error "unknown host: ~a" host))
        !           290:            ;; This next line is what they invented the word "hack" for.
        !           291:            ;; If I knew how to pass the address of the addr field in server, I
        !           292:            ;; wouldn't have to do this.
        !           293:            ;; Be sure that this precedes writes to other fields in server.
        !           294:            (if (not (= 4 (hostent-length hostaddress)))
        !           295:                (error "address length not 4"))
        !           296:            (setf (sockaddr-in-addr server)
        !           297:              (si:memref-int (hostent-addr hostaddress) 0 0 :unsigned-long))
        !           298:            (setf (sockaddr-in-family server) *af-inet*)
        !           299:            (setf (sockaddr-in-port server) port)
        !           300:            ;; open the connection
        !           301:            (when (< (connect sock server (ff::cstruct-len 'sockaddr-in)) 0)
        !           302:              (unix-close sock)
        !           303:              (error "couldn't connect to socket"))
        !           304:            ;; build and return the stream
        !           305:            (excl::make-buffered-terminal-stream sock sock t t))))

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.