Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv18335
Modified Files: application.lisp message-display.lisp presentations.lisp receivers.lisp Log Message: make beirc's current-nickname handling use the current connection's nickname.
--- /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 16:33:46 1.43 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 19:55:55 1.44 @@ -71,7 +71,6 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) ((connection-processes :initform nil :accessor connection-processes) - (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) (server-receivers :initform nil :reader server-receivers) @@ -140,6 +139,12 @@ (pushnew (cons connection newval) (slot-value frame 'connection-processes) :key #'car :test #'connection=))
+(defmethod current-nickname (&optional (connection (current-connection *application-frame*))) + (let ((user (when connection + (irc:user connection)))) + (when user + (irc:nickname user)))) + (defvar *gui-process* nil)
(defvar *beirc-frame*) @@ -152,7 +157,7 @@ seconds (format t "~2,'0D:~2,'0D ~A on ~A~@[ speaking to ~A~]~100T~D messages" hours minutes - (slot-value *application-frame* 'nick) + (current-nickname) (current-channel) (current-query) (length (current-messages)))))) @@ -264,9 +269,9 @@ (clim-sys:destroy-process ticker-process) (disconnect-all frame "Client Quit"))))))))
-(defun message-directed-to-me-p (frame message) +(defun message-directed-to-me-p (message) (irc:destructuring-arguments (&last body) message - (let ((my-nick (slot-value frame 'nick))) + (let ((my-nick (current-nickname (irc:connection message)))) (search my-nick (or body "")))))
(defun interesting-message-p (message) @@ -278,7 +283,7 @@ (unless (eql receiver (current-receiver frame)) (when (interesting-message-p message) (incf (unseen-messages receiver))) - (when (message-directed-to-me-p frame message) + (when (message-directed-to-me-p message) (incf (messages-directed-to-me receiver))) (incf (all-unseen-messages receiver))) (update-drawing-options receiver) @@ -361,8 +366,8 @@ (switch-to-pane (nth (1- position) list-of-panes) 'tab-layout-pane)))))
(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) - (when (eql receiver (server-receiver *application-frame*)) - (error "Can't close the server tab for this application!")) + (when (member receiver (server-receivers *application-frame*) :key #'cdr) + (error "Don't know how to close server tabs. Sorry.")) (let* ((connection (current-connection *application-frame*)) (channel (irc:find-channel connection (title receiver)))) (when channel @@ -371,19 +376,19 @@
(define-beirc-command (com-close-inactive-queries :name t) () (let ((receivers-to-close nil)) - (maphash (lambda (name receiver) - (declare (ignore name)) - (when (and (not (member receiver (server-receivers *application-frame*) :key #'cdr)) - (not (eql receiver (current-receiver *application-frame*))) - (= 0 - (unseen-messages receiver) (all-unseen-messages receiver) - (messages-directed-to-me receiver)) - (null (irc:find-channel (connection receiver) (title receiver))) - (> (- (get-universal-time) (last-visited receiver)) *max-query-inactive-time*)) - (push receiver receivers-to-close))) - (receivers *application-frame*)) - (loop for receiver in receivers-to-close - do (remove-receiver receiver *application-frame*)))) + (maphash (lambda (name receiver) + (declare (ignore name)) + (when (and (not (member receiver (server-receivers *application-frame*) :key #'cdr)) + (not (eql receiver (current-receiver *application-frame*))) + (= 0 + (unseen-messages receiver) (all-unseen-messages receiver) + (messages-directed-to-me receiver)) + (null (irc:find-channel (connection receiver) (title receiver))) + (> (- (get-universal-time) (last-visited receiver)) *max-query-inactive-time*)) + (push receiver receivers-to-close))) + (receivers *application-frame*)) + (loop for receiver in (remove-duplicates receivers-to-close) + do (remove-receiver receiver *application-frame*))))
(define-beirc-command (com-part :name t) () (irc:part (current-connection *application-frame*) @@ -428,7 +433,7 @@ pathname))))
(defun make-fake-irc-message (message-type &key command arguments - (source (slot-value *application-frame* 'nick)) + (source (current-nickname)) trailing-argument) (make-instance message-type :received-time (get-universal-time) @@ -533,7 +538,6 @@ (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))
(define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick")) - (setf (slot-value *application-frame* 'nick) new-nick) ;This is _not_ the way to do it. (irc:nick (current-connection *application-frame*) new-nick))
(define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url")) @@ -741,7 +745,6 @@ (unwind-protect (progn (setf (irc:client-stream connection) (make-broadcast-stream)) - (setf (slot-value *application-frame* 'nick) nick) (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server) (find-pane-named frame 'query)) (tab-layout:remove-pane (find-pane-named frame 'server) @@ -766,8 +769,7 @@ (not (eql (clim-sys:current-process) (connection-process frame connection)))) (destroy-process (connection-process frame connection))) - (setf (connection-process frame connection) nil - (slot-value frame 'nick) nil)) + (setf (connection-process frame connection) nil))
(defun disconnect-all (frame reason) (loop for (conn . receiver) in (server-receivers frame) @@ -838,14 +840,20 @@ (defclass beirc-connection (irc:connection) ())
-;;; KLUDGE: "why isn't this an :around method," you ask? CL-IRC's -;;; read-message registers the message's content before passing the -;;; message back, which means that QUIT and NICK messages can not be -;;; meaningfully decoded, with respect to: on which channels was the -;;; user before we got the message (so that we can display it -;;; everywhere it is relevant). -;;; So, this method is basically a copy of IRC:READ-MESSAGE. ugh. +(defmethod preprocess-message ((connection beirc-connection) (message irc:irc-nick-message)) + (when (string= (irc:normalize-nickname connection (current-nickname)) + (irc:normalize-nickname connection (irc:source message))) + (setf (irc:nickname (irc:user (irc:connection message))) + (car (last (irc:arguments message))) + + (irc:normalized-nickname (irc:user (irc:connection message))) + (irc:normalize-nickname connection (car (last (irc:arguments message))))))) + +(defmethod preprocess-message (connection message) + nil) + (defmethod irc::irc-message-event :around ((connection beirc-connection) message) + (preprocess-message connection message) (post-message *application-frame* message) (call-next-method))
--- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 17:26:56 1.35 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 19:55:56 1.36 @@ -5,6 +5,8 @@
(defvar *max-preamble-length* 0)
+(defvar *current-message*) + (define-presentation-type url () :inherit-from 'string)
@@ -37,7 +39,8 @@ :test #'string=))
(defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer) - (let* ((stream* (if (eql stream t) *standard-output* stream)) + (let* ((*current-message* message) + (stream* (if (eql stream t) *standard-output* stream)) (width (- (floor (bounding-rectangle-width (sheet-parent stream*)) (clim:stream-string-width stream* "X")) 2))) @@ -115,7 +118,7 @@ ((or (search "http://" word%) (search "https://" word%)) (present-url word%)) ((or - (nick-equals-my-nick-p word%) + (nick-equals-my-nick-p word% (irc:connection *current-message*)) (and (current-connection *application-frame*) (irc:find-user (current-connection *application-frame*) word%))) (present word% 'nickname)) @@ -418,7 +421,7 @@
(defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) - (1 (formatting-message (t message receiver) + (2 (formatting-message (t message receiver) ((format t " ")) ((irc:destructuring-arguments (channel 1c-mode) message (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/02/25 15:22:22 1.9 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/02/25 19:55:56 1.10 @@ -75,30 +75,29 @@ ;;; nicknames
(define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) - (with-slots (connection nick) *application-frame* - (let ((users (let ((channel (and (not (null (current-channel))) - (irc:find-channel connection (current-channel))))) - (if (not (null channel)) - (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))))) - (accept `(or (member ,@users) string) :prompt nil)))) + (let* ((connection (current-connection *application-frame*)) + (users (let ((channel (and (not (null (current-channel))) + (irc:find-channel connection (current-channel))))) + (if (not (null channel)) + (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))))) + (accept `(or (member ,@users) string) :prompt nil)))
(define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key) (with-slots (ignored-nicks) *application-frame* (accept `(member ,@ignored-nicks) :prompt nil)))
-(defun nick-equals-my-nick-p (nickname) - (and (not (null *application-frame*)) - (not (null (current-connection *application-frame*))) - (equal (irc:normalize-nickname (current-connection *application-frame*) - (slot-value *application-frame* 'nick)) - (irc:normalize-nickname (current-connection *application-frame*) - nickname)))) +(defun nick-equals-my-nick-p (nickname connection) + (and (not (null connection)) + (equal (current-nickname connection) + (irc:normalize-nickname connection nickname))))
(define-presentation-method present (o (type unhighlighted-nickname) *standard-output* (view textual-view) &key) (write-string o))
(define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key) - (if (nick-equals-my-nick-p o) + (if (nick-equals-my-nick-p o (if (boundp '*current-message*) + (irc:connection *current-message*) + (current-connection *application-frame*))) (with-drawing-options (t :ink +darkgreen+) (with-text-face (t :bold) (write-string o))) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 15:22:22 1.17 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 19:55:56 1.18 @@ -86,7 +86,8 @@ receiver)))))
(defun remove-receiver (receiver frame) - (remove-pane (tab-pane receiver) (find-pane-named frame 'query)) + (tab-layout:remove-pane (tab-pane receiver) + (find-pane-named frame 'query)) (remhash (title receiver) (receivers frame)))
(defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "") @@ -99,24 +100,23 @@ "NOTICE message targets that should be treated as network service targets.")
-(defun nickname-comparator (frame) +(defun nickname-comparator (connection) (lambda (nick1 nick2) - (string= (irc:normalize-nickname (current-connection frame) nick1) - (irc:normalize-nickname (current-connection frame) nick2)))) + (string= (irc:normalize-nickname connection nick1) + (irc:normalize-nickname connection nick2))))
-(defun from-network-service-p (source frame) +(defun from-network-service-p (source connection) (member source *network-service-sources* - :test (nickname-comparator frame))) + :test (nickname-comparator connection)))
-(defun global-notice-p (message target frame) +(defun global-notice-p (message target) (and (typep message 'irc:irc-notice-message) (member target *global-notice-targets* - :test (nickname-comparator frame)))) + :test (nickname-comparator (irc:connection message)))))
(macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) - (let* ((mynick (irc:normalize-nickname (current-connection frame) - (slot-value frame 'nick))) + (let* ((mynick (current-nickname (irc:connection message))) (nominal-target (irc:normalize-channel-name (irc:connection message) (first (irc:arguments message)))) (target (if (equal nominal-target mynick) @@ -124,8 +124,8 @@ nominal-target))) (cond ((find-receiver target (irc:connection message) frame) (intern-receiver target (irc:connection message) frame :channel target)) - ((or (global-notice-p message nominal-target frame) - (and (from-network-service-p (irc:source message) frame) + ((or (global-notice-p message nominal-target) + (and (from-network-service-p (irc:source message) (irc:connection message)) (equal nominal-target mynick))) (server-receiver frame (irc:connection message))) (t @@ -175,13 +175,13 @@ (let ((target (first (irc:arguments message)))) (if (and (null (find-receiver target (irc:connection message) frame)) - (string= (irc:source message) (slot-value frame 'nick))) + (string= (irc:source message) (current-nickname (irc:connection message)))) (server-receiver frame (irc:connection message)) ; don't re-open previously closed channels. (intern-receiver target (irc:connection message) frame :channel target))))
(defmethod receiver-for-message ((message irc:irc-mode-message) frame) (case (length (irc:arguments message)) - (1 (server-receiver frame (irc:connection message))) + (2 (server-receiver frame (irc:connection message))) (t (destructuring-bind (channel modes &rest args) (irc:arguments message) (declare (ignore modes args)) (intern-receiver channel (irc:connection message) frame :channel channel)))))