* configure.ac: Generate lisp/riece-package-info.el.

[riece] / lisp / riece-server.el

diff --git a/lisp/riece-server.el b/lisp/riece-server.el
index bac3c99..5a0db11 100644 (file)
--- a/lisp/riece-server.el
+++ b/lisp/riece-server.el
@@ -19,8 +19,8 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the

-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.

 
 ;;; Code:
 
 
 ;;; Code:
 


@@ -29,18 +29,18 @@
 (require 'riece-coding)                        ;riece-default-coding-system
 (require 'riece-identity)
 (require 'riece-compat)
 (require 'riece-coding)                        ;riece-default-coding-system
 (require 'riece-identity)
 (require 'riece-compat)

-(require 'riece-filter)
+(require 'riece-cache)

 
 (eval-and-compile
   (defvar riece-server-keyword-map
     '((:host)
       (:service 6667)
       (:nickname riece-nickname)
 
 (eval-and-compile
   (defvar riece-server-keyword-map
     '((:host)
       (:service 6667)
       (:nickname riece-nickname)

+      (:realname riece-realname)

       (:username riece-username)
       (:password)
       (:function riece-default-open-connection-function)
       (:username riece-username)
       (:password)
       (:function riece-default-open-connection-function)

-      (:coding riece-default-coding-system)
-      (:protocol))
+      (: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."))
 


@@ -74,7 +74,7 @@ the `riece-server-keyword-map' variable."
          plist)
       (setq plist (cons `(:host ,host) plist))
       (unless (equal service "")
          plist)
       (setq plist (cons `(:host ,host) plist))
       (unless (equal service "")

-       (setq plist (cons `(:service ,(string-to-int service)) plist)))
+       (setq plist (cons `(:service ,(string-to-number service)) plist)))

       (unless (equal password "")
        (setq plist (cons `(:password ,(substring password 1)) plist)))
       (apply #'nconc plist))))
       (unless (equal password "")
        (setq plist (cons `(:password ,(substring password 1)) plist)))
       (apply #'nconc plist))))


@@ -107,9 +107,82 @@ the `riece-server-keyword-map' variable."
 (put 'riece-with-server-buffer 'lisp-indent-function 1)
 (put 'riece-with-server-buffer 'edebug-form-spec '(form body))
 
 (put 'riece-with-server-buffer 'lisp-indent-function 1)
 (put 'riece-with-server-buffer 'edebug-form-spec '(form body))
 

+(defun riece-make-queue ()
+  "Make a queue object."
+  (vector nil nil))
+
+(defun riece-queue-enqueue (queue object)
+  "Add OBJECT to the end of QUEUE."
+  (if (aref queue 1)
+      (let ((last (list object)))
+       (nconc (aref queue 1) last)
+       (aset queue 1 last))
+    (aset queue 0 (list object))
+    (aset queue 1 (aref queue 0))))
+
+(defun riece-queue-dequeue (queue)
+  "Remove an object from the beginning of QUEUE."
+  (unless (aref queue 0)
+    (error "Empty queue"))
+  (prog1 (car (aref queue 0))
+    (unless (aset queue 0 (cdr (aref queue 0)))
+      (aset queue 1 nil))))
+
+(defun riece-queue-empty (queue)
+  "Return t if QUEUE is empty."
+  (null (aref queue 0)))
+
+;; stolen (and renamed) from time-date.el.
+(defun riece-seconds-to-time (seconds)
+  "Convert SECONDS (a floating point number) to a time value."
+  (list (floor seconds 65536)
+       (floor (mod seconds 65536))
+       (floor (* (- seconds (ffloor seconds)) 1000000))))
+
+;; stolen (and renamed) from time-date.el.
+(defun riece-time-less-p (t1 t2)
+  "Say whether time value T1 is less than time value T2."
+  (or (< (car t1) (car t2))
+      (and (= (car t1) (car t2))
+          (< (nth 1 t1) (nth 1 t2)))))
+
+;; stolen (and renamed) from time-date.el.
+(defun riece-time-since (time)
+  "Return the time elapsed since TIME."
+  (let* ((current (current-time))
+        (rest (when (< (nth 1 current) (nth 1 time))
+                (expt 2 16))))
+    (list (- (+ (car current) (if rest -1 0)) (car time))
+         (- (+ (or rest 0) (nth 1 current)) (nth 1 time)))))
+
+(defun riece-flush-send-queue (process)
+  (with-current-buffer (process-buffer process)
+    (let ((length 0)
+         string)
+      (if (riece-time-less-p (riece-seconds-to-time riece-send-delay)
+                            (riece-time-since riece-last-send-time))
+         (setq riece-send-size 0))
+      (while (and (not (riece-queue-empty riece-send-queue))
+                 (<= riece-send-size riece-max-send-size))
+       (setq string (riece-queue-dequeue 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))
+         (when (<= riece-send-size riece-max-send-size)
+           (process-send-string process string)
+           (setq riece-last-send-time (current-time)))))
+      (unless (riece-queue-empty riece-send-queue)
+       (riece-run-at-time riece-send-delay nil
+                          (lambda (process)
+                            (if (riece-server-process-opened process)
+                                (riece-flush-send-queue process)))
+                          process)))))
+

 (defun riece-process-send-string (process string)
   (with-current-buffer (process-buffer process)
 (defun riece-process-send-string (process string)
   (with-current-buffer (process-buffer process)

-    (process-send-string process (riece-encode-coding-string string))))
+    (riece-queue-enqueue riece-send-queue string))
+  (riece-flush-send-queue process))

 
 (defun riece-current-server-name ()
   (or riece-overriding-server-name
 
 (defun riece-current-server-name ()
   (or riece-overriding-server-name


@@ -121,74 +194,53 @@ the `riece-server-keyword-map' variable."
          (if (riece-server-opened "")
              "")))))
 
          (if (riece-server-opened "")
              "")))))
 

-(defun riece-send-string (string)
-  (let* ((server-name (riece-current-server-name))
+(defun riece-send-string (string &optional identity)
+  (let* ((server-name (if identity
+                         (riece-identity-server identity)
+                       (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.")))
         (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)))
+    (riece-process-send-string
+     process
+     (with-current-buffer (process-buffer process)
+       (if identity
+          (riece-encode-coding-string-for-identity string identity)
+        (riece-encode-coding-string string))))))

 
 

-(eval-when-compile
-  (autoload 'riece-exit "riece"))

 (defun riece-open-server (server server-name)
 (defun riece-open-server (server server-name)

-  (riece-server-keyword-bind server
-    (let (selective-display
-         (coding-system-for-read 'binary)
-         (coding-system-for-write 'binary)
-         process)
-      (if (equal server-name "")
-         (message "Connecting to IRC server...")
-       (message "Connecting to %s..." server-name))
-      (setq process
-           (funcall function (riece-server-process-name server-name)
-                    (concat " *IRC*" server-name)
-                    host service))
-      (if (equal server-name "")
-         (message "Connecting to IRC server...done")
-       (message "Connecting to %s...done" server-name))
-      (riece-reset-process-buffer process)
+  (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-server-name server-name))
-      (set-process-sentinel process 'riece-sentinel)
-      (set-process-filter process 'riece-filter)
-      (if (equal server-name "")
-         (message "Logging in to IRC server...")
-       (message "Logging in to %s..." server-name))
-      (if riece-reconnect-with-password        ;password incorrect or not set.
-         (unwind-protect
-             (setq password
-                   (condition-case nil
-                       (let (inhibit-quit)
-                         (if (equal server-name "")
-                             (riece-read-passwd "Password: ")
-                           (riece-read-passwd (format "Password for %s: "
-                                                      server-name))))
-                     (quit
-                      (if (equal server-name "")
-                          (message "Password: Quit")
-                        (message (format "Password for %s: Quit"
-                                         server-name)))
-                      'quit)))
-           (setq riece-reconnect-with-password nil)))
-      (if (eq password 'quit)
-         (delete-process process)
-       (if password
-           (riece-process-send-string process
-                                      (format "PASS %s\r\n" 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))
-       (with-current-buffer (process-buffer process)
-         (setq riece-last-nickname riece-real-nickname
-               riece-nick-accepted 'sent
-               riece-coding-system coding))
-       (setq riece-server-process-alist
-             (cons (cons server-name process)
-                   riece-server-process-alist))))))
+       (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


@@ -209,13 +261,28 @@ 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-obarray)
-    (setq riece-obarray (make-vector riece-obarray-size 0))
+    (make-local-variable 'riece-filter-running)
+    (make-local-variable 'riece-send-queue)
+    (setq riece-send-queue (riece-make-queue))
+    (make-local-variable 'riece-send-size)
+    (setq riece-send-size 0)
+    (make-local-variable 'riece-last-send-time)
+    (setq riece-last-send-time '(0 0 0))
+    (make-local-variable 'riece-user-obarray)
+    (setq riece-user-obarray (make-vector riece-user-obarray-size 0))
+    (make-local-variable 'riece-channel-obarray)
+    (setq riece-channel-obarray (make-vector riece-channel-obarray-size 0))

     (make-local-variable 'riece-coding-system)
     (make-local-variable 'riece-coding-system)

+    (make-local-variable 'riece-channel-cache)
+    (setq riece-channel-cache (riece-make-cache riece-channel-cache-max-size))
+    (make-local-variable 'riece-user-cache)
+    (setq riece-user-cache (riece-make-cache riece-user-cache-max-size))

     (buffer-disable-undo)
     (erase-buffer)))
 
 (defun riece-close-server-process (process)
     (buffer-disable-undo)
     (erase-buffer)))
 
 (defun riece-close-server-process (process)

+  (with-current-buffer (process-buffer process)
+    (run-hooks 'riece-after-close-hook))

   (kill-buffer (process-buffer process))
   (setq riece-server-process-alist
        (delq (rassq process riece-server-process-alist)
   (kill-buffer (process-buffer process))
   (setq riece-server-process-alist
        (delq (rassq process riece-server-process-alist)


@@ -236,17 +303,14 @@ the `riece-server-keyword-map' variable."
              (throw 'found t))
          (setq alist (cdr alist)))))))
 
              (throw 'found t))
          (setq alist (cdr alist)))))))
 

-(defun riece-quit-server-process (process &optional message)
-  (if riece-quit-timeout
-      (riece-run-at-time riece-quit-timeout nil
-                        (lambda (process)
-                          (if (rassq process riece-server-process-alist)
-                              (delete-process process)))
-                        process))
-  (riece-process-send-string process
-                            (if message
-                                (format "QUIT :%s\r\n" message)
-                              "QUIT\r\n")))
+(defun riece-server-properties (server-name)
+  "Return a list of properties associated with SERVER-NAME."
+  (if (equal server-name "")
+      riece-server
+    (let ((entry (assoc server-name riece-server-alist)))
+      (unless entry
+       (error "No such server"))
+      (cdr entry))))

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