X-Git-Url: https://cgit.sxemacs.org/?p=riece;a=blobdiff_plain;f=lisp%2Friece-server.el;h=5c6b420ebc3af47924d88a86314f0aef9343cedb;hp=9a47c35e88e698663164b11eb55cd3b19b1a0da0;hb=585902b534e239ed9089e5f92bd4c6c225fe033c;hpb=5d549325c340600f76a2450177094a3353de432a diff --git a/lisp/riece-server.el b/lisp/riece-server.el index 9a47c35..5c6b420 100644 --- 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-misc) ;riece-process-send-string, etc. (require 'riece-coding) ;riece-default-coding-system (require 'riece-identity) -(require 'riece-display) +(require 'riece-compat) (eval-and-compile (defvar riece-server-keyword-map @@ -38,7 +37,7 @@ (:nickname riece-nickname) (:username riece-username) (:password) - (:function #'open-network-stream) + (: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.")) @@ -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)) -(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) @@ -102,33 +87,80 @@ the `riece-server-keyword-map' variable." riece-save-variables-are-dirty t)) (cdr entry))) -(defun riece-open-server (server &optional server-name) - (if server-name - (message "Connecting to %s..." server-name) - (message "Connecting to IRC server...")) +(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-process-send-string (process string) + (with-current-buffer (process-buffer process) + (process-send-string process (riece-encode-coding-string string)))) + +(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) (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))) + (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) (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 (or password - riece-reconnect-with-password) + (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 + ;; XEmacs signals an error when the keyboard cannot be grabbed. + (condition-case nil + (setq password (riece-read-passwd "Password: ")) + (error)) + (setq riece-reconnect-with-password nil))) + (if password (riece-process-send-string process - (format "PASS %s\r\n" - (or password - (riece-read-passwd - "Password: "))))) + (format "PASS %s\r\n" password))) (riece-process-send-string process (format "USER %s * * :%s\r\n" (user-real-login-name) @@ -139,14 +171,9 @@ the `riece-server-keyword-map' variable." (setq riece-last-nickname riece-real-nickname riece-nick-accepted 'sent riece-coding-system coding)) - (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 %s...done" server-name) - (message "Connecting to IRC server...done"))) + (setq riece-server-process-alist + (cons (cons server-name process) + riece-server-process-alist))))) (defun riece-reset-process-buffer (process) (save-excursion @@ -173,71 +200,45 @@ the `riece-server-keyword-map' variable." (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)) +(defun riece-close-server-process (process) + (if riece-debug + (delete-process process) + (kill-buffer (process-buffer process))) + (setq riece-server-process-alist + (delq (rassq process riece-server-process-alist) + riece-server-process-alist))) -(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-server-process-opened (process) + (not (null (memq (process-status process) '(open run))))) (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))))))) + +(eval-when-compile + (autoload 'riece-exit "riece")) +(defun riece-quit-server-process (process &optional message) + (if riece-quit-timeout + (riece-run-at-time riece-quit-timeout nil + (lambda (process) + (when (rassq process riece-server-process-alist) + (riece-close-server-process process) + ;; If no server process is available, exit. + (unless riece-server-process-alist + (riece-exit)))) + process)) + (riece-process-send-string process + (if message + (format "QUIT :%s\r\n" message) + "QUIT\r\n"))) (provide 'riece-server)