1 ;;; riece-server.el --- functions to open and close servers
2 ;; Copyright (C) 1998-2003 Daiki Ueno
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Keywords: IRC, riece
8 ;; This file is part of Riece.
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
27 (require 'riece-options)
28 (require 'riece-globals) ;for server local variables.
29 (require 'riece-coding) ;riece-default-coding-system
30 (require 'riece-identity)
31 (require 'riece-compat)
34 (defvar riece-server-keyword-map
37 (:nickname riece-nickname)
38 (:username riece-username)
40 (:function riece-default-open-connection-function)
41 (:coding riece-default-coding-system))
42 "Mapping from keywords to default values.
43 All keywords that can be used must be listed here."))
45 (defmacro riece-server-keyword-bind (plist &rest body)
46 "Return a `let' form that binds all variables in PLIST.
47 After this is done, BODY will be executed in the scope
50 The variables bound and their default values are described by
51 the `riece-server-keyword-map' variable."
54 (list (intern (substring (symbol-name (car keyword)) 1))
56 `(or (plist-get ,plist ',(car keyword))
58 `(plist-get ,plist ',(car keyword)))))
59 riece-server-keyword-map)
62 (put 'riece-server-keyword-bind 'lisp-indent-function 1)
63 (put 'riece-server-keyword-bind 'edebug-form-spec '(form body))
65 (defun riece-server-parse-string (string)
66 "Convert a STRING set as `riece-server' and return a property list."
67 (when (or (string-match "^\\[\\([^]]+\\)\\]:?\\([0-9]*\\)" string)
68 (string-match "^\\([^:]+\\):?\\([0-9]*\\)" string))
69 (let ((host (match-string 1 string))
70 (service (match-string 2 string))
71 (password (substring string (match-end 0)))
73 (setq plist (cons `(:host ,host) plist))
74 (unless (equal service "")
75 (setq plist (cons `(:service ,(string-to-int service)) plist)))
76 (unless (equal password "")
77 (setq plist (cons `(:password ,(substring password 1)) plist)))
78 (apply #'nconc plist))))
80 (defun riece-server-name-to-server (server-name)
81 (let ((entry (assoc server-name riece-server-alist)))
83 (unless (listp (cdr entry))
84 (setcdr entry (riece-server-parse-string (cdr entry))))
85 (setq entry (cons server-name (riece-server-parse-string server-name))
86 riece-server-alist (cons entry riece-server-alist)
87 riece-save-variables-are-dirty t))
90 (defun riece-server-process-name (server-name)
91 (if (equal server-name "")
93 (format "IRC<%s>" server-name)))
95 (defun riece-server-process (server-name)
96 (cdr (assoc server-name riece-server-process-alist)))
98 (defmacro riece-with-server-buffer (server-name &rest body)
99 `(let ((process (riece-server-process ,server-name)))
101 (with-current-buffer (process-buffer process)
103 (error "Server closed"))))
105 (put 'riece-with-server-buffer 'lisp-indent-function 1)
106 (put 'riece-with-server-buffer 'edebug-form-spec '(form body))
108 (defun riece-make-queue ()
109 "Make a queue object."
112 (defun riece-queue-enqueue (queue object)
113 "Add OBJECT to the end of QUEUE."
115 (let ((last (list object)))
116 (nconc (aref queue 1) last)
118 (aset queue 0 (list object))
119 (aset queue 1 (aref queue 0))))
121 (defun riece-queue-dequeue (queue)
122 "Remove an object from the beginning of QUEUE."
123 (unless (aref queue 0)
124 (error "Empty queue"))
125 (prog1 (car (aref queue 0))
126 (unless (aset queue 0 (cdr (aref queue 0)))
127 (aset queue 1 nil))))
129 (defun riece-queue-empty (queue)
130 "Return t if QUEUE is empty."
131 (null (aref queue 0)))
133 ;; stolen (and renamed) from time-date.el.
134 (defun riece-seconds-to-time (seconds)
135 "Convert SECONDS (a floating point number) to a time value."
136 (list (floor seconds 65536)
137 (floor (mod seconds 65536))
138 (floor (* (- seconds (ffloor seconds)) 1000000))))
140 ;; stolen (and renamed) from time-date.el.
141 (defun riece-time-less-p (t1 t2)
142 "Say whether time value T1 is less than time value T2."
143 (or (< (car t1) (car t2))
144 (and (= (car t1) (car t2))
145 (< (nth 1 t1) (nth 1 t2)))))
147 ;; stolen (and renamed) from time-date.el.
148 (defun riece-time-since (time)
149 "Return the time elapsed since TIME."
150 (let* ((current (current-time))
151 (rest (when (< (nth 1 current) (nth 1 time))
153 (list (- (+ (car current) (if rest -1 0)) (car time))
154 (- (+ (or rest 0) (nth 1 current)) (nth 1 time)))))
156 (defun riece-flush-send-queue (process)
157 (with-current-buffer (process-buffer process)
160 (if (riece-time-less-p (riece-seconds-to-time riece-send-delay)
161 (riece-time-since riece-last-send-time))
162 (setq riece-send-size 0))
163 (while (and (not (riece-queue-empty riece-send-queue))
164 (<= riece-send-size riece-max-send-size))
165 (setq string (riece-encode-coding-string
166 (riece-queue-dequeue riece-send-queue))
167 length (length string))
168 (if (> length riece-max-send-size)
169 (message "Long message (%d > %d)" length riece-max-send-size)
170 (setq riece-send-size (+ riece-send-size length))
171 (when (<= riece-send-size riece-max-send-size)
172 (process-send-string process string)
173 (setq riece-last-send-time (current-time)))))
174 (unless (riece-queue-empty riece-send-queue)
175 (riece-run-at-time riece-send-delay nil
177 (if (riece-server-process-opened process)
178 (riece-flush-send-queue process)))
181 (defun riece-process-send-string (process string)
182 (with-current-buffer (process-buffer process)
183 (riece-queue-enqueue riece-send-queue string))
184 (riece-flush-send-queue process))
186 (defun riece-current-server-name ()
187 (or riece-overriding-server-name
188 ;already in the server buffer
189 (if (local-variable-p 'riece-server-name (current-buffer))
191 (if riece-current-channel
192 (riece-identity-server riece-current-channel)
193 (if (riece-server-opened "")
196 (defun riece-send-string (string)
197 (let* ((server-name (riece-current-server-name))
198 (process (riece-server-process server-name)))
200 (error "%s" (substitute-command-keys
201 "Type \\[riece-command-open-server] to open server.")))
202 (riece-process-send-string process string)))
204 (defun riece-open-server (server server-name)
205 (let ((protocol (or (plist-get server :protocol)
210 (require (intern (concat "riece-" (symbol-name protocol))))
212 (setq function (intern-soft (concat "riece-"
213 (symbol-name protocol)
216 (error "\"%S\" is not supported" protocol))
218 (setq process (funcall function server server-name))
221 (with-current-buffer (process-buffer process)
222 (make-local-variable 'riece-protocol)
223 (setq riece-protocol protocol))
224 (setq riece-server-process-alist
225 (cons (cons server-name process)
226 riece-server-process-alist)))))
228 (defun riece-quit-server-process (process &optional message)
229 (let ((function (intern-soft
231 (with-current-buffer (process-buffer process)
232 (symbol-name riece-protocol))
233 "-quit-server-process"))))
235 (funcall function process message))))
237 (defun riece-reset-process-buffer (process)
239 (set-buffer (process-buffer process))
240 (if (fboundp 'set-buffer-multibyte)
241 (set-buffer-multibyte nil))
242 (kill-all-local-variables)
243 (make-local-variable 'riece-real-nickname)
244 (make-local-variable 'riece-last-nickname)
245 (make-local-variable 'riece-nick-accepted)
246 (make-local-variable 'riece-real-server-name)
247 (make-local-variable 'riece-real-userhost)
248 (make-local-variable 'riece-user-at-host)
249 (make-local-variable 'riece-user-at-host-type)
250 (make-local-variable 'riece-supported-user-modes)
251 (make-local-variable 'riece-supported-channel-modes)
252 (make-local-variable 'riece-channel-filter)
253 (make-local-variable 'riece-server-name)
254 (make-local-variable 'riece-read-point)
255 (setq riece-read-point (point-min))
256 (make-local-variable 'riece-send-queue)
257 (setq riece-send-queue (riece-make-queue))
258 (make-local-variable 'riece-send-size)
259 (setq riece-send-size 0)
260 (make-local-variable 'riece-last-send-time)
261 (setq riece-last-send-time '(0 0 0))
262 (make-local-variable 'riece-user-obarray)
263 (setq riece-user-obarray (make-vector riece-user-obarray-size 0))
264 (make-local-variable 'riece-channel-obarray)
265 (setq riece-channel-obarray (make-vector riece-channel-obarray-size 0))
266 (make-local-variable 'riece-coding-system)
267 (buffer-disable-undo)
270 (defun riece-close-server-process (process)
271 (with-current-buffer (process-buffer process)
272 (run-hooks 'riece-after-close-hook))
273 (kill-buffer (process-buffer process))
274 (setq riece-server-process-alist
275 (delq (rassq process riece-server-process-alist)
276 riece-server-process-alist)))
278 (defun riece-server-process-opened (process)
279 (not (null (memq (process-status process) '(open run)))))
281 (defun riece-server-opened (&optional server-name)
283 (let ((process (riece-server-process server-name)))
285 (riece-server-process-opened process)))
286 (let ((alist riece-server-process-alist))
289 (if (riece-server-process-opened (cdr (car alist)))
291 (setq alist (cdr alist)))))))
293 (defun riece-server-properties (server-name)
294 "Return a list of properties associated with SERVER-NAME."
295 (if (equal server-name "")
297 (let ((entry (assoc server-name riece-server-alist)))
299 (error "No such server"))
302 (provide 'riece-server)
304 ;;; riece-server.el ends here