September 2005 - beirc-cvs@common-lisp.net

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv12043 Modified Files: beirc.lisp Log Message: add /part and better /close functionality. * /part exits the current channel and leaves the receiver intact. * /close closes the receiver and parts the channel (if the closed receiver is a channel). The part message from a closed channel goes to the server buffer. Date: Sat Sep 24 19:39:36 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.23 beirc/beirc.lisp:1.24 --- beirc/beirc.lisp:1.23 Sat Sep 24 19:28:38 2005 +++ beirc/beirc.lisp Sat Sep 24 19:39:36 2005 @@ -178,7 +178,11 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) - (intern-receiver target frame :channel target))) + (if (and + (null (find-receiver target frame)) + (string= (irc:source message) (slot-value frame 'nick))) + (server-receiver frame) ; don't re-open previously closed channels. + (intern-receiver target frame :channel target)))) (defmethod receiver-for-message ((message irc:irc-mode-message) frame) (case (length (irc:arguments message)) @@ -497,7 +501,15 @@ (raise-receiver receiver)) (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) + (let* ((connection (current-connection *application-frame*)) + (channel (irc:find-channel connection (title receiver)))) + (when channel + (irc:part connection channel))) (remove-receiver receiver *application-frame*)) + +(define-beirc-command (com-part :name t) () + (irc:part (current-connection *application-frame*) + (title (current-receiver *application-frame*)))) (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) (pushnew who (current-focused-nicks) :test #'string=))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv11001 Modified Files: beirc.lisp message-display.lisp Log Message: * refactor message faking * fix display of irc-MODE-messages that deal with user modes * rework /topic to display the topic if no string is passed * add presentation type CHANNEL and an accept method so that /join doesn't do stupid things anymore on empty input. * add minimal receiver closing functionality. Date: Sat Sep 24 19:28:38 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.22 beirc/beirc.lisp:1.23 --- beirc/beirc.lisp:1.22 Sat Sep 24 17:04:06 2005 +++ beirc/beirc.lisp Sat Sep 24 19:28:38 2005 @@ -121,6 +121,10 @@ (setf (gethash name (receivers frame)) receiver) receiver))))) +(defun remove-receiver (receiver frame) + (remove-pane (tab-pane receiver) (find-pane-named frame 'query)) + (remhash (title receiver) (receivers frame))) + (defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "") "Sources whose private messages (PRIVMSG, NOTICE, ...) should be treated as if they came from the connected server itself, @@ -177,9 +181,11 @@ (intern-receiver target frame :channel target))) (defmethod receiver-for-message ((message irc:irc-mode-message) frame) - (destructuring-bind (channel modes args) (irc:arguments message) - (declare (ignore modes args)) - (intern-receiver channel frame :channel channel))) + (case (length (irc:arguments message)) + (1 (server-receiver frame)) + (3 (destructuring-bind (channel modes args) (irc:arguments message) + (declare (ignore modes args)) + (intern-receiver channel frame :channel channel))))) (macrolet ((define-ignore-message-types (&rest mtypes) `(progn @@ -244,7 +250,6 @@ ;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" - (defclass redisplay-frame-mixin () ()) @@ -469,12 +474,31 @@ (format t "~A" o))) (format t "~A" o))) +(define-presentation-type channel () :inherit-from 'string) + +(define-presentation-method presentation-typep (object (type channel)) + (channelp object)) + +(defun channelp (channel) + (and (stringp channel) + (> (length channel) 2) + (not (null (member (char channel 0) '(#\# #\+ #\! #\&)))))) + +(define-presentation-method accept ((type channel) *standard-input* (view textual-view) &key) + (let ((channel (accept 'string :view view :prompt nil))) + (if (not (presentation-typep channel 'channel)) + (input-not-of-required-type channel 'channel) + channel))) + (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) (raise-receiver (intern-receiver nick *application-frame* :query nick))) (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) +(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) + (remove-receiver receiver *application-frame*)) + (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) (pushnew who (current-focused-nicks) :test #'string=)) @@ -495,8 +519,30 @@ (when (eql status :external) (apply symbol (current-connection *application-frame*) (coerce args 'list))))) -(define-beirc-command (com-topic :name t) ((topic 'mumble :prompt "topic")) - (irc:topic- (current-connection *application-frame*) (target) topic)) +(defun make-fake-irc-message (message-type &key command arguments + (source (slot-value *application-frame* 'nick)) + trailing-argument) + (make-instance message-type + :received-time (get-universal-time) + :connection :local + :trailing-argument trailing-argument + :arguments arguments + :command command + :HOST "localhost" + :USER "localuser" + :SOURCE source)) + +(define-beirc-command (com-topic :name t) (&key (topic 'mumble :prompt "New topic")) + (if (and (not (string= topic ""))) + (irc:topic- (current-connection *application-frame*) (target) topic) + (post-message *application-frame* + (make-fake-irc-message 'irc:irc-rpl_topic-message + :command "332" + :arguments `("=" ,(target)) + :trailing-argument (irc:topic + (irc:find-channel + (current-connection *application-frame*) + (target))))))) (define-beirc-command (com-op :name t) ((who 'nickname :prompt "who")) (irc:op (current-connection *application-frame*) (target) who)) @@ -523,16 +569,10 @@ (define-beirc-command (com-say :name t) ((what 'mumble)) ;; make a fake IRC-PRIV-MESSAGE object (post-message *application-frame* - (make-instance 'irc:irc-privmsg-message - :received-time (get-universal-time) - :connection :local - :trailing-argument what - :arguments (list (target)) - :command "PRIVMSG" - :HOST "localhost" - :USER "localuser" - :SOURCE (slot-value *application-frame* 'nick) - )) + (make-fake-irc-message 'irc:irc-privmsg-message + :trailing-argument what + :arguments (list (target)) + :command "PRIVMSG")) (irc:privmsg (current-connection *application-frame*) (target) what)) (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick")) @@ -581,7 +621,7 @@ (presentation) (list (presentation-object presentation))) -(define-beirc-command (com-join :name t) ((channel 'string :prompt "channel")) +(define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) (raise-receiver (intern-receiver channel *application-frame* :channel channel)) (irc:join (current-connection *application-frame*) channel)) @@ -609,26 +649,18 @@ :name "IRC Message Muffling Loop")) ))))) (defun disconnect (frame) - (let ((old-nickname (slot-value frame 'nick))) - (raise-receiver (server-receiver frame)) - (post-message frame - (make-instance 'irc:irc-quit-message - :received-time (get-universal-time) - :connection :local - :trailing-argument - (format nil "You disconnected from IRC") - :arguments nil - :command "QUIT" - :host "localhost" ;### - :user "localuser" ;### - :source old-nickname)) - (when (and (connection-process frame) - (not (eql (clim-sys:current-process) - (connection-process frame)))) - (destroy-process (connection-process frame))) - (setf (slot-value frame 'connection) nil - (connection-process frame) nil - (slot-value frame 'nick) nil))) + (raise-receiver (server-receiver frame)) + (post-message frame + (make-fake-irc-message 'irc:irc-quit-message + :trailing-argument "You disconnected from IRC" + :command "QUIT")) + (when (and (connection-process frame) + (not (eql (clim-sys:current-process) + (connection-process frame)))) + (destroy-process (connection-process frame))) + (setf (slot-value frame 'connection) nil + (connection-process frame) nil + (slot-value frame 'nick) nil)) (defun quit (frame reason) (raise-receiver (server-receiver frame)) @@ -725,32 +757,22 @@ (write-char (read-char) bag))))))) (define-beirc-command (com-me :name t) ((what 'mumble)) - (with-slots (connection nick) *application-frame* - (let ((m (make-instance 'irc:ctcp-action-message - :received-time (get-universal-time) - :connection :local - :trailing-argument - (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) - :arguments (list (target)) - :command "PRIVMSG" - :host "localhost" ;### - :user "localuser" ;### - :source nick))) ;### + (with-slots (connection) *application-frame* + (let ((m (make-fake-irc-message 'irc:ctcp-action-message + :trailing-argument + (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) + :arguments (list (target)) + :command "PRIVMSG"))) ;### (post-message *application-frame* m) (irc:privmsg connection (target) (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))) (defun send-private-message (target what) (post-message *application-frame* - (make-instance 'irc:irc-privmsg-message - :received-time (get-universal-time) - :connection :local - :trailing-argument what - :arguments (list target) - :command "PRIVMSG" - :HOST "localhost" - :USER "localuser" - :SOURCE (slot-value *application-frame* 'nick) )) + (make-fake-irc-message 'irc:irc-privmsg-message + :trailing-argument what + :arguments (list target) + :command "PRIVMSG")) (irc:privmsg (current-connection *application-frame*) target what)) (define-beirc-command (com-msg :name t) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.9 beirc/message-display.lisp:1.10 --- beirc/message-display.lisp:1.9 Sat Sep 24 17:04:06 2005 +++ beirc/message-display.lisp Sat Sep 24 19:28:38 2005 @@ -206,13 +206,20 @@ (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) (defmethod print-message ((message irc:irc-mode-message) receiver) - (destructuring-bind (target modes args) (irc:arguments message) - (declare (ignore target)) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (format-message* (format nil " set mode ~A ~A" modes args))))))) + (case (length (irc:arguments message)) + (1 (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A set mode ~A ~A" (irc:source message) + (irc:trailing-argument message) + (first (irc:arguments message)))))))) + (3 (destructuring-bind (target modes args) (irc:arguments message) + (declare (ignore target)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (format-message* (format nil " set mode ~A ~A" modes args))))))))) (defmethod print-message ((message irc:irc-rpl_motd-message) receiver) (formatting-message (t message receiver)

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv1363 Modified Files: beirc.lisp message-display.lisp Log Message: further printing / command features: * don't print "end of <anything>" replies from the server. * add a /topic, /names, /op, /deop command. * add a method to print irc-mode-messages. Date: Sat Sep 24 17:04:07 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.21 beirc/beirc.lisp:1.22 --- beirc/beirc.lisp:1.21 Sat Sep 24 16:36:31 2005 +++ beirc/beirc.lisp Sat Sep 24 17:04:06 2005 @@ -176,6 +176,34 @@ (let ((target (first (irc:arguments message)))) (intern-receiver target frame :channel target))) +(defmethod receiver-for-message ((message irc:irc-mode-message) frame) + (destructuring-bind (channel modes args) (irc:arguments message) + (declare (ignore modes args)) + (intern-receiver channel frame :channel channel))) + +(macrolet ((define-ignore-message-types (&rest mtypes) + `(progn + ,@(loop for mtype in mtypes + collect `(defmethod receiver-for-message ((message ,mtype) frame) + nil))))) + (define-ignore-message-types cl-irc:irc-rpl_endofwhowas-message + cl-irc:irc-rpl_endoflinks-message + cl-irc:irc-rpl_endoptions-message + cl-irc:irc-rpl_endofwhois-message + cl-irc:irc-rpl_endsitelist-message + cl-irc:irc-rpl_endofinvitelist-message + cl-irc:irc-rpl_endofservices-message + cl-irc:irc-rpl_endmode-message + cl-irc:irc-rpl_endofmap-message + cl-irc:irc-rpl_endofnames-message + cl-irc:irc-rpl_endofusers-message + cl-irc:irc-rpl_endofbanlist-message + cl-irc:irc-rpl_endofmotd-message + cl-irc:irc-rpl_endofinfo-message + cl-irc:irc-rpl_endofstats-message + cl-irc:irc-rpl_endofwho-message + cl-irc:irc-rpl_endofexceptlist-message)) + (defmethod receiver-for-message ((message irc:irc-message) frame) (server-receiver frame)) @@ -463,9 +491,21 @@ (define-beirc-command (com-eval :name t) ((command 'string :prompt "command") (args '(sequence string) :prompt "arguments")) - (multiple-value-bind (symbol status) (find-symbol command :irc) + (multiple-value-bind (symbol status) (find-symbol (string-upcase command) :irc) (when (eql status :external) (apply symbol (current-connection *application-frame*) (coerce args 'list))))) + +(define-beirc-command (com-topic :name t) ((topic 'mumble :prompt "topic")) + (irc:topic- (current-connection *application-frame*) (target) topic)) + +(define-beirc-command (com-op :name t) ((who 'nickname :prompt "who")) + (irc:op (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who")) + (irc:deop (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-names :name t) () + (irc:names (current-connection *application-frame*) (target))) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.8 beirc/message-display.lisp:1.9 --- beirc/message-display.lisp:1.8 Sat Sep 24 16:36:31 2005 +++ beirc/message-display.lisp Sat Sep 24 17:04:06 2005 @@ -205,6 +205,15 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) +(defmethod print-message ((message irc:irc-mode-message) receiver) + (destructuring-bind (target modes args) (irc:arguments message) + (declare (ignore target)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (format-message* (format nil " set mode ~A ~A" modes args))))))) + (defmethod print-message ((message irc:irc-rpl_motd-message) receiver) (formatting-message (t message receiver) ((format t "~A" (irc:source message)))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv31756 Modified Files: beirc.lisp message-display.lisp Log Message: Handle printing of the server's MOTD. Add an /Eval command to debug cl-irc commands. Date: Sat Sep 24 16:36:32 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.20 beirc/beirc.lisp:1.21 --- beirc/beirc.lisp:1.20 Sat Sep 24 13:43:37 2005 +++ beirc/beirc.lisp Sat Sep 24 16:36:31 2005 @@ -461,6 +461,12 @@ (setf (current-focused-nicks) (remove who (current-focused-nicks) :test #'string=))) +(define-beirc-command (com-eval :name t) ((command 'string :prompt "command") + (args '(sequence string) :prompt "arguments")) + (multiple-value-bind (symbol status) (find-symbol command :irc) + (when (eql status :external) + (apply symbol (current-connection *application-frame*) (coerce args 'list))))) + (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) (quit *application-frame* reason)) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.7 beirc/message-display.lisp:1.8 --- beirc/message-display.lisp:1.7 Sat Sep 24 11:14:03 2005 +++ beirc/message-display.lisp Sat Sep 24 16:36:31 2005 @@ -205,6 +205,12 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) +(defmethod print-message ((message irc:irc-rpl_motd-message) receiver) + (formatting-message (t message receiver) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "MOTD: ~A" (irc:trailing-argument message)))))) + (defmethod print-message (message receiver) (formatting-message (t message receiver) ((format t "!!! ~A" (irc:source message)))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv19320 Modified Files: beirc.lisp Log Message: fix NOTICE handling, including network service notices. also, revert the TICKER function back to its old self; the handler-case in there served no purpose. Date: Sat Sep 24 13:43:37 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.19 beirc/beirc.lisp:1.20 --- beirc/beirc.lisp:1.19 Sat Sep 24 11:14:03 2005 +++ beirc/beirc.lisp Sat Sep 24 13:43:37 2005 @@ -97,13 +97,17 @@ (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) +(defun find-receiver (name frame) + (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) + (receivers frame))) + (defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) - (receivers frame)))) + (let* ((normalized-name (irc:normalize-channel-name (slot-value frame 'connection) name)) + (rec (find-receiver name frame))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-paneless-receiver name initargs))) + (let ((receiver (apply 'make-paneless-receiver normalized-name initargs))) (initialize-receiver-with-pane receiver frame (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) @@ -117,20 +121,35 @@ (setf (gethash name (receivers frame)) receiver) receiver))))) +(defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "") + "Sources whose private messages (PRIVMSG, NOTICE, ...) should + be treated as if they came from the connected server itself, + unless the user has opened a query window to the source + already.") + +(defun network-service-p (source frame) + (member source *network-service-sources* + :test (lambda (source1 source2) + (string= (irc:normalize-nickname (current-connection frame) source1) + (irc:normalize-nickname (current-connection frame) source2))))) + (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) - (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection) - (slot-value frame 'nick))) - (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) - (first (irc:arguments message)))) - (target (if (equal nominal-target mynick) - (irc:source message) - nominal-target))) - (intern-receiver target frame :channel target))))) + (if (or + (find-receiver (irc:source message) frame) + (not (network-service-p (irc:source message) frame))) + (let* ((mynick (irc:normalize-nickname (current-connection frame) + (slot-value frame 'nick))) + (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) + (first (irc:arguments message)))) + (target (if (equal nominal-target mynick) + (irc:source message) + nominal-target))) + (intern-receiver target frame :channel target)) + (server-receiver frame))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) - ;; (define-privmsg-receiver-lookup irc:irc-notice-message) ; XXX: NOTICEs in freenode are a bit tricky. - ) + (define-privmsg-receiver-lookup irc:irc-notice-message)) (macrolet ((define-global-message-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) @@ -361,28 +380,24 @@ (defun post-message (frame message) (let ((receiver (receiver-for-message message frame))) - (setf (messages receiver) - (append (messages receiver) (list message))) - (unless (eql receiver (current-receiver frame)) - (incf (unseen-messages receiver)) - (when (message-directed-to-me-p frame message) - (incf (messages-directed-to-me receiver)))) - (update-drawing-options receiver) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) - nil)) + (unless (null receiver) + (setf (messages receiver) + (append (messages receiver) (list message))) + (unless (eql receiver (current-receiver frame)) + (incf (unseen-messages receiver)) + (when (message-directed-to-me-p frame message) + (incf (messages-directed-to-me receiver)))) + (update-drawing-options receiver) + (clim-internals::event-queue-prepend + (climi::frame-event-queue frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil))) -;;; XXX: ticker continues to run even if the frame is no longer active -;;; or on the display. (defun ticker (frame) - (handler-case - (loop - (clim-internals::event-queue-prepend (climi::frame-event-queue frame) - (make-instance 'bar-event :sheet frame)) - (sleep 1)) - (frame-exit () - nil))) + (loop + (clim-internals::event-queue-prepend (climi::frame-event-queue frame) + (make-instance 'bar-event :sheet frame)) + (sleep 1))) (define-presentation-type nickname ()) (define-presentation-type ignored-nickname (nickname))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv8786 Modified Files: beirc.lisp message-display.lisp Log Message: Fix /quit, /disconnect commands and quitting the irc worker thread. * /quit, /disconnect and later /connect commands now work, hopefully in all combinations. * This change also introduces a level of thread hygiene. When beirc's application frame exits, every thread (except the clim/clx listener thread) should be killed as well. Date: Sat Sep 24 11:14:04 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.18 beirc/beirc.lisp:1.19 --- beirc/beirc.lisp:1.18 Sat Sep 24 01:22:50 2005 +++ beirc/beirc.lisp Sat Sep 24 11:14:03 2005 @@ -190,7 +190,6 @@ (setf (messages-directed-to-me receiver) 0) (update-drawing-options receiver)))) - (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) @@ -211,6 +210,7 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) ((connection :initform nil :reader current-connection) + (connection-process :initform nil :accessor connection-process) (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) @@ -347,11 +347,12 @@ (clim-sys:make-process (lambda () (progv syms vals - (let ((frame (make-application-frame 'beirc))) + (let* ((frame (make-application-frame 'beirc)) + (ticker-process (clim-sys:make-process (lambda () (ticker frame)) + :name "Beirc Ticker"))) (setf *beirc-frame* frame) - (clim-sys:make-process (lambda () (ticker frame)) - :name "Beirc Ticker") - (run-frame-top-level frame)))))))) + (run-frame-top-level frame) + (clim-sys:destroy-process ticker-process)))))))) (defun message-directed-to-me-p (frame message) (let ((my-nick (slot-value frame 'nick)) @@ -372,11 +373,16 @@ (make-instance 'foo-event :sheet frame :receiver receiver)) nil)) +;;; XXX: ticker continues to run even if the frame is no longer active +;;; or on the display. (defun ticker (frame) - (loop - (clim-internals::event-queue-prepend (climi::frame-event-queue frame) - (make-instance 'bar-event :sheet frame)) - (sleep 1))) + (handler-case + (loop + (clim-internals::event-queue-prepend (climi::frame-event-queue frame) + (make-instance 'bar-event :sheet frame)) + (sleep 1)) + (frame-exit () + nil))) (define-presentation-type nickname ()) (define-presentation-type ignored-nickname (nickname)) @@ -406,7 +412,8 @@ (find-in-tab-panes-list object 'tab-layout-pane))) (defun nick-equals-my-nick-p (nickname) - (and *application-frame* + (and (not (null *application-frame*)) + (not (null (slot-value *application-frame* 'connection))) (equal (irc:normalize-nickname (current-connection *application-frame*) (slot-value *application-frame* 'nick)) (irc:normalize-nickname (current-connection *application-frame*) @@ -440,7 +447,13 @@ (remove who (current-focused-nicks) :test #'string=))) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) - (irc:quit (current-connection *application-frame*) reason)) + (when (current-connection *application-frame*) + (quit *application-frame* reason)) + (frame-exit *application-frame*)) + +(define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason")) + (when (current-connection *application-frame*) + (quit *application-frame* reason))) (defun target (&optional (*application-frame* *application-frame*)) (or (current-query) @@ -527,9 +540,45 @@ (find-pane-named frame 'server) :add-pane-p nil) (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) - (clim-sys:make-process #'(lambda () - (irc-event-loop frame connection)) - :name "IRC Message Muffling Loop") ))))) + (setf (connection-process *application-frame*) + (clim-sys:make-process #'(lambda () + (unwind-protect + (irc-event-loop frame connection) + (disconnect frame))) + :name "IRC Message Muffling Loop")) ))))) + +(defun disconnect (frame) + (let ((old-nickname (slot-value frame 'nick))) + (raise-receiver (server-receiver frame)) + (post-message frame + (make-instance 'irc:irc-quit-message + :received-time (get-universal-time) + :connection :local + :trailing-argument + (format nil "You disconnected from IRC") + :arguments nil + :command "QUIT" + :host "localhost" ;### + :user "localuser" ;### + :source old-nickname)) + (when (and (connection-process frame) + (not (eql (clim-sys:current-process) + (connection-process frame)))) + (destroy-process (connection-process frame))) + (setf (slot-value frame 'connection) nil + (connection-process frame) nil + (slot-value frame 'nick) nil))) + +(defun quit (frame reason) + (raise-receiver (server-receiver frame)) + (irc:quit (current-connection frame) reason) + (when (and (connection-process frame) + (not (eql (clim-sys:current-process) + (connection-process frame)))) + (destroy-process (connection-process frame))) + (setf (slot-value frame 'connection) nil + (connection-process frame) nil + (slot-value frame 'nick) nil)) (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) (multiple-value-prog1 @@ -544,12 +593,10 @@ (window-clear stream))) (defun restart-beirc () - (let ((m (current-messages))) - (clim-sys:destroy-process *gui-process*) - (setf *beirc-frame* nil) - (beirc) - (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*)) - (setf (current-messages) m))) + (clim-sys:destroy-process *gui-process*) + (setf *beirc-frame* nil) + (beirc) + (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))) ;;;;;;;;; Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.6 beirc/message-display.lisp:1.7 --- beirc/message-display.lisp:1.6 Sat Sep 24 01:04:21 2005 +++ beirc/message-display.lisp Sat Sep 24 11:14:03 2005 @@ -103,7 +103,8 @@ (present-url word%)) ((or (nick-equals-my-nick-p word%) - (irc:find-user (current-connection *application-frame*) word%)) + (and (current-connection *application-frame*) + (irc:find-user (current-connection *application-frame*) word%))) (present word% 'nickname)) (t (write-string word%))) (write-string stripped-punctuation)))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv1525 Modified Files: beirc.lisp Log Message: Fix a few uses to find-in-tab-panes-list to use the recommended API Date: Sat Sep 24 01:22:50 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.17 beirc/beirc.lisp:1.18 --- beirc/beirc.lisp:1.17 Sat Sep 24 01:04:21 2005 +++ beirc/beirc.lisp Sat Sep 24 01:22:50 2005 @@ -184,8 +184,7 @@ (defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane))) (let ((receiver (receiver-from-tab-pane - (find-in-tab-panes-list pane - (find-pane-named *application-frame* 'query))))) + (find-in-tab-panes-list pane 'tab-layout-pane)))) (unless (null receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) @@ -404,8 +403,7 @@ (receiver-pane receiver beirc) (object) (receiver-from-tab-pane - (find-in-tab-panes-list object - (find-pane-named *application-frame* 'query)))) + (find-in-tab-panes-list object 'tab-layout-pane))) (defun nick-equals-my-nick-p (nickname) (and *application-frame*

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv430 Modified Files: beirc.lisp message-display.lisp Log Message: add NAMES and TOPIC reply output; fix /raise <click>; add pointer-documentation also, remove the defunct raise-this-receiver p-t-c-translator Date: Sat Sep 24 01:04:22 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.16 beirc/beirc.lisp:1.17 --- beirc/beirc.lisp:1.16 Sat Sep 24 00:05:54 2005 +++ beirc/beirc.lisp Sat Sep 24 01:04:21 2005 @@ -67,6 +67,8 @@ (pane :reader pane) (tab-pane :accessor tab-pane))) +(define-presentation-type receiver-pane ()) + ;;; KLUDGE: make-clim-application-pane doesn't return an application ;;; pane, but a pane that wraps the application pane. we need the ;;; application pane for redisplay, though. @@ -91,7 +93,7 @@ 'tab-layout-pane)) (progn (setf (slot-value receiver 'tab-pane) - (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver)) + (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane)) (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) @@ -138,6 +140,15 @@ (define-global-message-receiver-lookup irc:irc-quit-message) (define-global-message-receiver-lookup irc:irc-nick-message)) +(defmethod receiver-for-message ((message irc:irc-topic-message) frame) + (intern-receiver (first (irc:arguments message)) frame :channel (first (irc:arguments message)))) + +(defmethod receiver-for-message ((message irc:irc-rpl_topic-message) frame) + (intern-receiver (second (irc:arguments message)) frame :channel (second (irc:arguments message)))) + +(defmethod receiver-for-message ((message irc:irc-rpl_namreply-message) frame) + (intern-receiver (third (irc:arguments message)) frame :channel (third (irc:arguments message)))) + (defmethod receiver-for-message ((message irc:irc-join-message) frame) (let ((target (irc:trailing-argument message))) (intern-receiver target frame :channel target))) @@ -232,8 +243,8 @@ (:layouts (default (vertically () - (with-tab-layout ('receiver :name 'query) - ("*Server*" server)) + (with-tab-layout ('receiver-pane :name 'query) + ("*Server*" server 'receiver-pane)) (60 io) (20 ;<-- Sigh! Bitrot! status-bar))))) @@ -389,6 +400,13 @@ (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) (maphash #'suggest (receivers *application-frame*)))) +(define-presentation-translator receiver-pane-to-receiver-translator + (receiver-pane receiver beirc) + (object) + (receiver-from-tab-pane + (find-in-tab-panes-list object + (find-pane-named *application-frame* 'query)))) + (defun nick-equals-my-nick-p (nickname) (and *application-frame* (equal (irc:normalize-nickname (current-connection *application-frame*) @@ -403,13 +421,6 @@ (format t "~A" o))) (format t "~A" o))) -(define-presentation-to-command-translator raise-this-receiver - (receiver com-raise-receiver beirc - :gesture :select - :documentation "Raise this receiver") - (presentation) - (list (presentation-object presentation))) - (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) (raise-receiver (intern-receiver nick *application-frame* :query nick))) @@ -470,7 +481,8 @@ (nickname com-ignore beirc :gesture :menu :menu t - :documentation "Ignore this user") + :documentation "Ignore this user" + :pointer-documentation "Ignore this user") (object) (list object)) @@ -478,7 +490,8 @@ (nickname com-focus beirc :gesture :menu :menu t - :documentation "Focus this user") + :documentation "Focus this user" + :pointer-documentation "Focus this user") (object) (list object)) @@ -486,7 +499,8 @@ (nickname com-query beirc :gesture :menu :menu t - :documentation "Query this user") + :documentation "Query this user" + :pointer-documentation "Query this user") (object) (list object)) @@ -514,6 +528,7 @@ (initialize-receiver-with-pane (server-receiver frame) frame (find-pane-named frame 'server) :add-pane-p nil) + (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) (clim-sys:make-process #'(lambda () (irc-event-loop frame connection)) :name "IRC Message Muffling Loop") ))))) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.5 beirc/message-display.lisp:1.6 --- beirc/message-display.lisp:1.5 Fri Sep 23 23:31:27 2005 +++ beirc/message-display.lisp Sat Sep 24 01:04:21 2005 @@ -78,6 +78,16 @@ (string last-char))) (otherwise (values word "")))))) +(defun strip-op-signs (word) + (if (= (length word) 0) + (values word "") + (let ((first-char (char word 0))) + (case first-char + ((#\@ #\+) + (values (subseq word 1) + (string first-char))) + (otherwise (values word "")))))) + (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) with column = start-length @@ -85,16 +95,18 @@ when (> column limit) do (setf column (length word)) (terpri) - do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word) - (cond - ((search "http://" word*) - (present-url word*)) - ((or - (nick-equals-my-nick-p word*) - (irc:find-user (current-connection *application-frame*) word*)) - (present word* 'nickname)) - (t (write-string word*))) - (write-string stripped-punctuation)) + do (multiple-value-bind (%word stripped-opsigns) (strip-op-signs word) + (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) + (write-string stripped-opsigns) + (cond + ((search "http://" word%) + (present-url word%)) + ((or + (nick-equals-my-nick-p word%) + (irc:find-user (current-connection *application-frame*) word%)) + (present word% 'nickname)) + (t (write-string word%))) + (write-string stripped-punctuation))) ;; TODO: more highlighting unless (or (null rest) (>= column limit)) do (write-char #\Space) @@ -158,6 +170,31 @@ (present (irc:source message) 'nickname) (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) (present (irc:trailing-argument message) 'nickname))))) + +(defun print-topic (receiver message sender channel topic) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (if (null sender) + (format-message* (format nil "Topic for ~A: ~A" channel topic)) + (progn + (present sender 'nickname) + (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) + +(defmethod print-message ((message irc:irc-topic-message) receiver) + (print-topic receiver message (irc:source message) + (first (irc:arguments message)) (irc:trailing-argument message))) + +(defmethod print-message ((message irc:irc-rpl_topic-message) receiver) + (print-topic receiver message nil + (second (irc:arguments message)) (irc:trailing-argument message))) + +(defmethod print-message ((message irc:irc-rpl_namreply-message) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A Names: ~A" (third (irc:arguments message)) + (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-part-message) receiver) (formatting-message (t message receiver)

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 23 Sep '05

23 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv28512 Modified Files: beirc.lisp Log Message: Make server buffer display messages & delete previous KLUDGE. * Also, try and dtrt on /quit. Date: Sat Sep 24 00:06:00 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.15 beirc/beirc.lisp:1.16 --- beirc/beirc.lisp:1.15 Fri Sep 23 23:31:27 2005 +++ beirc/beirc.lisp Sat Sep 24 00:05:54 2005 @@ -80,24 +80,6 @@ for found-pane = (actual-application-pane child) if found-pane do (return found-pane)))) -;;; 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)) @@ -105,7 +87,7 @@ (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) + (find-in-tab-panes-list pane 'tab-layout-pane)) (progn (setf (slot-value receiver 'tab-pane) @@ -184,7 +166,7 @@ (define-delegate current-focused-nicks focused-nicks t)) (defun update-drawing-options (receiver) - (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver)) + (set-drawing-options-for-pane-in-tab-layout (pane receiver) `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+) ((> (unseen-messages receiver) 0) +red+) (t +black+))))) @@ -202,7 +184,7 @@ (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) - (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane)) + (switch-to-pane (pane receiver) 'tab-layout-pane)) ;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" @@ -238,13 +220,13 @@ :background +black+ :foreground +white+) (server - :application - :display (lambda (frame pane) - (beirc-app-display frame pane (server-receiver *application-frame*))) - :display-time :command-loop - :width 400 - :height 600 - :incremental-redisplay t)) + (make-clim-application-pane + :display-function + (lambda (frame pane) + (beirc-app-display frame pane (server-receiver *application-frame*))) + :display-time nil + :width 400 :height 600 + :incremental-redisplay t))) (:geometry :width 800 :height 600) (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt)) (:layouts @@ -448,7 +430,7 @@ (setf (current-focused-nicks) (remove who (current-focused-nicks) :test #'string=))) -(define-beirc-command (com-quit :name t) ((reason 'string :prompt "reason")) +(define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (irc:quit (current-connection *application-frame*) reason)) (defun target (&optional (*application-frame* *application-frame*))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 23 Sep '05

23 Sep '05

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 ,@users) :prompt nil)))) + (let ((users (unless (null (current-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* @@ -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))

1 0