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 riece-default-open-connection-function)
  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-server-parse-string (string)
  66   "Convert a STRING set as `riece-server' and return a property list."
  67   (when (or (string-match "^\\[\\([^]]+\\)\\]:?\\([0-9]*\\)" string)
  68             (string-match "^\\([^:]+\\):?\\([0-9]*\\)" string))
  69     (let ((host (match-string 1 string))
  70           (service (match-string 2 string))
  71           (password (substring string (match-end 0)))
  72           plist)
  73       (setq plist (cons `(:host ,host) plist))
  74       (unless (equal service "")
  75         (setq plist (cons `(:service ,(string-to-int service)) plist)))
  76       (unless (equal password "")
  77         (setq plist (cons `(:password ,(substring password 1)) plist)))
  78       (apply #'nconc plist))))
  79
  80 (defun riece-server-name-to-server (server-name)
  81   (let ((entry (assoc server-name riece-server-alist)))
  82     (if entry
  83         (unless (listp (cdr entry))
  84           (setcdr entry (riece-server-parse-string (cdr entry))))
  85       (setq entry (cons server-name (riece-server-parse-string server-name))
  86             riece-server-alist (cons entry riece-server-alist)
  87             riece-save-variables-are-dirty t))
  88     (cdr entry)))
  89
  90 (defun riece-server-process-name (server-name)
  91   (if (equal server-name "")
  92       "IRC"
  93     (format "IRC<%s>" server-name)))
  94
  95 (defun riece-server-process (server-name)
  96   (cdr (assoc server-name riece-server-process-alist)))
  97
  98 (defmacro riece-with-server-buffer (server-name &rest body)
  99   `(let ((process (riece-server-process ,server-name)))
 100      (if process
 101          (with-current-buffer (process-buffer process)
 102            ,@body)
 103        (error "Server closed"))))
 104
 105 (put 'riece-with-server-buffer 'lisp-indent-function 1)
 106 (put 'riece-with-server-buffer 'edebug-form-spec '(form body))
 107
 108 ;; stolen (and renamed) from time-date.el.
 109 (defun riece-seconds-to-time (seconds)
 110   "Convert SECONDS (a floating point number) to a time value."
 111   (list (floor seconds 65536)
 112         (floor (mod seconds 65536))
 113         (floor (* (- seconds (ffloor seconds)) 1000000))))
 114
 115 ;; stolen (and renamed) from time-date.el.
 116 (defun riece-time-since (time)
 117   "Return the time elapsed since TIME.
 118 TIME should be either a time value or a date-time string."
 119   (let* ((current (current-time))
 120          (rest (when (< (nth 1 current) (nth 1 time))
 121                  (expt 2 16))))
 122     (list (- (+ (car current) (if rest -1 0)) (car time))
 123           (- (+ (or rest 0) (nth 1 current)) (nth 1 time)))))
 124
 125 ;; stolen (and renamed) from time-date.el.
 126 (defun riece-time-less-p (t1 t2)
 127   "Say whether time value T1 is less than time value T2."
 128   (or (< (car t1) (car t2))
 129       (and (= (car t1) (car t2))
 130            (< (nth 1 t1) (nth 1 t2)))))
 131
 132 (defun riece-flush-send-queue (process)
 133   (with-current-buffer (process-buffer process)
 134     (let ((length 0)
 135           string)
 136       (if (riece-time-less-p (riece-seconds-to-time riece-send-delay)
 137                              (riece-time-since riece-last-send-time))
 138           (setq riece-send-size 0))
 139       (while (and riece-send-queue
 140                   (< riece-send-size riece-max-send-size))
 141         (setq string (riece-encode-coding-string (car riece-send-queue))
 142               length (length string))
 143         (if (> length riece-max-send-size)
 144             (message "Long message (%d > %d)" length riece-max-send-size)
 145           (process-send-string process string)
 146           (setq riece-send-size (+ riece-send-size length)))
 147         (setq riece-send-queue (cdr riece-send-queue)))
 148       (if riece-send-queue
 149           (progn
 150             (if riece-debug
 151                 (message "%d bytes sent, %d bytes left"
 152                          riece-send-size
 153                          (apply #'+ (mapcar #'length riece-send-queue))))
 154             ;; schedule next send after a second
 155             (riece-run-at-time riece-send-delay nil
 156                                #'riece-flush-send-queue process))
 157         (if riece-debug
 158             (message "%d bytes sent" riece-send-size)))
 159       (setq riece-last-send-time (current-time)))))
 160
 161 (defun riece-process-send-string (process string)
 162   (with-current-buffer (process-buffer process)
 163     (setq riece-send-queue (nconc riece-send-queue (list string))))
 164   (riece-flush-send-queue process))
 165
 166 (defun riece-current-server-name ()
 167   (or riece-overriding-server-name
 168                                         ;already in the server buffer
 169       (if (local-variable-p 'riece-server-name (current-buffer))
 170           riece-server-name
 171         (if riece-current-channel
 172             (riece-identity-server riece-current-channel)
 173           (if (riece-server-opened "")
 174               "")))))
 175
 176 (defun riece-send-string (string)
 177   (let* ((server-name (riece-current-server-name))
 178          (process (riece-server-process server-name)))
 179     (unless process
 180       (error "%s" (substitute-command-keys
 181                    "Type \\[riece-command-open-server] to open server.")))
 182     (riece-process-send-string process string)))
 183
 184 (defun riece-open-server (server server-name)
 185   (let ((protocol (or (plist-get server :protocol)
 186                       riece-protocol))
 187         function
 188         process)
 189     (condition-case nil
 190         (require (intern (concat "riece-" (symbol-name protocol))))
 191       (error))
 192     (setq function (intern-soft (concat "riece-"
 193                                         (symbol-name protocol)
 194                                         "-open-server")))
 195     (unless function
 196       (error "\"%S\" is not supported" protocol))
 197     (condition-case nil
 198         (setq process (funcall function server server-name))
 199       (error))
 200     (when process
 201       (with-current-buffer (process-buffer process)
 202         (make-local-variable 'riece-protocol)
 203         (setq riece-protocol protocol))
 204       (setq riece-server-process-alist
 205             (cons (cons server-name process)
 206                   riece-server-process-alist)))))
 207
 208 (defun riece-quit-server-process (process &optional message)
 209   (let ((function (intern-soft
 210                    (concat "riece-"
 211                            (with-current-buffer (process-buffer process)
 212                              (symbol-name riece-protocol))
 213                            "-quit-server-process"))))
 214     (if function
 215         (funcall function process message))))
 216
 217 (defun riece-reset-process-buffer (process)
 218   (save-excursion
 219     (set-buffer (process-buffer process))
 220     (if (fboundp 'set-buffer-multibyte)
 221         (set-buffer-multibyte nil))
 222     (kill-all-local-variables)
 223     (make-local-variable 'riece-real-nickname)
 224     (make-local-variable 'riece-last-nickname)
 225     (make-local-variable 'riece-nick-accepted)
 226     (make-local-variable 'riece-real-server-name)
 227     (make-local-variable 'riece-real-userhost)
 228     (make-local-variable 'riece-user-at-host)
 229     (make-local-variable 'riece-user-at-host-type)
 230     (make-local-variable 'riece-supported-user-modes)
 231     (make-local-variable 'riece-supported-channel-modes)
 232     (make-local-variable 'riece-channel-filter)
 233     (make-local-variable 'riece-server-name)
 234     (make-local-variable 'riece-read-point)
 235     (make-local-variable 'riece-send-queue)
 236     (make-local-variable 'riece-last-send-time)
 237     (setq riece-last-send-time '(0 0 0))
 238     (make-local-variable 'riece-send-size)
 239     (setq riece-send-size 0)
 240     (setq riece-read-point (point-min))
 241     (make-local-variable 'riece-obarray)
 242     (setq riece-obarray (make-vector riece-obarray-size 0))
 243     (make-local-variable 'riece-coding-system)
 244     (buffer-disable-undo)
 245     (erase-buffer)))
 246
 247 (defun riece-close-server-process (process)
 248   (kill-buffer (process-buffer process))
 249   (setq riece-server-process-alist
 250         (delq (rassq process riece-server-process-alist)
 251               riece-server-process-alist)))
 252
 253 (defun riece-server-process-opened (process)
 254   (not (null (memq (process-status process) '(open run)))))
 255
 256 (defun riece-server-opened (&optional server-name)
 257   (if server-name
 258       (let ((process (riece-server-process server-name)))
 259         (and process
 260              (riece-server-process-opened process)))
 261     (let ((alist riece-server-process-alist))
 262       (catch 'found
 263         (while alist
 264           (if (riece-server-process-opened (cdr (car alist)))
 265               (throw 'found t))
 266           (setq alist (cdr alist)))))))
 267
 268 (provide 'riece-server)
 269
 270 ;;; riece-server.el ends here