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     #+gcl (setq si::*sigpipe-action* 'si::bye)
  42     #+ecl (ext:set-signal-handler EXT:+SIGPIPE+ 'ext:quit)
  43
  44     (setq *socket-connection* sock)
  45     (setq $old_stderr *error-output*
  46           $old_stdout *standard-output*)
  47     #+ecl (setq *old-stdin*    *standard-input*
  48                 *old-stdout*   *standard-output*
  49                 *old-sterr*    *error-output*
  50                 *old-term-io*  *terminal-io*
  51                 *old-debug-io* *debug-io*)
  52     (setq *standard-input* sock)
  53     (setq *standard-output* sock)
  54     (setq *error-output* sock)
  55     (setq *terminal-io* sock)
  56     (setq *trace-output* sock)
  57     (format t "pid=~a~%" (getpid))
  58     (finish-output sock)
  59     (setq *debug-io* sock))
  60   (values))
  61
  62 (defun close-client ()
  63   #+ecl (setq *standard-input*  *old-stdin*
  64               *standard-output* *old-stdout*
  65               *error-output*    *old-sterr*
  66               *terminal-io*     *old-term-io*
  67               *debug-io*        *old-debug-io*)
  68   #+ecl (close *socket-connection*))
  69
  70 ;;; from CLOCC: <http://clocc.sourceforge.net>
  71 (defun open-socket (host port &optional bin)
  72   "Open a socket connection to `host' at `port'."
  73   (declare (type (or integer string) host) (fixnum port) (type boolean bin))
  74   #+(or gcl ccl)
  75   (declare (ignore bin))
  76
  77   (let ((host (etypecase host
  78                 (string host)
  79                 ;; Can't actually handle this case for lack of HOSTENT-NAME and RESOLVE-HOST-IPADDR.
  80                 ;;(integer (hostent-name (resolve-host-ipaddr host)))))
  81                 (integer (merror (intl:gettext "OPEN-SOCKET: can't handle integer host argument (host=~M)~%") host))))
  82         #+(and ccl openmcl-unicode-strings)
  83         (ccl:*default-socket-character-encoding* :utf-8))
  84     #+allegro (socket:make-socket :remote-host host :remote-port port
  85                                   :format (if bin :binary :text))
  86     #+abcl (ext:get-socket-stream (ext:make-socket host port))
  87     #+clisp (socket:socket-connect port host :element-type
  88                                    (if bin '(unsigned-byte 8) 'character))
  89     #+scl (sys:make-fd-stream (ext:connect-to-inet-socket host port)
  90                               :input t :output t :element-type
  91                               (if bin '(unsigned-byte 8) 'character))
  92     #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket host port)
  93                               :input t :output t :element-type
  94                               (if bin '(unsigned-byte 8) 'character)
  95                               #+unicode :external-format #+unicode :utf-8
  96                               :buffering :line)
  97     #+(or ecl sbcl) (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
  98                                         :type :stream :protocol :tcp)))
  99              (sb-bsd-sockets:socket-connect
 100               socket (sb-bsd-sockets:host-ent-address
 101                       (sb-bsd-sockets:get-host-by-name host)) port)
 102              (sb-bsd-sockets:socket-make-stream
 103               socket :input t :output t :buffering (if bin :none :line)
 104               :element-type (if bin '(unsigned-byte 8) 'character)
 105               #+sb-unicode :external-format #+sb-unicode :utf-8))
 106     #+gcl (si::socket port :host host)
 107     #+lispworks (comm:open-tcp-stream host port :direction :io :element-type
 108                                       (if bin 'unsigned-byte 'base-char))
 109     #+ccl (ccl::make-socket :remote-host host :remote-port port)
 110     #-(or allegro abcl clisp cmu scl sbcl gcl lispworks ecl ccl)
 111     (error 'not-implemented :proc (list 'open-socket host port bin))))
 112
 113
 114
 115 (defun start-client (port &optional (host "localhost"))
 116   (format t (intl:gettext "Connecting Maxima to server on port ~a~%") port)
 117   (setq $in_netmath t)
 118   (setq $show_openplot nil)
 119   (setup-client port host))
 120
 121 #-gcl
 122 (defun getpid-from-environment ()
 123   (handler-case
 124       (values (parse-integer (maxima-getenv "PID")))
 125     ((or type-error parse-error) () -1)))
 126
 127 ;;; For gcl, getpid imported from system in maxima-package.lisp
 128 #-gcl
 129 (defun getpid ()
 130 #+clisp (os:process-id)
 131 #+(or cmu scl) (unix:unix-getpid)
 132 #+sbcl (sb-unix:unix-getpid)
 133 #+gcl (system:getpid)
 134 #+openmcl (ccl::getpid)
 135 #+lispworks (system::getpid)
 136 #+ecl (si:getpid)
 137 #+ccl (ccl::getpid)
 138 #+allegro (excl::getpid)
 139 #-(or clisp cmu scl sbcl gcl openmcl lispworks ecl ccl allegro)
 140   (getpid-from-environment)
 141 )
 142
 143 #+(or gcl clisp cmu scl sbcl lispworks ecl ccl allegro)
 144 (defun xchdir (w)
 145   #+clisp (ext:cd w)
 146   #+gcl (si::chdir w)
 147   #+(or cmu scl) (unix::unix-chdir w)
 148   #+sbcl (sb-posix:chdir w)
 149   #+lispworks (hcl:change-directory w)
 150   #+ecl (si:chdir w)
 151   #+ccl (ccl:cwd w)
 152   #+allegro (excl:chdir w)
 153   )