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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, 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-cache)
  33 (require 'riece-debug)
  34
  35 (eval-and-compile
  36   (defvar riece-server-keyword-map
  37     '((:host)
  38       (:service 6667)
  39       (:nickname riece-nickname)
  40       (:realname riece-realname)
  41       (:username riece-username)
  42       (:password)
  43       (:function riece-default-open-connection-function)
  44       (:coding riece-default-coding-system))
  45     "Mapping from keywords to default values.
  46 All keywords that can be used must be listed here."))
  47
  48 (defmacro riece-server-keyword-bind (plist &rest body)
  49   "Return a `let' form that binds all variables in PLIST.
  50 After this is done, BODY will be executed in the scope
  51 of the `let' form.
  52
  53 The variables bound and their default values are described by
  54 the `riece-server-keyword-map' variable."
  55   `(let ,(mapcar
  56           (lambda (keyword)
  57             (list (intern (substring (symbol-name (car keyword)) 1))
  58                   (if (cadr keyword)
  59                       `(or (plist-get ,plist ',(car keyword))
  60                            ,(cadr keyword))
  61                     `(plist-get ,plist ',(car keyword)))))
  62           riece-server-keyword-map)
  63      ,@body))
  64
  65 (put 'riece-server-keyword-bind 'lisp-indent-function 1)
  66 (put 'riece-server-keyword-bind 'edebug-form-spec '(form body))
  67
  68 (defun riece-server-parse-string (string)
  69   "Convert a STRING set as `riece-server' and return a property list."
  70   (when (or (string-match "^\\[\\([^]]+\\)\\]:?\\([0-9]*\\)" string)
  71             (string-match "^\\([^:]+\\):?\\([0-9]*\\)" string))
  72     (let ((host (match-string 1 string))
  73           (service (match-string 2 string))
  74           (password (substring string (match-end 0)))
  75           plist)
  76       (setq plist (cons `(:host ,host) plist))
  77       (unless (equal service "")
  78         (setq plist (cons `(:service ,(string-to-number service)) plist)))
  79       (unless (equal password "")
  80         (setq plist (cons `(:password ,(substring password 1)) plist)))
  81       (apply #'nconc plist))))
  82
  83 (defun riece-server-name-to-server (server-name)
  84   (let ((entry (assoc server-name riece-server-alist)))
  85     (if entry
  86         (unless (listp (cdr entry))
  87           (setcdr entry (riece-server-parse-string (cdr entry))))
  88       (setq entry (cons server-name (riece-server-parse-string server-name))
  89             riece-server-alist (cons entry riece-server-alist)
  90             riece-save-variables-are-dirty t))
  91     (cdr entry)))
  92
  93 (defun riece-server-process-name (server-name)
  94   (if (equal server-name "")
  95       "IRC"
  96     (format "IRC<%s>" server-name)))
  97
  98 (defun riece-server-process (server-name)
  99   (cdr (assoc server-name riece-server-process-alist)))
 100
 101 (defmacro riece-with-server-buffer (server-name &rest body)
 102   `(let ((process (riece-server-process ,server-name)))
 103      (if process
 104          (with-current-buffer (process-buffer process)
 105            ,@body)
 106        (error "Server closed"))))
 107
 108 (put 'riece-with-server-buffer 'lisp-indent-function 1)
 109 (put 'riece-with-server-buffer 'edebug-form-spec '(form body))
 110
 111 (defun riece-make-queue ()
 112   "Make a queue object."
 113   (vector nil nil))
 114
 115 (defun riece-queue-enqueue (queue object)
 116   "Add OBJECT to the end of QUEUE."
 117   (if (aref queue 1)
 118       (let ((last (list object)))
 119         (nconc (aref queue 1) last)
 120         (aset queue 1 last))
 121     (aset queue 0 (list object))
 122     (aset queue 1 (aref queue 0))))
 123
 124 (defun riece-queue-dequeue (queue)
 125   "Remove an object from the beginning of QUEUE."
 126   (unless (aref queue 0)
 127     (error "Empty queue"))
 128   (prog1 (car (aref queue 0))
 129     (unless (aset queue 0 (cdr (aref queue 0)))
 130       (aset queue 1 nil))))
 131
 132 (defun riece-queue-empty (queue)
 133   "Return t if QUEUE is empty."
 134   (null (aref queue 0)))
 135
 136 ;; stolen (and renamed) from time-date.el.
 137 (defun riece-seconds-to-time (seconds)
 138   "Convert SECONDS (a floating point number) to a time value."
 139   (list (floor seconds 65536)
 140         (floor (mod seconds 65536))
 141         (floor (* (- seconds (ffloor seconds)) 1000000))))
 142
 143 ;; stolen (and renamed) from time-date.el.
 144 (defun riece-time-less-p (t1 t2)
 145   "Say whether time value T1 is less than time value T2."
 146   (or (< (car t1) (car t2))
 147       (and (= (car t1) (car t2))
 148            (< (nth 1 t1) (nth 1 t2)))))
 149
 150 ;; stolen (and renamed) from time-date.el.
 151 (defun riece-time-since (time)
 152   "Return the time elapsed since TIME."
 153   (let* ((current (current-time))
 154          (rest (when (< (nth 1 current) (nth 1 time))
 155                  (expt 2 16))))
 156     (list (- (+ (car current) (if rest -1 0)) (car time))
 157           (- (+ (or rest 0) (nth 1 current)) (nth 1 time)))))
 158
 159 (defun riece-flush-send-queue (process)
 160   (with-current-buffer (process-buffer process)
 161     (let ((length 0)
 162           string)
 163       (if (riece-time-less-p (riece-seconds-to-time riece-send-delay)
 164                              (riece-time-since riece-last-send-time))
 165           (setq riece-send-size 0))
 166       (while (and (not (riece-queue-empty riece-send-queue))
 167                   (<= riece-send-size riece-max-send-size))
 168         (setq string (riece-queue-dequeue riece-send-queue)
 169               length (length string))
 170         (if (> length riece-max-send-size)
 171             (message "Long message (%d > %d)" length riece-max-send-size)
 172           (setq riece-send-size (+ riece-send-size length))
 173           (when (<= riece-send-size riece-max-send-size)
 174             (process-send-string process string)
 175             (setq riece-last-send-time (current-time)))))
 176       (unless (riece-queue-empty riece-send-queue)
 177         (riece-run-at-time riece-send-delay nil
 178                            (lambda (process)
 179                              (if (riece-server-process-opened process)
 180                                  (riece-flush-send-queue process)))
 181                            process)))))
 182
 183 (defun riece-process-send-string (process string)
 184   (with-current-buffer (process-buffer process)
 185     (riece-queue-enqueue riece-send-queue string))
 186   (riece-flush-send-queue process))
 187
 188 (defun riece-current-server-name ()
 189   (or riece-overriding-server-name
 190                                         ;already in the server buffer
 191       (if (local-variable-p 'riece-server-name (current-buffer))
 192           riece-server-name
 193         (if riece-current-channel
 194             (riece-identity-server riece-current-channel)
 195           (if (riece-server-opened "")
 196               "")))))
 197
 198 (defun riece-send-string (string &optional identity)
 199   (let* ((server-name (if identity
 200                           (riece-identity-server identity)
 201                         (riece-current-server-name)))
 202          (process (riece-server-process server-name)))
 203     (unless process
 204       (error "%s" (substitute-command-keys
 205                    "Type \\[riece-command-open-server] to open server.")))
 206     (riece-process-send-string
 207      process
 208      (with-current-buffer (process-buffer process)
 209        (if identity
 210            (riece-encode-coding-string-for-identity string identity)
 211          (riece-encode-coding-string string))))))
 212
 213 (defun riece-open-server (server server-name)
 214   (let ((protocol (or (plist-get server :protocol)
 215                       riece-protocol))
 216         function
 217         process)
 218     (condition-case nil
 219         (require (intern (concat "riece-" (symbol-name protocol))))
 220       (error))
 221     (setq function (intern-soft (concat "riece-"
 222                                         (symbol-name protocol)
 223                                         "-open-server")))
 224     (unless function
 225       (error "\"%S\" is not supported" protocol))
 226     (setq process (riece-funcall-ignore-errors (symbol-name function)
 227                                                function server server-name))
 228     (when process
 229       (with-current-buffer (process-buffer process)
 230         (make-local-variable 'riece-protocol)
 231         (setq riece-protocol protocol))
 232       (setq riece-server-process-alist
 233             (cons (cons server-name process)
 234                   riece-server-process-alist)))))
 235
 236 (defun riece-quit-server-process (process &optional message)
 237   (let ((function (intern-soft
 238                    (concat "riece-"
 239                            (with-current-buffer (process-buffer process)
 240                              (symbol-name riece-protocol))
 241                            "-quit-server-process"))))
 242     (if function
 243         (funcall function process message))))
 244
 245 (defun riece-reset-process-buffer (process)
 246   (save-excursion
 247     (set-buffer (process-buffer process))
 248     (if (fboundp 'set-buffer-multibyte)
 249         (set-buffer-multibyte nil))
 250     (kill-all-local-variables)
 251     (make-local-variable 'riece-real-nickname)
 252     (make-local-variable 'riece-last-nickname)
 253     (make-local-variable 'riece-nick-accepted)
 254     (make-local-variable 'riece-real-server-name)
 255     (make-local-variable 'riece-real-userhost)
 256     (make-local-variable 'riece-user-at-host)
 257     (make-local-variable 'riece-user-at-host-type)
 258     (make-local-variable 'riece-supported-user-modes)
 259     (make-local-variable 'riece-supported-channel-modes)
 260     (make-local-variable 'riece-channel-filter)
 261     (make-local-variable 'riece-server-name)
 262     (make-local-variable 'riece-read-point)
 263     (setq riece-read-point (point-min))
 264     (make-local-variable 'riece-filter-running)
 265     (make-local-variable 'riece-send-queue)
 266     (setq riece-send-queue (riece-make-queue))
 267     (make-local-variable 'riece-send-size)
 268     (setq riece-send-size 0)
 269     (make-local-variable 'riece-last-send-time)
 270     (setq riece-last-send-time '(0 0 0))
 271     (make-local-variable 'riece-user-obarray)
 272     (setq riece-user-obarray (make-vector riece-user-obarray-size 0))
 273     (make-local-variable 'riece-channel-obarray)
 274     (setq riece-channel-obarray (make-vector riece-channel-obarray-size 0))
 275     (make-local-variable 'riece-coding-system)
 276     (make-local-variable 'riece-channel-cache)
 277     (setq riece-channel-cache (riece-make-cache riece-channel-cache-max-size))
 278     (make-local-variable 'riece-user-cache)
 279     (setq riece-user-cache (riece-make-cache riece-user-cache-max-size))
 280     (buffer-disable-undo)
 281     (erase-buffer)))
 282
 283 (defun riece-close-server-process (process)
 284   (with-current-buffer (process-buffer process)
 285     (run-hooks 'riece-after-close-hook))
 286   (kill-buffer (process-buffer process))
 287   (setq riece-server-process-alist
 288         (delq (rassq process riece-server-process-alist)
 289               riece-server-process-alist)))
 290
 291 (defun riece-server-process-opened (process)
 292   (not (null (memq (process-status process) '(open run)))))
 293
 294 (defun riece-server-opened (&optional server-name)
 295   (if server-name
 296       (let ((process (riece-server-process server-name)))
 297         (and process
 298              (riece-server-process-opened process)))
 299     (let ((alist riece-server-process-alist))
 300       (catch 'found
 301         (while alist
 302           (if (riece-server-process-opened (cdr (car alist)))
 303               (throw 'found t))
 304           (setq alist (cdr alist)))))))
 305
 306 (defun riece-server-properties (server-name)
 307   "Return a list of properties associated with SERVER-NAME."
 308   (if (equal server-name "")
 309       riece-server
 310     (let ((entry (assoc server-name riece-server-alist)))
 311       (unless entry
 312         (error "No such server"))
 313       (cdr entry))))
 314
 315 (provide 'riece-server)
 316
 317 ;;; riece-server.el ends here