4d5b2449a4629ff0aa90d16bed2ed293714bd3cd
[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-misc)                   ;riece-process-send-string, etc.
30 (require 'riece-coding)                 ;riece-default-coding-system
31 (require 'riece-identity)
32 (require 'riece-display)
33
34 (eval-and-compile
35   (defvar riece-server-keyword-map
36     '((:host)
37       (:service 6667)
38       (:nickname riece-nickname)
39       (:username riece-username)
40       (:password)
41       (:function #'open-network-stream)
42       (:coding-system riece-default-coding-system))
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-start-server (server &optional server-name)
67   "Open network stream to remote irc server.
68 If optional argument CONFIRM is non-nil, ask the host that the server
69 is running on."
70   (if server-name
71       (message "Connecting to IRC server on %s..." server-name)
72     (message "Connecting to IRC server..."))
73   (prog1 (riece-open-server server server-name)
74     (if server-name
75         (message "Connecting to IRC server on %s...done" server-name)
76       (message "Connecting to IRC server...done"))))
77
78 (defun riece-clear-system ()
79   (while riece-buffer-list
80     (if (and (get-buffer (car riece-buffer-list))
81              (buffer-live-p (car riece-buffer-list)))
82         (funcall riece-buffer-dispose-function (car riece-buffer-list)))
83     (setq riece-buffer-list (cdr riece-buffer-list)))
84   (setq riece-channel-buffer-alist nil
85         riece-user-list-buffer-alist nil
86         riece-current-channels nil
87         riece-current-channel nil
88         riece-channel-indicator "None"
89         riece-channel-list-indicator "No channel")
90   (delete-other-windows))
91
92 (defun riece-server-parse-string (string)
93   "Convert a STRING set as `riece-server' and return a property list."
94   (when (or (string-match "^\\[\\([^]]+\\)\\]:?\\([0-9]*\\)" string)
95             (string-match "^\\([^:]+\\):?\\([0-9]*\\)" string))
96     (let ((host (match-string 1 string))
97           (service (match-string 2 string))
98           (password (substring string (match-end 0)))
99           plist)
100       (setq plist (cons `(:host ,host) plist))
101       (unless (equal service "")
102         (setq plist (cons `(:service ,(string-to-int service)) plist)))
103       (unless (equal password "")
104         (setq plist (cons `(:password ,(substring password 1)) plist)))
105       (apply #'nconc plist))))
106
107 (defun riece-server-name-to-server (server-name)
108   (let ((entry (assoc server-name riece-server-alist)))
109     (if entry
110         (unless (listp (cdr entry))
111           (setcdr entry (riece-server-parse-string (cdr entry))))
112       (setq entry (cons server-name (riece-server-parse-string server-name))
113             riece-server-alist (cons entry riece-server-alist)
114             riece-save-variables-are-dirty t))
115     (cdr entry)))
116
117 (defun riece-open-server (server server-name)
118   "Open chat server on HOST.
119 If HOST is nil, use value of environment variable \"IRCSERVER\".
120 If optional argument SERVICE is non-nil, open by the service name."
121   (riece-server-keyword-bind server
122     (let* (selective-display
123            (coding-system-for-read 'binary)
124            (coding-system-for-write 'binary)
125            (process
126             (funcall function "IRC" (if server-name
127                                         (format " *IRC*%s" server-name)
128                                       " *IRC*")
129                      host service)))
130       (riece-reset-process-buffer process)
131       (set-process-sentinel process 'riece-sentinel)
132       (set-process-filter process 'riece-filter)
133       (if (or password
134               riece-reconnect-with-password)
135           (riece-process-send-string process
136                                      (format "PASS %s\r\n"
137                                              (or password
138                                                  (riece-read-passwd
139                                                   "Password: ")))))
140       (setq riece-reconnect-with-password nil)
141       (riece-process-send-string process
142                                  (format "USER %s * * :%s\r\n"
143                                          (user-real-login-name)
144                                          (or username
145                                              "No information given")))
146       (riece-process-send-string process (format "NICK %s\r\n" nickname))
147       (with-current-buffer (process-buffer process)
148         (setq riece-last-nickname riece-real-nickname
149               riece-nick-accepted 'sent
150               riece-coding-system coding-system))
151       process)))
152
153 (defun riece-reset-process-buffer (process)
154   (save-excursion
155     (set-buffer (process-buffer process))
156     (if (fboundp 'set-buffer-multibyte)
157         (set-buffer-multibyte nil))
158     (kill-all-local-variables)
159     (make-local-variable 'riece-real-nickname)
160     (make-local-variable 'riece-last-nickname)
161     (make-local-variable 'riece-nick-accepted)
162     (make-local-variable 'riece-real-server-name)
163     (make-local-variable 'riece-real-userhost)
164     (make-local-variable 'riece-user-at-host)
165     (make-local-variable 'riece-user-at-host-type)
166     (make-local-variable 'riece-supported-user-modes)
167     (make-local-variable 'riece-supported-channel-modes)
168     (make-local-variable 'riece-channel-filter)
169     (make-local-variable 'riece-server-name)
170     (make-local-variable 'riece-read-point)
171     (setq riece-read-point (point-min))
172     (make-local-variable 'riece-obarray)
173     (setq riece-obarray (make-vector riece-obarray-size 0))
174     (make-local-variable 'riece-coding-system)
175     (buffer-disable-undo)
176     (erase-buffer)))
177
178 (defun riece-close-server-process (process &optional quit-message)
179   (if (eq 'riece-filter (process-filter process))
180       (set-process-filter process nil))
181   (if (eq 'riece-sentinel (process-sentinel process))
182       (set-process-sentinel process nil))
183   (when (memq (process-status process) '(open run))
184     (riece-process-send-string process
185                                (if quit-message
186                                    (format "QUIT :%s\r\n" quit-message)
187                                  "QUIT\r\n"))
188     (delete-process process)
189     (unless riece-debug
190       (kill-buffer (process-buffer process)))))
191
192 (eval-when-compile
193   (autoload 'riece-exit "riece"))
194 (defun riece-close-server (server-name &optional quit-message)
195   ;; Remove channels which belong to the server.
196   (let ((riece-overriding-server-name server-name)
197         (channels riece-current-channels))
198     (while channels
199       (if (equal (riece-identity-server (car channels))
200                  server-name)
201           (riece-part-channel (car channels)))
202       (setq channels (cdr channels)))
203     (riece-redisplay-buffers))
204   ;; Close now.
205   (let (process)
206     (if server-name
207         (let ((entry (assoc server-name riece-server-process-alist)))
208           (setq process (cdr entry)
209                 riece-server-process-alist
210                 (delq entry riece-server-process-alist)))
211       (setq process riece-server-process
212             riece-server-process nil))
213     (riece-close-server-process process quit-message)
214     ;; If no server process is available, exit.
215     (if (and (null riece-server-process)
216              (null riece-server-process-alist))
217         (riece-exit))))
218
219 (defun riece-close-all-server (&optional quit-message)
220   (let ((process-list
221          (delq nil (cons riece-server-process
222                          (mapcar #'cdr riece-server-process-alist)))))
223     (while process-list
224       (riece-close-server-process (car process-list) quit-message)
225       (setq process-list (cdr process-list)))
226     (setq riece-server-process nil
227           riece-server-process-alist nil)
228     (riece-exit)))
229
230 (defun riece-server-opened (&optional server-name)
231   (let ((processes
232          (delq nil
233                (if server-name
234                    (cdr (assoc server-name riece-server-process-alist))
235                  (cons riece-server-process
236                        (mapcar #'cdr riece-server-process-alist))))))
237     (catch 'found
238       (while processes
239         (if (memq (process-status (car processes)) '(open run))
240             (throw 'found t))
241         (setq processes (cdr processes))))))
242
243 (provide 'riece-server)
244
245 ;;; riece-server.el ends here