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