src/server.lisp

   1 ;; Connect Maxima to a socket which has been opened by
   2 ;; some third party, typically a GUI program which supplies
   3 ;; input to Maxima.
   4 ;; Note that this code DOES NOT create a Maxima server:
   5 ;; Maxima is the client!
   6
   7 (in-package :maxima)
   8
   9 #+(or ecl sbcl)
  10 (eval-when (:compile-toplevel :load-toplevel :execute)
  11   #+sbcl (require 'sb-posix)
  12   (require 'sb-bsd-sockets))
  13
  14 (defvar $in_netmath nil)
  15 (defvar $show_openplot t)
  16 (defvar *socket-connection*)
  17 (defvar $old_stdout)
  18 (defvar $old_stderr)
  19
  20 #+ecl (defvar *old-stdin*)
  21 #+ecl (defvar *old-stdout*)
  22 #+ecl (defvar *old-sterr*)
  23 #+ecl (defvar *old-term-io*)
  24 #+ecl (defvar *old-debug-io*)
  25
  26 (defun setup-client (port &optional (host "localhost"))
  27   ;; The following command has to be executed on windows before
  28   ;; the connection is opened. If it isn't the first unicode
  29   ;; character maxima wants to send causes sbcl to wait indefinitely.
  30   #+sbcl (setf sb-impl::*default-external-format* :utf-8)
  31   (multiple-value-bind (sock condition) (ignore-errors (open-socket host port))
  32     (unless sock
  33       ; It appears that we were unable to open a socket or connect to the
  34       ; specified port.
  35       (mtell (intl:gettext "~%Unable to connect Maxima to port ~:M.~%") port)
  36       (mtell (intl:gettext "Error: ~A~%") condition)
  37       ($quit))
  38     ;; Some lisps if the front-end dies by default don't quit but output an
  39     ;; error message to the front-end that (as the front-end doesn't exist
  40     ;; any more) causes an error message that...
  41     #+ecl (ext:set-signal-handler EXT:+SIGPIPE+ 'ext:quit)
  42
  43     (setq *socket-connection* sock)
  44     (setq $old_stderr *error-output*
  45           $old_stdout *standard-output*)
  46     #+ecl (setq *old-stdin*    *standard-input*
  47                 *old-stdout*   *standard-output*
  48                 *old-sterr*    *error-output*
  49                 *old-term-io*  *terminal-io*
  50                 *old-debug-io* *debug-io*)
  51     (setq *standard-input* sock)
  52     (setq *standard-output* sock)
  53     (setq *error-output* sock)
  54     (setq *terminal-io* sock)
  55     (setq *trace-output* sock)
  56     (format t "pid=~a~%" (getpid))
  57     (finish-output sock)
  58     (setq *debug-io* sock))
  59   (values))
  60
  61 (defun close-client ()
  62   #+ecl (setq *standard-input*  *old-stdin*
  63               *standard-output* *old-stdout*
  64               *error-output*    *old-sterr*
  65               *terminal-io*     *old-term-io*
  66               *debug-io*        *old-debug-io*)
  67   #+ecl (close *socket-connection*))
  68
  69 ;;; from CLOCC: <http://clocc.sourceforge.net>
  70 (defun open-socket (host port &optional bin)
  71   "Open a socket connection to `host' at `port'."
  72   (declare (type (or integer string) host) (fixnum port) (type boolean bin))
  73   #+(or gcl ccl)
  74   (declare (ignore bin))
  75
  76   (let ((host (etypecase host
  77                 (string host)
  78                 ;; Can't actually handle this case for lack of HOSTENT-NAME and RESOLVE-HOST-IPADDR.
  79                 ;;(integer (hostent-name (resolve-host-ipaddr host)))))
  80                 (integer (merror (intl:gettext "OPEN-SOCKET: can't handle integer host argument (host=~M)~%") host))))
  81         #+(and ccl openmcl-unicode-strings)
  82         (ccl:*default-socket-character-encoding* :utf-8))
  83     #+allegro (socket:make-socket :remote-host host :remote-port port
  84                                   :format (if bin :binary :text))
  85     #+abcl (ext:get-socket-stream (ext:make-socket host port))
  86     #+clisp (socket:socket-connect port host :element-type
  87                                    (if bin '(unsigned-byte 8) 'character))
  88     #+scl (sys:make-fd-stream (ext:connect-to-inet-socket host port)
  89                               :input t :output t :element-type
  90                               (if bin '(unsigned-byte 8) 'character))
  91     #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port)
  92                               :input t :output t :element-type
  93                               (if bin '(unsigned-byte 8) 'character)
  94                               #+unicode :external-format #+unicode :utf-8
  95                               :buffering :line)
  96     #+(or ecl sbcl) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
  97                                         :type :stream :protocol :tcp)))
  98              (sb-bsd-sockets:socket-connect
  99               socket (sb-bsd-sockets:host-ent-address
 100                       (sb-bsd-sockets:get-host-by-name host)) port)
 101              (sb-bsd-sockets:socket-make-stream
 102               socket :input t :output t :buffering (if bin :none :line)
 103               :element-type (if bin '(unsigned-byte 8) 'character)
 104               #+sb-unicode :external-format #+sb-unicode :utf-8))
 105     #+gcl (si::socket port :host host)
 106     #+lispworks (comm:open-tcp-stream host port :direction :io :element-type
 107                                       (if bin 'unsigned-byte 'base-char))
 108     #+ccl (ccl::make-socket :remote-host host :remote-port port)
 109     #-(or allegro abcl clisp cmu scl sbcl gcl lispworks ecl ccl)
 110     (error 'not-implemented :proc (list 'open-socket host port bin))))
 111
 112
 113
 114 (defun start-client (port &optional (host "localhost"))
 115   (format t (intl:gettext "Connecting Maxima to server on port ~a~%") port)
 116   (setq $in_netmath t)
 117   (setq $show_openplot nil)
 118   (setup-client port host))
 119
 120 #-gcl
 121 (defun getpid-from-environment ()
 122   (handler-case
 123       (values (parse-integer (maxima-getenv "PID")))
 124     ((or type-error parse-error) () -1)))
 125
 126 ;;; For gcl, getpid imported from system in maxima-package.lisp
 127 #-gcl
 128 (defun getpid ()
 129 #+clisp (os:process-id)
 130 #+(or cmu scl) (unix:unix-getpid)
 131 #+sbcl (sb-unix:unix-getpid)
 132 #+gcl (system:getpid)
 133 #+openmcl (ccl::getpid)
 134 #+lispworks (system::getpid)
 135 #+ecl (si:getpid)
 136 #+ccl (ccl::getpid)
 137 #+allegro (excl::getpid)
 138 #-(or clisp cmu scl sbcl gcl openmcl lispworks ecl ccl allegro)
 139   (getpid-from-environment)
 140 )
 141
 142 #+(or gcl clisp cmu scl sbcl lispworks ecl ccl allegro)
 143 (defun xchdir (w)
 144   #+clisp (ext:cd w)
 145   #+gcl (si::chdir w)
 146   #+(or cmu scl) (unix::unix-chdir w)
 147   #+sbcl (sb-posix:chdir w)
 148   #+lispworks (hcl:change-directory w)
 149   #+ecl (si:chdir w)
 150   #+ccl (ccl:cwd w)
 151   #+allegro (excl:chdir w)
 152   )