[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Andreas Fuchs
afuchs at common-lisp.net
Fri Sep 23 21:31:41 UTC 2005
Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv25178
Modified Files:
beirc.lisp message-display.lisp
Log Message:
baby steps towards a server buffer.
* don't register hook functions into cl-irc anymore, just catch all
of them and tries to print them in a mostly sensible manner in the
*Server* buffer.
* doesn't actually display the messages, as redisplay is broken, for
only the Server buffer.
* requires cl-irc cvs patched with
http://common-lisp.net/pipermail/cl-irc-devel/2005-September/000061.html
anybody who can fix the redisplay issue is welcome to do so (-:
Date: Fri Sep 23 23:31:39 2005
Author: afuchs
Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.14 beirc/beirc.lisp:1.15
--- beirc/beirc.lisp:1.14 Fri Sep 23 21:05:15 2005
+++ beirc/beirc.lisp Fri Sep 23 23:31:27 2005
@@ -80,34 +80,57 @@
for found-pane = (actual-application-pane child)
if found-pane do (return found-pane))))
-(defmethod initialize-instance :after ((object receiver) &rest initargs)
- (declare (ignore initargs))
- (setf (slot-value object 'pane)
- (with-look-and-feel-realization
- ((frame-manager *application-frame*) *application-frame*)
- (make-clim-application-pane
- :display-function
- (lambda (frame pane)
- (beirc-app-display frame pane object))
- :display-time nil
- :width 400 :height 600
- :incremental-redisplay t)))
- (setf (slot-value object 'tab-pane)
- (make-tab-pane-from-list (title object) (pane object) 'receiver)))
-
-(defun make-receiver (name &rest initargs)
- (let ((receiver (apply 'make-instance 'receiver :title name initargs)))
- receiver))
+;;; another KLUDGE: define-application-frame-defined panes (as
+;;; find-pane-named returns them) /don't/ come wrapped - they are
+;;; stored as the application pane itself. Of course, tab-layout
+;;; /expects/ them wrapped, so we recurse through the parents to find
+;;; the granddaughter of a tab-layout-pane.
+(defun direct-tab-pane-child-from (pane)
+ "Given a pane, find the parent pane that is the direct child of
+a tab-layout-pane's radio-layout-pane."
+ (labels ((has-parent-p (pane) (and (typep pane 'clim:sheet-parent-mixin)
+ (not (null (sheet-parent pane)))))
+ (grandparent (pane)
+ (if (and (has-parent-p pane) (has-parent-p (sheet-parent pane)))
+ (sheet-parent (sheet-parent pane)))))
+ (cond
+ ((typep (grandparent pane) 'tab-layout-pane) pane)
+ ((has-parent-p pane) (direct-tab-pane-child-from (sheet-parent pane)))
+ (t nil))))
+
+(defun make-paneless-receiver (name &rest initargs)
+ (apply 'make-instance 'receiver :title name initargs))
+
+(defun initialize-receiver-with-pane (receiver frame pane &key (add-pane-p t))
+ (setf (slot-value receiver 'pane) pane)
+ (if (not add-pane-p)
+ (setf (slot-value receiver 'tab-pane)
+ (find-in-tab-panes-list (direct-tab-pane-child-from pane)
+ 'tab-layout-pane))
+ (progn
+ (setf (slot-value receiver 'tab-pane)
+ (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver))
+ (add-pane (tab-pane receiver) (find-pane-named frame 'query))))
+ (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver))
(defun intern-receiver (name frame &rest initargs)
- (let ((rec (gethash name (receivers frame))))
+ (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name)
+ (receivers frame))))
(if rec
rec
(let ((*application-frame* frame))
- (let ((receiver (apply 'make-receiver name initargs)))
- (add-pane (tab-pane receiver) (find-pane-named frame 'query))
+ (let ((receiver (apply 'make-paneless-receiver name initargs)))
+ (initialize-receiver-with-pane receiver frame
+ (with-look-and-feel-realization
+ ((frame-manager *application-frame*) *application-frame*)
+ (make-clim-application-pane
+ :display-function
+ (lambda (frame pane)
+ (beirc-app-display frame pane receiver))
+ :display-time nil
+ :width 400 :height 600
+ :incremental-redisplay t)))
(setf (gethash name (receivers frame)) receiver)
- (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)
receiver)))))
(macrolet ((define-privmsg-receiver-lookup (message-type)
@@ -122,7 +145,8 @@
(intern-receiver target frame :channel target)))))
(define-privmsg-receiver-lookup irc:irc-privmsg-message)
(define-privmsg-receiver-lookup irc:ctcp-action-message)
- (define-privmsg-receiver-lookup irc:irc-notice-message))
+ ;; (define-privmsg-receiver-lookup irc:irc-notice-message) ; XXX: NOTICEs in freenode are a bit tricky.
+ )
(macrolet ((define-global-message-receiver-lookup (message-type)
`(defmethod receiver-for-message ((message ,message-type) frame)
@@ -139,6 +163,10 @@
(defmethod receiver-for-message ((message irc:irc-part-message) frame)
(let ((target (first (irc:arguments message))))
(intern-receiver target frame :channel target)))
+
+(defmethod receiver-for-message ((message irc:irc-message) frame)
+ (server-receiver frame))
+
;; TODO: more receiver-for-message methods.
(macrolet ((define-delegate (function-name accessor &optional define-setter-p)
@@ -156,7 +184,7 @@
(define-delegate current-focused-nicks focused-nicks t))
(defun update-drawing-options (receiver)
- (set-drawing-options-for-pane-in-tab-layout (pane receiver)
+ (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver))
`(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+)
((> (unseen-messages receiver) 0) +red+)
(t +black+)))))
@@ -174,7 +202,7 @@
(defun raise-receiver (receiver)
(setf (unseen-messages receiver) 0)
(setf (messages-directed-to-me receiver) 0)
- (switch-to-pane (pane receiver) 'tab-layout-pane))
+ (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane))
;;; KLUDGE: workaround for mcclim bug "Application pane vertical
;;; scrolling does not work with table formatting"
@@ -194,6 +222,7 @@
(nick :initform nil)
(ignored-nicks :initform nil)
(receivers :initform (make-hash-table :test #'equal) :accessor receivers)
+ (server-receiver :initform (make-paneless-receiver "*Server*") :reader server-receiver)
(tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers))
(:panes
(io
@@ -210,22 +239,25 @@
:foreground +white+)
(server
:application
- ;; TODO: server message display.
- ))
+ :display (lambda (frame pane)
+ (beirc-app-display frame pane (server-receiver *application-frame*)))
+ :display-time :command-loop
+ :width 400
+ :height 600
+ :incremental-redisplay t))
(:geometry :width 800 :height 600)
(:top-level (clim:default-frame-top-level :prompt 'beirc-prompt))
(:layouts
(default
(vertically ()
(with-tab-layout ('receiver :name 'query)
- ("Server" server))
+ ("*Server*" server))
(60 io)
(20 ;<-- Sigh! Bitrot!
- status-bar )))))
+ status-bar)))))
(defun receiver-from-tab-pane (tab-pane)
- (gethash tab-pane
- (tab-panes-to-receivers *application-frame*)))
+ (gethash tab-pane (tab-panes-to-receivers *application-frame*)))
(defmethod current-receiver ((frame beirc))
(let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)))))
@@ -339,7 +371,6 @@
(setf (messages receiver)
(append (messages receiver) (list message)))
(unless (eql receiver (current-receiver frame))
- (print "hallo" *debug-io*)
(incf (unseen-messages receiver))
(when (message-directed-to-me-p frame message)
(incf (messages-directed-to-me receiver))))
@@ -364,8 +395,9 @@
(define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key)
(with-slots (connection nick) *application-frame*
- (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))
- (accept `(member , at users) :prompt nil))))
+ (let ((users (unless (null (current-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*
@@ -491,12 +523,15 @@
(format *query-io* "You are already connected.~%"))
(t
(setf (slot-value *application-frame* 'connection)
- (irc:connect :nickname nick :server server))
+ (irc:connect :nickname nick :server server :connection-type 'beirc-connection))
(setf (irc:client-stream (current-connection *application-frame*))
(make-broadcast-stream))
(setf (slot-value *application-frame* 'nick) nick)
(let ((connection (current-connection *application-frame*)))
(let ((frame *application-frame*))
+ (initialize-receiver-with-pane (server-receiver frame) frame
+ (find-pane-named frame 'server)
+ :add-pane-p nil)
(clim-sys:make-process #'(lambda ()
(irc-event-loop frame connection))
:name "IRC Message Muffling Loop") )))))
@@ -553,24 +588,18 @@
; (finish-output *trace-output*)
nil)
+(defclass beirc-connection (irc:connection)
+ ())
+
+(defmethod irc:read-message :around ((connection beirc-connection))
+ (let ((message (call-next-method connection)))
+ (post-message *application-frame* message)
+ message))
+
(defun irc-event-loop (frame connection)
(unwind-protect
- (progn
- (irc:add-hook connection 'irc:irc-privmsg-message
- (lambda (m) (post-message frame m)))
- (irc:add-hook connection 'irc:irc-nick-message
- (lambda (m) (post-message frame m)))
- (irc:add-hook connection 'irc:irc-part-message
- (lambda (m) (post-message frame m)))
- (irc:add-hook connection 'irc:irc-quit-message
- (lambda (m) (post-message frame m)))
- (irc:add-hook connection 'irc:irc-join-message
- (lambda (m) (post-message frame m)))
- (irc:add-hook connection 'irc:irc-ping-message
- (lambda (m) (process-message frame m)))
- (irc:add-hook connection 'cl-irc:ctcp-action-message
- (lambda (m) (post-message frame m)))
- (irc:read-message-loop connection) )
+ (let ((*application-frame* frame))
+ (irc:read-message-loop connection))
(irc:remove-all-hooks connection)))
;;; Hack:
Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.4 beirc/message-display.lisp:1.5
--- beirc/message-display.lisp:1.4 Fri Sep 23 11:52:40 2005
+++ beirc/message-display.lisp Fri Sep 23 23:31:27 2005
@@ -101,7 +101,7 @@
(incf column))
(terpri))
-(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
+(defun print-privmsg-like-message (message receiver start-string end-string)
(with-drawing-options
(*standard-output*
:ink (if (string-equal "localhost" (irc:host message))
@@ -112,10 +112,16 @@
(*standard-output*
(if (message-from-focused-nick-p message receiver) :bold :roman))
(formatting-message (t message receiver)
- ((format t "<")
- (present (irc:source message) 'nickname)
- (format t ">"))
- ((format-message* (irc:trailing-argument message))))))))
+ ((write-string start-string *standard-output*)
+ (present (irc:source message) 'nickname)
+ (write-string end-string *standard-output*))
+ ((format-message* (irc:trailing-argument message))))))))
+
+(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver)
+ (print-privmsg-like-message message receiver "<" ">"))
+
+(defmethod print-message ((message irc:IRC-NOTICE-MESSAGE) receiver)
+ (print-privmsg-like-message message receiver "-" "-"))
(defmethod print-message ((message irc:ctcp-action-message) receiver)
(let ((source (cl-irc:source message))
@@ -161,6 +167,11 @@
(present (irc:source message) 'nickname)
(format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
+(defmethod print-message (message receiver)
+ (formatting-message (t message receiver)
+ ((format t "!!! ~A" (irc:source message)))
+ ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
+ (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))
(defgeneric preamble-length (message)
(:method ((message irc:irc-privmsg-message))
More information about the Beirc-cvs
mailing list