Revised.

[riece] / lisp / riece-server.el

diff --git a/lisp/riece-server.el b/lisp/riece-server.el
index e0d3742..e0ffa28 100644 (file)
--- a/lisp/riece-server.el
+++ b/lisp/riece-server.el
@@ -26,10 +26,9 @@
 
 (require 'riece-options)
 (require 'riece-globals)               ;for server local variables.
 
 (require 'riece-options)
 (require 'riece-globals)               ;for server local variables.

-(require 'riece-misc)                  ;riece-process-send-string, etc.

 (require 'riece-coding)                        ;riece-default-coding-system
 (require 'riece-identity)
 (require 'riece-coding)                        ;riece-default-coding-system
 (require 'riece-identity)

-(require 'riece-display)
+(require 'riece-compat)

 
 (eval-and-compile
   (defvar riece-server-keyword-map
 
 (eval-and-compile
   (defvar riece-server-keyword-map


@@ -38,8 +37,8 @@
       (:nickname riece-nickname)
       (:username riece-username)
       (:password)
       (:nickname riece-nickname)
       (:username riece-username)
       (:password)

-      (:function #'open-network-stream)
-      (:coding-system riece-default-coding-system))
+      (:function riece-default-open-connection-function)
+      (:coding riece-default-coding-system))

     "Mapping from keywords to default values.
 All keywords that can be used must be listed here."))
 
     "Mapping from keywords to default values.
 All keywords that can be used must be listed here."))
 


@@ -63,20 +62,6 @@ the `riece-server-keyword-map' variable."
 (put 'riece-server-keyword-bind 'lisp-indent-function 1)
 (put 'riece-server-keyword-bind 'edebug-form-spec '(form body))
 
 (put 'riece-server-keyword-bind 'lisp-indent-function 1)
 (put 'riece-server-keyword-bind 'edebug-form-spec '(form body))
 

-(defun riece-clear-system ()
-  (while riece-buffer-list
-    (if (and (get-buffer (car riece-buffer-list))
-            (buffer-live-p (car riece-buffer-list)))
-       (funcall riece-buffer-dispose-function (car riece-buffer-list)))
-    (setq riece-buffer-list (cdr riece-buffer-list)))
-  (setq riece-channel-buffer-alist nil
-       riece-user-list-buffer-alist nil
-       riece-current-channels nil
-       riece-current-channel nil
-       riece-channel-indicator "None"
-       riece-channel-list-indicator "No channel")
-  (delete-other-windows))
-

 (defun riece-server-parse-string (string)
   "Convert a STRING set as `riece-server' and return a property list."
   (when (or (string-match "^\\[\\([^]]+\\)\\]:?\\([0-9]*\\)" string)
 (defun riece-server-parse-string (string)
   "Convert a STRING set as `riece-server' and return a property list."
   (when (or (string-match "^\\[\\([^]]+\\)\\]:?\\([0-9]*\\)" string)


@@ -102,50 +87,99 @@ the `riece-server-keyword-map' variable."
            riece-save-variables-are-dirty t))
     (cdr entry)))
 
            riece-save-variables-are-dirty t))
     (cdr entry)))
 

-(defun riece-open-server (server &optional server-name)
-  (if server-name
-      (message "Connecting to IRC server on %s..." server-name)
-    (message "Connecting to IRC server..."))
-  (riece-server-keyword-bind server
-    (let* (selective-display
-          (coding-system-for-read 'binary)
-          (coding-system-for-write 'binary)
-          (process
-           (funcall function "IRC"
-                    (get-buffer-create
-                     (if server-name
-                         (format " *IRC*%s" server-name)
-                       " *IRC*"))
-                    host service)))
-      (riece-reset-process-buffer process)
-      (setq riece-server-name server-name)
-      (set-process-sentinel process 'riece-sentinel)
-      (set-process-filter process 'riece-filter)
-      (if (or password
-             riece-reconnect-with-password)
-         (riece-process-send-string process
-                                    (format "PASS %s\r\n"
-                                            (or password
-                                                (riece-read-passwd
-                                                 "Password: ")))))
-      (riece-process-send-string process
-                                (format "USER %s * * :%s\r\n"
-                                        (user-real-login-name)
-                                        (or username
-                                            "No information given")))
-      (riece-process-send-string process (format "NICK %s\r\n" nickname))
+(defun riece-server-process-name (server-name)
+  (if (equal server-name "")
+      "IRC"
+    (format "IRC<%s>" server-name)))
+
+(defun riece-server-process (server-name)
+  (cdr (assoc server-name riece-server-process-alist)))
+
+(defmacro riece-with-server-buffer (server-name &rest body)
+  `(let ((process (riece-server-process ,server-name)))
+     (if process
+        (with-current-buffer (process-buffer process)
+          ,@body)
+       (error "Server closed"))))
+
+(put 'riece-with-server-buffer 'lisp-indent-function 1)
+(put 'riece-with-server-buffer 'edebug-form-spec '(form body))
+
+(defun riece-flush-send-queue (process reset)
+  (with-current-buffer (process-buffer process)
+    (let ((length 0)
+         string)
+      (if reset
+         (setq riece-send-size 0))
+      (while (and riece-send-queue
+                 (<= riece-send-size riece-max-send-size))
+       (setq string (riece-encode-coding-string (car riece-send-queue))
+             length (length string))
+       (if (> length riece-max-send-size)
+           (message "Long message (%d > %d)" length riece-max-send-size)
+         (setq riece-send-size (+ riece-send-size length))
+         (if (<= riece-send-size riece-max-send-size)
+             (process-send-string process string)))
+       (setq riece-send-queue (cdr riece-send-queue)))
+      (if riece-send-queue
+         (riece-run-at-time riece-send-delay nil
+                            #'riece-flush-send-queue process t)))))
+
+(defun riece-process-send-string (process string)
+  (with-current-buffer (process-buffer process)
+    (setq riece-send-queue (nconc riece-send-queue (list string))))
+  (riece-flush-send-queue process nil))
+
+(defun riece-current-server-name ()
+  (or riece-overriding-server-name
+                                       ;already in the server buffer
+      (if (local-variable-p 'riece-server-name (current-buffer))
+         riece-server-name
+       (if riece-current-channel
+           (riece-identity-server riece-current-channel)
+         (if (riece-server-opened "")
+             "")))))
+
+(defun riece-send-string (string)
+  (let* ((server-name (riece-current-server-name))
+        (process (riece-server-process server-name)))
+    (unless process
+      (error "%s" (substitute-command-keys
+                  "Type \\[riece-command-open-server] to open server.")))
+    (riece-process-send-string process string)))
+
+(defun riece-open-server (server server-name)
+  (let ((protocol (or (plist-get server :protocol)
+                     riece-protocol))
+       function
+       process)
+    (condition-case nil
+       (require (intern (concat "riece-" (symbol-name protocol))))
+      (error))
+    (setq function (intern-soft (concat "riece-"
+                                       (symbol-name protocol)
+                                       "-open-server")))
+    (unless function
+      (error "\"%S\" is not supported" protocol))
+    (condition-case nil
+       (setq process (funcall function server server-name))
+      (error))
+    (when process

       (with-current-buffer (process-buffer process)
       (with-current-buffer (process-buffer process)

-       (setq riece-last-nickname riece-real-nickname
-             riece-nick-accepted 'sent
-             riece-coding-system coding-system))
-      (if server-name
-         (setq riece-server-process-alist
-               (cons (cons server-name process)
-                     riece-server-process-alist))
-       (setq riece-server-process process))))
-  (if server-name
-      (message "Connecting to IRC server on %s...done" server-name)
-    (message "Connecting to IRC server...done")))
+       (make-local-variable 'riece-protocol)
+       (setq riece-protocol protocol))
+      (setq riece-server-process-alist
+           (cons (cons server-name process)
+                 riece-server-process-alist)))))
+
+(defun riece-quit-server-process (process &optional message)
+  (let ((function (intern-soft
+                  (concat "riece-"
+                          (with-current-buffer (process-buffer process)
+                            (symbol-name riece-protocol))
+                          "-quit-server-process"))))
+    (if function
+       (funcall function process message))))

 
 (defun riece-reset-process-buffer (process)
   (save-excursion
 
 (defun riece-reset-process-buffer (process)
   (save-excursion


@@ -166,77 +200,35 @@ the `riece-server-keyword-map' variable."
     (make-local-variable 'riece-server-name)
     (make-local-variable 'riece-read-point)
     (setq riece-read-point (point-min))
     (make-local-variable 'riece-server-name)
     (make-local-variable 'riece-read-point)
     (setq riece-read-point (point-min))

+    (make-local-variable 'riece-send-queue)
+    (make-local-variable 'riece-send-size)
+    (setq riece-send-size 0)

     (make-local-variable 'riece-obarray)
     (setq riece-obarray (make-vector riece-obarray-size 0))
     (make-local-variable 'riece-coding-system)
     (buffer-disable-undo)
     (erase-buffer)))
 
     (make-local-variable 'riece-obarray)
     (setq riece-obarray (make-vector riece-obarray-size 0))
     (make-local-variable 'riece-coding-system)
     (buffer-disable-undo)
     (erase-buffer)))
 

-(defun riece-close-server-process (process &optional quit-message)
-  (if (eq 'riece-filter (process-filter process))
-      (set-process-filter process nil))
-  (if (eq 'riece-sentinel (process-sentinel process))
-      (set-process-sentinel process nil))
-  (when (memq (process-status process) '(open run))
-    (riece-process-send-string process
-                              (if quit-message
-                                  (format "QUIT :%s\r\n" quit-message)
-                                "QUIT\r\n"))
-    (unless riece-debug
-      (kill-buffer (process-buffer process))))
-  (delete-process process))
-
-(eval-when-compile
-  (autoload 'riece-exit "riece"))
-(defun riece-close-server (server-name &optional quit-message)
-  ;; Remove channels which belong to the server.
-  (let ((riece-overriding-server-name server-name)
-       (channels riece-current-channels))
-    (while channels
-      (if (and (car channels)
-              (equal (riece-identity-server (car channels))
-                     server-name))
-         (riece-part-channel (car channels)))
-      (setq channels (cdr channels)))
-    (riece-redisplay-buffers))
-  ;; Close now.
-  (let (process)
-    (if server-name
-       (let ((entry (assoc server-name riece-server-process-alist)))
-         (setq process (cdr entry)
-               riece-server-process-alist
-               (delq entry riece-server-process-alist)))
-      (setq process riece-server-process
-           riece-server-process nil))
-    (riece-close-server-process process quit-message)
-    ;; If no server process is available, exit.
-    (if (and (null riece-server-process)
-            (null riece-server-process-alist))
-       (riece-exit))))
-
-(defun riece-close-all-server (&optional quit-message)
-  (let ((process-list
-        (delq nil (cons riece-server-process
-                        (mapcar #'cdr riece-server-process-alist)))))
-    (while process-list
-      (riece-close-server-process (car process-list) quit-message)
-      (setq process-list (cdr process-list)))
-    (setq riece-server-process nil
-         riece-server-process-alist nil)
-    (riece-exit)))
+(defun riece-close-server-process (process)
+  (kill-buffer (process-buffer process))
+  (setq riece-server-process-alist
+       (delq (rassq process riece-server-process-alist)
+             riece-server-process-alist)))
+
+(defun riece-server-process-opened (process)
+  (not (null (memq (process-status process) '(open run)))))

 
 (defun riece-server-opened (&optional server-name)
 
 (defun riece-server-opened (&optional server-name)

-  (let ((processes
-        (delq nil
-              (if server-name
-                  (cdr (assoc server-name riece-server-process-alist))
-                (cons riece-server-process
-                      (mapcar #'cdr riece-server-process-alist))))))
-    (catch 'found
-      (while processes
-       (if (memq (process-status (car processes)) '(open run))
-           (throw 'found t))
-       (setq processes (cdr processes))))))
+  (if server-name
+      (let ((process (riece-server-process server-name)))
+       (and process
+            (riece-server-process-opened process)))
+    (let ((alist riece-server-process-alist))
+      (catch 'found
+       (while alist
+         (if (riece-server-process-opened (cdr (car alist)))
+             (throw 'found t))
+         (setq alist (cdr alist)))))))

 
 (provide 'riece-server)
 
 
 (provide 'riece-server)