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