elisp/geiser-connection.el

   1 ;;; geiser-connection.el -- talking to a scheme process
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sat Feb 07, 2009 21:11
  11
  12 \f
  13
  14 ;; Connection datatype and functions for managing request queues
  15 ;; between emacs and inferior guile processes.
  16
  17 (require 'geiser-log)
  18 (require 'geiser-syntax)
  19 (require 'geiser-base)
  20 (require 'geiser-impl)
  21
  22 (require 'tq)
  23
  24 \f
  25 ;;; Buffer connections:
  26
  27 (make-variable-buffer-local
  28  (defvar geiser-con--connection nil))
  29
  30 (defun geiser-con--get-connection (buffer/proc)
  31   (if (processp buffer/proc)
  32       (geiser-con--get-connection (process-buffer buffer/proc))
  33     (with-current-buffer buffer/proc geiser-con--connection)))
  34
  35 \f
  36 ;;; Request datatype:
  37
  38 (defun geiser-con--make-request (con str cont &optional sender-buffer)
  39   (list :geiser-connection-request
  40         (cons :id (geiser-con--connection-inc-count con))
  41         (cons :string str)
  42         (cons :continuation cont)
  43         (cons :buffer (or sender-buffer (current-buffer)))
  44         (cons :connection con)))
  45
  46 (defsubst geiser-con--request-p (req)
  47   (and (listp req) (eq (car req) :geiser-connection-request)))
  48
  49 (defsubst geiser-con--request-id (req)
  50   (cdr (assoc :id req)))
  51
  52 (defsubst geiser-con--request-string (req)
  53   (cdr (assoc :string req)))
  54
  55 (defsubst geiser-con--request-continuation (req)
  56   (cdr (assoc :continuation req)))
  57
  58 (defsubst geiser-con--request-buffer (req)
  59   (cdr (assoc :buffer req)))
  60
  61 (defsubst geiser-con--request-connection (req)
  62   (cdr (assoc :connection req)))
  63
  64 (defsubst geiser-con--request-deactivate (req)
  65   (setcdr (assoc :continuation req) nil))
  66
  67 (defsubst geiser-con--request-deactivated-p (req)
  68   (null (cdr (assoc :continuation req))))
  69
  70 \f
  71 ;;; Connection datatype:
  72
  73 (defun geiser-con--combined-prompt (prompt debug)
  74   (format "\\(%s%s\\)" prompt (if debug (format "\\|%s" debug) "")))
  75
  76 (defun geiser-con--connection-eot-re (prompt debug)
  77   (geiser-con--combined-prompt (format "\0\n%s" prompt)
  78                                (and debug (format "\n%s" debug))))
  79
  80 (defun geiser-con--make-connection (proc prompt debug-prompt)
  81   (list :geiser-connection
  82         (cons :tq (tq-create proc))
  83         (cons :eot (geiser-con--connection-eot-re prompt debug-prompt))
  84         (cons :prompt prompt)
  85         (cons :debug-prompt debug-prompt)
  86         (cons :count 0)
  87         (cons :completed (make-hash-table :weakness 'value))))
  88
  89 (defun geiser-con--connection-swap-proc (con proc)
  90   (let* ((this-proc (geiser-con--connection-process con))
  91          (this-filter (process-filter this-proc))
  92          (filter (process-filter proc))
  93          (buffer (process-buffer proc))
  94          (tq (geiser-con--connection-tq con)))
  95     (set-process-filter this-proc filter)
  96     (set-process-buffer this-proc buffer)
  97     (set-process-filter proc this-filter)
  98     (set-process-buffer proc nil)
  99     (setcdr tq (cons proc (tq-buffer tq)))
 100     this-proc))
 101
 102 (defsubst geiser-con--connection-p (c)
 103   (and (listp c) (eq (car c) :geiser-connection)))
 104
 105 (defsubst geiser-con--connection-process (c)
 106   (tq-process (cdr (assoc :tq c))))
 107
 108 (defsubst geiser-con--connection-tq (c)
 109   (cdr (assoc :tq c)))
 110
 111 (defsubst geiser-con--connection-eot (c)
 112   (cdr (assoc :eot c)))
 113
 114 (defsubst geiser-con--connection-prompt (c)
 115   (cdr (assoc :prompt c)))
 116
 117 (defsubst geiser-con--connection-debug-prompt (c)
 118   (cdr (assoc :debug-prompt c)))
 119
 120 (defsubst geiser-con--connection-completed (c r)
 121   (geiser-con--request-deactivate r)
 122   (puthash (geiser-con--request-id r) r (cdr (assoc :completed c))))
 123
 124 (defsubst geiser-con--connection-completed-p (c id)
 125   (gethash id (cdr (assoc :completed c))))
 126
 127 (defun geiser-con--connection-inc-count (c)
 128   (let* ((cnt (assoc :count c))
 129          (new (1+ (cdr cnt))))
 130     (setcdr cnt new)
 131     new))
 132
 133 (defun geiser-con--has-entered-debugger (con answer)
 134   (let ((dp (geiser-con--connection-debug-prompt con)))
 135     (and (stringp dp) (string-match dp answer))))
 136
 137 (defun geiser-con--connection-close (con)
 138   (let ((tq (geiser-con--connection-tq con)))
 139     (and tq (tq-close tq))))
 140
 141 (defvar geiser-con--startup-prompt nil)
 142 (defun geiser-con--startup-prompt (p s)
 143   (setq geiser-con--startup-prompt
 144         (concat geiser-con--startup-prompt s))
 145   nil)
 146
 147 (defun geiser-con--open-connection (host port prompt debug-prompt)
 148   (setq geiser-con--startup-prompt "")
 149   (let* ((name (format "geiser-con@%s:%s" host port))
 150          (proc (open-network-stream name nil host port)))
 151     (set-process-filter proc 'geiser-con--startup-prompt)
 152     (with-timeout (10
 153                    (error (format "Timeout connecting to %s:%s" host port)))
 154       (while (not (string-match prompt geiser-con--startup-prompt))
 155         (accept-process-output proc 0.05)))
 156     (geiser-con--make-connection proc prompt debug-prompt)))
 157
 158 \f
 159 ;;; Requests handling:
 160
 161 (defun geiser-con--req-form (req answer)
 162   (let ((con (geiser-con--request-connection req)))
 163     (if (geiser-con--has-entered-debugger con answer)
 164         `((error (key . geiser-debugger))
 165           (output . ,answer))
 166       (condition-case err
 167           (car (read-from-string answer))
 168         (error `((error (key . geiser-con-error))
 169                  (output . ,(format "%s\n(%s)"
 170                                     answer
 171                                     (error-message-string err)))))))))
 172
 173 (defun geiser-con--process-completed-request (req answer)
 174   (let ((cont (geiser-con--request-continuation req))
 175         (id (geiser-con--request-id req))
 176         (rstr (geiser-con--request-string req))
 177         (form (geiser-con--req-form req answer))
 178         (buffer (or (geiser-con--request-buffer req) (current-buffer)))
 179         (con (geiser-con--request-connection req)))
 180     (if (not cont)
 181         (geiser-log--warn "<%s> Droping result for request %S: %s"
 182                           id rstr form)
 183       (condition-case cerr
 184           (with-current-buffer buffer
 185             (funcall cont form)
 186             (geiser-log--info "<%s>: processed" id))
 187         (error (geiser-log--error
 188                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))
 189     (geiser-con--connection-completed con req)))
 190
 191 (defun geiser-con--connection-add-request (c r)
 192   (geiser-log--info "REQUEST: <%s>: %s"
 193                     (geiser-con--request-id r)
 194                     (geiser-con--request-string r))
 195   (tq-enqueue (geiser-con--connection-tq c)
 196               (concat (geiser-con--request-string r) "\n")
 197               (geiser-con--connection-eot c)
 198               r
 199               'geiser-con--process-completed-request
 200               nil))
 201
 202 \f
 203 ;;; Message sending interface:
 204
 205 (defun geiser-con--send-string (con str cont &optional sbuf)
 206   (let ((req (geiser-con--make-request con str cont sbuf)))
 207     (geiser-con--connection-add-request con req)
 208     req))
 209
 210 (defvar geiser-connection-timeout 30000
 211   "Time limit, in msecs, blocking on synchronous evaluation requests")
 212
 213 (defun geiser-con--send-string/wait (con str cont &optional timeout sbuf)
 214   (save-current-buffer
 215     (let ((proc (and con (geiser-con--connection-process con))))
 216       (unless proc (error "Geiser connection not active"))
 217       (let* ((req (geiser-con--send-string con str cont sbuf))
 218              (id (geiser-con--request-id req))
 219              (timeout (/ (or timeout geiser-connection-timeout) 1000.0)))
 220         (with-timeout (timeout (geiser-con--request-deactivate req))
 221           (condition-case nil
 222               (while (and (geiser-con--connection-process con)
 223                           (not (geiser-con--connection-completed-p con id)))
 224                 (accept-process-output proc (/ timeout 10)))
 225             (error (geiser-con--request-deactivate req))))))))
 226
 227 \f
 228 (provide 'geiser-connection)