source: release/1.9/source/library/swank-loader.lisp @ 15706

Last change on this file since 15706 was 15105, checked in by gz, 8 years ago

Rewrite the remote lisp client to use swink rather than swank. Move swank utilities to a separate file since no longer use it here.

File size: 7.1 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2011 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16;;;
17
18(in-package :ccl)
19
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21;;
22;; Standard swank startup
23;;
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
26;; (export '(load-swank start-swank-server start-swank-loader stop-swank-loader))
27
28(defun swankvar (name &optional (package :swank))
29  (symbol-value (find-symbol name package)))
30
31(defun (setf swankvar) (value name &optional (package :swank))
32  (let ((sym (find-symbol name package)))
33    (if (null sym)
34      (warn "Couldn't find ~a::~a" package name)
35      (set sym value))))
36
37(defun load-swank (load-path)
38  (when (find-package :swank-loader) (delete-package :swank-loader)) ;; so can tell if loaded
39  (load (merge-pathnames load-path "swank-loader.lisp"))
40  (unless (and (find-package :swank-loader)
41               (find-symbol "INIT" :swank-loader))
42    (error "~s is not a swank loader path" load-path))
43  (funcall (find-symbol "INIT" :swank-loader))
44  (unless (and (find-package :swank)
45               (find-symbol "CREATE-SERVER" :swank))
46    (error "Incompatible swank version loaded from ~s" load-path)))
47
48(defun start-swank-server (&key
49                           (port (swankvar "DEFAULT-SERVER-PORT"))
50                           (debug (swankvar "*LOG-EVENTS*"))
51                           (dedicated-output-port (and (swankvar "*USE-DEDICATED-OUTPUT-STREAM*")
52                                                       (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*")))
53                           (globally-redirect-io (swankvar "*GLOBALLY-REDIRECT-IO*"))
54                           (global-debugger (swankvar "*GLOBAL-DEBUGGER*"))
55                           (indentation-updates (swankvar "*CONFIGURE-EMACS-INDENTATION*"))
56                           (dont-close (swankvar "*DONT-CLOSE*"))
57                           (coding-system "iso-latin-1-unix")
58                           (style :spawn))
59  "Assuming SWANK is already loaded, create a swank server on the specified port"
60  (when debug
61    (setf (swankvar "*LOG-EVENTS*" :swank-rpc) t)
62    (setf (swankvar "*SWANK-DEBUG-P*") t)
63    (setf (swankvar "*DEBUG-ON-SWANK-PROTOCOL-ERROR*") t))
64  (when (setf (swankvar "*USE-DEDICATED-OUTPUT-STREAM*") (not (null dedicated-output-port)))
65    (setf (swankvar "*DEDICATED-OUTPUT-STREAM-PORT*") dedicated-output-port))
66  (setf (swankvar "*GLOBALLY-REDIRECT-IO*") globally-redirect-io)
67  (setf (swankvar "*GLOBAL-DEBUGGER*") global-debugger)
68  (setf (swankvar "*CONFIGURE-EMACS-INDENTATION*") indentation-updates)
69  (funcall (find-symbol "CREATE-SERVER" :swank)
70           :style style
71           :port port
72           :dont-close dont-close
73           :coding-system coding-system))
74
75
76(defun swank-port-active? (port)
77  (and (find-package :swank) (getf (swankvar "*LISTENER-SOCKETS*") port)))
78
79
80;; Special ccl slime extension to allow the client to specify the swank path
81
82(defvar *swank-loader-process* nil)
83(defparameter $emacs-ccl-swank-request-marker "[emacs-ccl-swank-request]")
84(defparameter *default-swank-loader-port* 4884)
85
86(defun stop-swank-loader ()
87  (when *swank-loader-process*
88    (process-kill (shiftf *swank-loader-process* nil))))
89
90(defun start-swank-loader (&optional (port *default-swank-loader-port*))
91  (ignore-errors (stop-swank-loader))
92  (let ((semaphore (make-semaphore))
93        (errorp nil))
94    (setq *swank-loader-process*
95          ;; Wait for either a swank client to connect or the special ccl slime kludge
96          (process-run-function "Swank Loader"
97                                (lambda (sem)
98                                  (setq *swank-loader-process* *current-process*)
99                                  (unwind-protect
100                                      (with-open-socket (socket :connect :passive :local-port port
101                                                                :reuse-address t)
102                                        (signal-semaphore (shiftf sem nil))
103                                        (loop
104                                          (let* ((stream (accept-connection socket))
105                                                 (line (read-line stream nil)))
106                                            (multiple-value-bind (path port)
107                                                                 (parse-emacs-ccl-swank-request line)
108                                              (let ((message (handler-case
109                                                                 (if (swank-port-active? port)
110                                                                   (format nil "Swank is already active on port ~s" port)
111                                                                   (progn
112                                                                     (load-swank path)
113                                                                     (start-swank-server :port port)
114                                                                     nil))
115                                                               (error (c) (princ-to-string c)))))
116                                                (prin1 `(:active (and (swank-port-active? port) t)
117                                                                 :loader ,path
118                                                                 :message ,message
119                                                                 :port ,port)
120                                                       stream)
121                                                (finish-output stream))))))
122                                    (when sem ;; in case exit before finished startup
123                                      (setq errorp t)
124                                      (signal-semaphore sem))))
125                                semaphore))
126    (wait-on-semaphore semaphore)
127    (when errorp
128      (ignore-errors (process-kill (shiftf *swank-loader-process* nil))))
129    *swank-loader-process*))
130
131(defun parse-emacs-ccl-swank-request (line)
132  (let ((start (length $emacs-ccl-swank-request-marker)))
133    (when (and (< start (length line))
134               (string= $emacs-ccl-swank-request-marker line :end2 start))
135      (let* ((split-pos (position #\: line :start start))
136             (port (parse-integer line :junk-allowed nil :start start :end split-pos))
137             (path-pos (position-if-not #'whitespacep line
138                                        :start (if split-pos (1+ split-pos) start)))
139             (path (subseq line path-pos
140                           (1+ (position-if-not #'whitespacep line :from-end t)))))
141        (values path port)))))
142
143
144
145
Note: See TracBrowser for help on using the repository browser.