[beirc-cvs] CVS beirc
afuchs
afuchs at common-lisp.net
Sat Feb 25 19:55:56 UTC 2006
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 , at 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 , at 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 , at 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)))))
More information about the Beirc-cvs
mailing list