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