* riece-options.el (riece-send-delay): Set default to 2.
[elisp/riece.git] / lisp / riece-server.el
1 ;;; riece-server.el --- functions to open and close servers
2 ;; Copyright (C) 1998-2003 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Created: 1998-09-28
6 ;; Keywords: IRC, riece
7
8 ;; This file is part of Riece.
9
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)
13 ;; any later version.
14
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.
19
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.
24
25 ;;; Code:
26
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)
32
33 (eval-and-compile
34   (defvar riece-server-keyword-map
35     '((:host)
36       (:service 6667)
37       (:nickname riece-nickname)
38       (:username riece-username)
39       (:password)
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."))
44
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
48 of the `let' form.
49
50 The variables bound and their default values are described by
51 the `riece-server-keyword-map' variable."
52   `(let ,(mapcar
53           (lambda (keyword)
54             (list (intern (substring (symbol-name (car keyword)) 1))
55                   (if (cadr keyword)
56                       `(or (plist-get ,plist ',(car keyword))
57                            ,(cadr keyword))
58                     `(plist-get ,plist ',(car keyword)))))
59           riece-server-keyword-map)
60      ,@body))
61
62 (put 'riece-server-keyword-bind 'lisp-indent-function 1)
63 (put 'riece-server-keyword-bind 'edebug-form-spec '(form body))
64
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)))
72           plist)
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))))
79
80 (defun riece-server-name-to-server (server-name)
81   (let ((entry (assoc server-name riece-server-alist)))
82     (if entry
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))
88     (cdr entry)))
89
90 (defun riece-server-process-name (server-name)
91   (if (equal server-name "")
92       "IRC"
93     (format "IRC<%s>" server-name)))
94
95 (defun riece-server-process (server-name)
96   (cdr (assoc server-name riece-server-process-alist)))
97
98 (defmacro riece-with-server-buffer (server-name &rest body)
99   `(let ((process (riece-server-process ,server-name)))
100      (if process
101          (with-current-buffer (process-buffer process)
102            ,@body)
103        (error "Server closed"))))
104
105 (put 'riece-with-server-buffer 'lisp-indent-function 1)
106 (put 'riece-with-server-buffer 'edebug-form-spec '(form body))
107
108 (defun riece-make-queue ()
109   "Make a queue object."
110   (vector nil nil))
111
112 (defun riece-queue-enqueue (queue object)
113   "Add OBJECT to the end of QUEUE."
114   (if (aref queue 1)
115       (let ((last (list object)))
116         (nconc (aref queue 1) last)
117         (aset queue 1 last))
118     (aset queue 0 (list object))
119     (aset queue 1 (aref queue 0))))
120
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))))
128
129 (defun riece-queue-empty (queue)
130   "Return t if QUEUE is empty."
131   (null (aref queue 0)))
132
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))))
139
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)))))
146
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))
152                  (expt 2 16))))
153     (list (- (+ (car current) (if rest -1 0)) (car time))
154           (- (+ (or rest 0) (nth 1 current)) (nth 1 time)))))
155
156 (defun riece-flush-send-queue (process)
157   (with-current-buffer (process-buffer process)
158     (let ((length 0)
159           string)
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       (if riece-send-queue
175           (riece-run-at-time riece-send-delay nil
176                              #'riece-flush-send-queue process)))))
177
178 (defun riece-process-send-string (process string)
179   (with-current-buffer (process-buffer process)
180     (riece-queue-enqueue riece-send-queue string))
181   (riece-flush-send-queue process))
182
183 (defun riece-current-server-name ()
184   (or riece-overriding-server-name
185                                         ;already in the server buffer
186       (if (local-variable-p 'riece-server-name (current-buffer))
187           riece-server-name
188         (if riece-current-channel
189             (riece-identity-server riece-current-channel)
190           (if (riece-server-opened "")
191               "")))))
192
193 (defun riece-send-string (string)
194   (let* ((server-name (riece-current-server-name))
195          (process (riece-server-process server-name)))
196     (unless process
197       (error "%s" (substitute-command-keys
198                    "Type \\[riece-command-open-server] to open server.")))
199     (riece-process-send-string process string)))
200
201 (defun riece-open-server (server server-name)
202   (let ((protocol (or (plist-get server :protocol)
203                       riece-protocol))
204         function
205         process)
206     (condition-case nil
207         (require (intern (concat "riece-" (symbol-name protocol))))
208       (error))
209     (setq function (intern-soft (concat "riece-"
210                                         (symbol-name protocol)
211                                         "-open-server")))
212     (unless function
213       (error "\"%S\" is not supported" protocol))
214     (condition-case nil
215         (setq process (funcall function server server-name))
216       (error))
217     (when process
218       (with-current-buffer (process-buffer process)
219         (make-local-variable 'riece-protocol)
220         (setq riece-protocol protocol))
221       (setq riece-server-process-alist
222             (cons (cons server-name process)
223                   riece-server-process-alist)))))
224
225 (defun riece-quit-server-process (process &optional message)
226   (let ((function (intern-soft
227                    (concat "riece-"
228                            (with-current-buffer (process-buffer process)
229                              (symbol-name riece-protocol))
230                            "-quit-server-process"))))
231     (if function
232         (funcall function process message))))
233
234 (defun riece-reset-process-buffer (process)
235   (save-excursion
236     (set-buffer (process-buffer process))
237     (if (fboundp 'set-buffer-multibyte)
238         (set-buffer-multibyte nil))
239     (kill-all-local-variables)
240     (make-local-variable 'riece-real-nickname)
241     (make-local-variable 'riece-last-nickname)
242     (make-local-variable 'riece-nick-accepted)
243     (make-local-variable 'riece-real-server-name)
244     (make-local-variable 'riece-real-userhost)
245     (make-local-variable 'riece-user-at-host)
246     (make-local-variable 'riece-user-at-host-type)
247     (make-local-variable 'riece-supported-user-modes)
248     (make-local-variable 'riece-supported-channel-modes)
249     (make-local-variable 'riece-channel-filter)
250     (make-local-variable 'riece-server-name)
251     (make-local-variable 'riece-read-point)
252     (setq riece-read-point (point-min))
253     (make-local-variable 'riece-send-queue)
254     (setq riece-send-queue (riece-make-queue))
255     (make-local-variable 'riece-send-size)
256     (setq riece-send-size 0)
257     (make-local-variable 'riece-last-send-time)
258     (setq riece-last-send-time '(0 0 0))
259     (make-local-variable 'riece-obarray)
260     (setq riece-obarray (make-vector riece-obarray-size 0))
261     (make-local-variable 'riece-coding-system)
262     (buffer-disable-undo)
263     (erase-buffer)))
264
265 (defun riece-close-server-process (process)
266   (kill-buffer (process-buffer process))
267   (setq riece-server-process-alist
268         (delq (rassq process riece-server-process-alist)
269               riece-server-process-alist)))
270
271 (defun riece-server-process-opened (process)
272   (not (null (memq (process-status process) '(open run)))))
273
274 (defun riece-server-opened (&optional server-name)
275   (if server-name
276       (let ((process (riece-server-process server-name)))
277         (and process
278              (riece-server-process-opened process)))
279     (let ((alist riece-server-process-alist))
280       (catch 'found
281         (while alist
282           (if (riece-server-process-opened (cdr (car alist)))
283               (throw 'found t))
284           (setq alist (cdr alist)))))))
285
286 (provide 'riece-server)
287
288 ;;; riece-server.el ends here