3d6e3668388fc5310a065194c8acb32998890c7a
[riece] / 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
31 (eval-and-compile
32   (defvar riece-server-keyword-map
33     '((:host)
34       (:service 6667)
35       (:nickname riece-nickname)
36       (:username riece-username)
37       (:password)
38       (:function #'open-network-stream)
39       (:coding riece-default-coding-system))
40     "Mapping from keywords to default values.
41 All keywords that can be used must be listed here."))
42
43 (defmacro riece-server-keyword-bind (plist &rest body)
44   "Return a `let' form that binds all variables in PLIST.
45 After this is done, BODY will be executed in the scope
46 of the `let' form.
47
48 The variables bound and their default values are described by
49 the `riece-server-keyword-map' variable."
50   `(let ,(mapcar
51           (lambda (keyword)
52             (list (intern (substring (symbol-name (car keyword)) 1))
53                   (if (cadr keyword)
54                       `(or (plist-get ,plist ',(car keyword))
55                            ,(cadr keyword))
56                     `(plist-get ,plist ',(car keyword)))))
57           riece-server-keyword-map)
58      ,@body))
59
60 (put 'riece-server-keyword-bind 'lisp-indent-function 1)
61 (put 'riece-server-keyword-bind 'edebug-form-spec '(form body))
62
63 (defun riece-clear-system ()
64   (while riece-buffer-list
65     (if (and (get-buffer (car riece-buffer-list))
66              (buffer-live-p (car riece-buffer-list)))
67         (funcall riece-buffer-dispose-function (car riece-buffer-list)))
68     (setq riece-buffer-list (cdr riece-buffer-list)))
69   (setq riece-current-channels nil
70         riece-current-channel nil
71         riece-user-indicator nil
72         riece-channel-indicator "None"
73         riece-channel-list-indicator "No channel"
74         riece-away-indicator "-"
75         riece-operator-indicator "-"
76         riece-freeze-indicator "-")
77   (delete-other-windows))
78
79 (defun riece-server-parse-string (string)
80   "Convert a STRING set as `riece-server' and return a property list."
81   (when (or (string-match "^\\[\\([^]]+\\)\\]:?\\([0-9]*\\)" string)
82             (string-match "^\\([^:]+\\):?\\([0-9]*\\)" string))
83     (let ((host (match-string 1 string))
84           (service (match-string 2 string))
85           (password (substring string (match-end 0)))
86           plist)
87       (setq plist (cons `(:host ,host) plist))
88       (unless (equal service "")
89         (setq plist (cons `(:service ,(string-to-int service)) plist)))
90       (unless (equal password "")
91         (setq plist (cons `(:password ,(substring password 1)) plist)))
92       (apply #'nconc plist))))
93
94 (defun riece-server-name-to-server (server-name)
95   (let ((entry (assoc server-name riece-server-alist)))
96     (if entry
97         (unless (listp (cdr entry))
98           (setcdr entry (riece-server-parse-string (cdr entry))))
99       (setq entry (cons server-name (riece-server-parse-string server-name))
100             riece-server-alist (cons entry riece-server-alist)
101             riece-save-variables-are-dirty t))
102     (cdr entry)))
103
104 (defun riece-server-process-name (server-name)
105   (if (equal server-name "")
106       "IRC"
107     (format "IRC<%s>" server-name)))
108
109 (defun riece-server-process (server-name)
110   (get-process (riece-server-process-name server-name)))
111
112 (defmacro riece-with-server-buffer (server-name &rest body)
113   `(let ((process (riece-server-process ,server-name)))
114      (if process
115          (with-current-buffer (process-buffer process)
116            ,@body)
117        (error "Server closed"))))
118
119 (put 'riece-with-server-buffer 'lisp-indent-function 1)
120
121 (defun riece-process-send-string (process string)
122   (with-current-buffer (process-buffer process)
123     (process-send-string process (riece-encode-coding-string string))))
124
125 (defun riece-send-string (string)
126   (let* ((server-name
127           (or riece-overriding-server-name
128                                         ;already in the server buffer
129               (if (local-variable-p 'riece-server-name (current-buffer))
130                   riece-server-name
131                 (if riece-current-channel
132                     (riece-identity-server riece-current-channel)
133                   (if (riece-server-opened "")
134                       "")))))
135          (process (riece-server-process server-name)))
136     (unless process
137       (error "%s" (substitute-command-keys
138                    "Type \\[riece-command-open-server] to open server.")))
139     (riece-process-send-string process string)))
140
141 (defun riece-open-server (server server-name)
142   (if (equal server-name "")
143       (message "Connecting to IRC server...")
144     (message "Connecting to %s..." server-name))
145   (riece-server-keyword-bind server
146     (let* (selective-display
147            (coding-system-for-read 'binary)
148            (coding-system-for-write 'binary)
149            (process
150             (funcall function (riece-server-process-name server-name)
151                      (concat " *IRC*" server-name)
152                      host service)))
153       (riece-reset-process-buffer process)
154       (with-current-buffer (process-buffer process)
155         (setq riece-server-name server-name))
156       (set-process-sentinel process 'riece-sentinel)
157       (set-process-filter process 'riece-filter)
158       (if (or password
159               riece-reconnect-with-password)
160           (riece-process-send-string process
161                                      (format "PASS %s\r\n"
162                                              (or password
163                                                  (riece-read-passwd
164                                                   "Password: ")))))
165       (riece-process-send-string process
166                                  (format "USER %s * * :%s\r\n"
167                                          (user-real-login-name)
168                                          (or username
169                                              "No information given")))
170       (riece-process-send-string process (format "NICK %s\r\n" nickname))
171       (with-current-buffer (process-buffer process)
172         (setq riece-last-nickname riece-real-nickname
173               riece-nick-accepted 'sent
174               riece-coding-system coding))
175       (setq riece-process-list
176             (cons process riece-process-list))))
177   (if (equal server-name "")
178       (message "Connecting to IRC server...done")
179     (message "Connecting to %s...done" server-name)))
180
181 (defun riece-reset-process-buffer (process)
182   (save-excursion
183     (set-buffer (process-buffer process))
184     (if (fboundp 'set-buffer-multibyte)
185         (set-buffer-multibyte nil))
186     (kill-all-local-variables)
187     (make-local-variable 'riece-real-nickname)
188     (make-local-variable 'riece-last-nickname)
189     (make-local-variable 'riece-nick-accepted)
190     (make-local-variable 'riece-real-server-name)
191     (make-local-variable 'riece-real-userhost)
192     (make-local-variable 'riece-user-at-host)
193     (make-local-variable 'riece-user-at-host-type)
194     (make-local-variable 'riece-supported-user-modes)
195     (make-local-variable 'riece-supported-channel-modes)
196     (make-local-variable 'riece-channel-filter)
197     (make-local-variable 'riece-server-name)
198     (make-local-variable 'riece-read-point)
199     (setq riece-read-point (point-min))
200     (make-local-variable 'riece-obarray)
201     (setq riece-obarray (make-vector riece-obarray-size 0))
202     (make-local-variable 'riece-coding-system)
203     (buffer-disable-undo)
204     (erase-buffer)))
205
206 (defun riece-close-server-process (process)
207   (if riece-debug
208       (delete-process process)
209     (kill-buffer (process-buffer process)))
210   (setq riece-process-list (delq process riece-process-list)))
211
212 (defun riece-server-opened (&optional server-name)
213   (let ((process-list riece-process-list))
214     (catch 'found
215       (while process-list
216         (if (memq (process-status (car process-list)) '(open run))
217             (throw 'found t))
218         (setq process-list (cdr process-list))))))
219
220 (defun riece-quit-server-process (process &optional message)
221   (run-at-time riece-quit-timeout nil
222                (lambda (process)
223                  (if (memq process riece-process-list)
224                      (kill-process (process-buffer process))))
225                process)
226   (riece-process-send-string process
227                              (if message
228                                  (format "QUIT :%s\r\n" message)
229                                "QUIT\r\n")))
230
231 (provide 'riece-server)
232
233 ;;; riece-server.el ends here