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