Commit | Line | Data |
---|---|---|
731bcf73 NJ |
1 | ;;; gds-server.el -- infrastructure for running GDS server processes |
2 | ||
3 | ;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. | |
4 | ;;;; | |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 2.1 of the License, or (at your option) any later | |
9 | ;;;; version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free | |
18 | ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA | |
19 | ;;;; 02111-1307 USA | |
20 | ||
21 | ||
22 | ;;;; Customization group setup. | |
23 | ||
24 | (defgroup gds nil | |
25 | "Customization options for Guile Emacs frontend." | |
26 | :group 'scheme) | |
27 | ||
28 | ||
fce4b99e | 29 | ;;;; Communication with the (ice-9 gds-server) subprocess. |
731bcf73 NJ |
30 | |
31 | ;; Subprocess output goes into the `*GDS Process*' buffer, and | |
32 | ;; is then read from there one form at a time. `gds-read-cursor' is | |
33 | ;; the buffer position of the start of the next unread form. | |
34 | (defvar gds-read-cursor nil) | |
35 | ||
36 | ;; The guile executable used by the GDS server process. | |
37 | (defcustom gds-guile-program "guile" | |
38 | "*The guile executable used by the GDS server process." | |
39 | :type 'string | |
40 | :group 'gds) | |
41 | ||
42 | (defcustom gds-scheme-directory nil | |
43 | "Where GDS's Scheme code is, if not in one of the standard places." | |
44 | :group 'gds | |
45 | :type '(choice (const :tag "nil" nil) directory)) | |
46 | ||
e2d23cc0 NJ |
47 | (defun gds-start-server (procname port-or-path protocol-handler &optional bufname) |
48 | "Start a GDS server process called PROCNAME, listening on TCP port | |
49 | or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a | |
50 | function that accepts and processes one protocol form. Optional arg | |
51 | BUFNAME specifies the name of the buffer that is used for process | |
52 | output; if not specified the buffer name is the same as the process | |
53 | name." | |
731bcf73 NJ |
54 | (with-current-buffer (get-buffer-create (or bufname procname)) |
55 | (erase-buffer) | |
56 | (let* ((code (format "(begin | |
57 | %s | |
fce4b99e | 58 | (use-modules (ice-9 gds-server)) |
e2d23cc0 | 59 | (run-server %S))" |
731bcf73 NJ |
60 | (if gds-scheme-directory |
61 | (concat "(set! %load-path (cons " | |
62 | (format "%S" gds-scheme-directory) | |
63 | " %load-path))") | |
64 | "") | |
e2d23cc0 | 65 | port-or-path)) |
731bcf73 NJ |
66 | (process-connection-type nil) ; use a pipe |
67 | (proc (start-process procname | |
68 | (current-buffer) | |
69 | gds-guile-program | |
70 | "-q" | |
71 | "--debug" | |
72 | "-c" | |
73 | code))) | |
74 | (set (make-local-variable 'gds-read-cursor) (point-min)) | |
75 | (set (make-local-variable 'gds-protocol-handler) protocol-handler) | |
76 | (set-process-filter proc (function gds-filter)) | |
77 | (set-process-sentinel proc (function gds-sentinel)) | |
78 | (set-process-coding-system proc 'latin-1-unix) | |
79 | (process-kill-without-query proc) | |
80 | proc))) | |
81 | ||
82 | ;; Subprocess output filter: inserts normally into the process buffer, | |
83 | ;; then tries to reread the output one form at a time and delegates | |
84 | ;; processing of each form to `gds-protocol-handler'. | |
85 | (defun gds-filter (proc string) | |
86 | (with-current-buffer (process-buffer proc) | |
87 | (save-excursion | |
88 | (goto-char (process-mark proc)) | |
89 | (insert-before-markers string)) | |
90 | (goto-char gds-read-cursor) | |
91 | (while (let ((form (condition-case nil | |
92 | (read (current-buffer)) | |
93 | (error nil)))) | |
94 | (if form | |
95 | (save-excursion | |
96 | (funcall gds-protocol-handler (car form) (cdr form)))) | |
97 | form) | |
98 | (setq gds-read-cursor (point))))) | |
99 | ||
100 | ;; Subprocess sentinel: do nothing. (Currently just here to avoid | |
101 | ;; inserting un-`read'able process status messages into the process | |
102 | ;; buffer.) | |
103 | (defun gds-sentinel (proc event) | |
104 | ) | |
105 | ||
106 | ||
107 | ;;;; The end! | |
108 | ||
109 | (provide 'gds-server) | |
110 | ||
111 | ;;; gds-server.el ends here. |