From afuchs at common-lisp.net Sun Feb 5 21:50:51 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 5 Feb 2006 15:50:51 -0600 (CST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060205215051.76BD52A032@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv18126 Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: Add ban/invite/exceptlist display functionality. --- /project/beirc/cvsroot/beirc/application.lisp 2006/01/30 18:56:00 1.36 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/05 21:50:51 1.37 @@ -247,7 +247,7 @@ (search my-nick text))) (defun interesting-message-p (message) - (typep message '(or irc:irc-privmsg-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) + (typep message '(or irc:irc-privmsg-message irc:irc-notice-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) (defun post-message-to-receiver (frame message receiver) (setf (messages receiver) @@ -418,6 +418,9 @@ (define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who")) (irc:deop (current-connection *application-frame*) (target) who)) +(define-beirc-command (com-show-ban-list :name t) () + (irc:ban (current-connection *application-frame*) (target) "")) + (define-beirc-command (com-ban-nick :name t) ((who 'nickname :prompt "who")) (irc:ban (current-connection *application-frame*) (target) (format nil "~A!*@*" who))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/01/27 22:39:09 1.27 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/05 21:50:51 1.28 @@ -435,6 +435,25 @@ if (not (null rest)) do (write-string ", ")))))))))) +(macrolet ((define-*list-printer (&rest message-types) + `(progn + ,@(loop for (message-type prefix) in message-types + collect + `(defmethod print-message ((message ,message-type) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (write-string ,prefix) + (present (nth 2 (irc:arguments message)) 'hostmask) + (when (find #\! (nth 3 (irc:arguments message))) + (write-string " by ") + (present (first (split-sequence:split-sequence #\! (nth 3 (irc:arguments message)))) + 'nickname)))))))))) + (define-*list-printer + (irc:irc-rpl_banlist-message "BANNED: ") + (irc:irc-rpl_invitelist-message "INVITED: ") + (irc:irc-rpl_exceptlist-message "UNBANNED: "))) + ;;; the display function (& utilities) (defgeneric preamble-length (message) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/01/27 22:40:32 1.13 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/05 21:50:51 1.14 @@ -159,7 +159,9 @@ (intern-receiver target frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message) - (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message irc:irc-err_chanoprivsneeded-message) + (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message + irc:irc-err_chanoprivsneeded-message irc:irc-rpl_banlist-message + irc:irc-rpl_invitelist-message irc:irc-rpl_exceptlist-message) (2 irc:irc-rpl_namreply-message) (nil irc:irc-join-message))) From afuchs at common-lisp.net Mon Feb 6 21:21:02 2006 From: afuchs at common-lisp.net (afuchs) Date: Mon, 6 Feb 2006 15:21:02 -0600 (CST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060206212102.DD2E144014@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv6629 Modified Files: message-display.lisp Log Message: fix indentation of formatting-message --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/05 21:50:51 1.28 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/06 21:21:02 1.29 @@ -74,6 +74,8 @@ (lambda () , at message-body-column-body))) +;;; for optimal indentation, use (put 'formatting-message 'common-lisp-indent-function 1) + (defun strip-punctuation (word) (if (= (length word) 0) (values word "") @@ -134,10 +136,10 @@ (*standard-output* (if (message-from-focused-nick-p message receiver) :bold :roman)) (formatting-message (t message receiver) - ((write-string start-string *standard-output*) - (present (irc:source message) 'unhighlighted-nickname) - (write-string end-string *standard-output*)) - ((format-message* (irc:trailing-argument message)))))))) + ((write-string start-string *standard-output*) + (present (irc:source message) 'unhighlighted-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 "<" ">")) @@ -149,19 +151,19 @@ (let ((source (cl-irc:source message)) (matter (trailing-argument* message))) (formatting-message (t message receiver) - ((format t "*")) - ((present source 'unhighlighted-nickname) - (format t " ") - (format-message* matter :start-length (+ 2 (length source))))))) + ((format t "*")) + ((present source 'unhighlighted-nickname) + (format t " ") + (format-message* matter :start-length (+ 2 (length source))))))) (defmethod print-message ((message irc:ctcp-version-message) receiver) (let ((source (cl-irc:source message))) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present source 'unhighlighted-nickname) - (format t " ") - (format-message* "asked for your IRC client version" :start-length (+ 2 (length source)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present source 'unhighlighted-nickname) + (format t " ") + (format-message* "asked for your IRC client version" :start-length (+ 2 (length source)))))))) ;;; server messages @@ -171,13 +173,13 @@ collect `(defmethod print-message ((message ,message-type) receiver) (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* - (format nil "~@[~A: ~]~{~A ~}~A" - ,message-name - (cdr (irc:arguments message)) - (irc:trailing-argument message))))))))))) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* + (format nil "~@[~A: ~]~{~A ~}~A" + ,message-name + (cdr (irc:arguments message)) + (irc:trailing-argument message))))))))))) (define-server-message-printer ((irc:irc-rpl_motd-message . "MODT") (irc:irc-rpl_motdstart-message . "MOTD") (irc:irc-rpl_isupport-message) @@ -203,35 +205,35 @@ (defmethod print-message ((message irc:irc-rpl_isupport-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)))))) + ((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 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)))))) + ((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))) - ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "~A ~A :~A" (irc:command message) - (irc:arguments message) - (irc:trailing-argument message)))))) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "~A ~A :~A" (irc:command message) + (irc:arguments message) + (irc:trailing-argument message)))))) ;;; user-related messages (defmethod print-message ((message irc:irc-quit-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Quit: ") - (present (irc:source message) 'nickname) - (format t ": ") - (format-message* (irc:trailing-argument message) - :start-length (+ 8 (length (irc:source message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Quit: ") + (present (irc:source message) 'nickname) + (format t ": ") + (format-message* (irc:trailing-argument message) + :start-length (+ 8 (length (irc:source message)))))))) (defun present-as-hostmask (user host) (write-char #\() @@ -241,91 +243,91 @@ (defmethod print-message ((message irc:irc-nick-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Nick change: ") - (present (irc:source message) 'nickname) - (write-string " ") - (present-as-hostmask (irc:user message) (irc:host message)) - (write-string " is now known as ") - (present (irc:trailing-argument message) 'nickname))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Nick change: ") + (present (irc:source message) 'nickname) + (write-string " ") + (present-as-hostmask (irc:user message) (irc:host message)) + (write-string " is now known as ") + (present (irc:trailing-argument message) 'nickname))))) (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me nickname user host &rest args) (irc:arguments message) - (declare (ignore me args)) - (present nickname 'nickname) - (format t " is ") - (present-as-hostmask user host) - (format t " (~A)" (irc:trailing-argument message))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (destructuring-bind (me nickname user host &rest args) (irc:arguments message) + (declare (ignore me args)) + (present nickname 'nickname) + (format t " is ") + (present-as-hostmask user host) + (format t " (~A)" (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is in ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil " is in ~A" (irc:trailing-argument message)) + :start-length (length (second (irc:arguments message)))))))) (defmethod print-message ((message irc:irc-rpl_whoisserver-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is on ~A: ~A" - (third (irc:arguments message)) - (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil " is on ~A: ~A" + (third (irc:arguments message)) + (irc:trailing-argument message)) + :start-length (length (second (irc:arguments message)))))))) (defmethod print-message ((message irc:irc-rpl_away-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is away: ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil " is away: ~A" (irc:trailing-argument message)) + :start-length (length (second (irc:arguments message)))))))) (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (write-char #\Space) - (format-message* (irc:trailing-argument message) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (write-char #\Space) + (format-message* (irc:trailing-argument message) + :start-length (length (second (irc:arguments message)))))))) ;;; channel management messages (defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (let* ((target (second (irc:arguments message))) - (close-p (string= (title receiver) - (irc:normalize-nickname (current-connection *application-frame*) - target)))) - (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" - target close-p)) - (when close-p - (present `(com-close ,receiver) 'command))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (let* ((target (second (irc:arguments message))) + (close-p (string= (title receiver) + (irc:normalize-nickname (current-connection *application-frame*) + target)))) + (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" + target close-p)) + (when close-p + (present `(com-close ,receiver) 'command))))))) (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message))))))) (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)))))))) + ((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) @@ -337,49 +339,49 @@ (defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me channel who time) (irc:arguments message) - (declare (ignore me - time ; TODO: no date display for now. - )) - (format-message* (format nil "~A topic set by ~A" channel who))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (destructuring-bind (me channel who time) (irc:arguments message) + (declare (ignore me + time ; TODO: no date display for now. + )) + (format-message* (format nil "~A topic set by ~A" channel who))))))) (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))))))) + ((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) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Part: ") - (present (irc:source message) 'nickname) - (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) - (irc:trailing-argument message))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Part: ") + (present (irc:source message) 'nickname) + (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) + (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Join: ") - (present (irc:source message) 'nickname) - (write-char #\Space) - (present-as-hostmask (irc:user message) (irc:host message)))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Join: ") + (present (irc:source message) 'nickname) + (write-char #\Space) + (present-as-hostmask (irc:user message) (irc:host message)))))) (defmethod print-message ((message irc:irc-kick-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (write-string " kicked ") - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil ": ~A" (irc:trailing-argument message)) - :start-length (+ 9 (length (second (irc:arguments message))) - (length (irc:source message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " kicked ") + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil ": ~A" (irc:trailing-argument message)) + :start-length (+ 9 (length (second (irc:arguments message))) + (length (irc:source message)))))))) ;;; XXX: uses unexported symbols from cl-irc, but I think their ;;; unexportedness is accidental. @@ -412,11 +414,11 @@ (defmethod print-message ((message irc:irc-mode-message) receiver) (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)))))))) + ((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)))))))) (t (destructuring-bind (target &rest args) (irc:arguments message) (let* ((connection (current-connection *application-frame*)) @@ -425,15 +427,15 @@ (mode-changes (irc:parse-mode-arguments connection target args :server-p (irc:user connection)))) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (write-string " changes channel mode: ") - (loop for (change . rest) on mode-changes - do (destructuring-bind (op mode &optional arg) change - (print-mode-change target op mode arg)) - if (not (null rest)) - do (write-string ", ")))))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " changes channel mode: ") + (loop for (change . rest) on mode-changes + do (destructuring-bind (op mode &optional arg) change + (print-mode-change target op mode arg)) + if (not (null rest)) [27 lines skipped] From afuchs at common-lisp.net Fri Feb 10 20:48:23 2006 From: afuchs at common-lisp.net (afuchs) Date: Fri, 10 Feb 2006 14:48:23 -0600 (CST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060210204823.799345800C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv14444 Modified Files: message-display.lisp Log Message: add a printer for the :key channel mode (+k) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/06 21:21:02 1.29 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/10 20:48:23 1.30 @@ -400,6 +400,12 @@ (write-char #\:) (present arg 'number))) +(defmethod print-mode-change (target op (mode (eql :key)) arg) + (format t "~A~A" op (mode-symbol-to-char target mode)) + (when (not (null arg)) + (write-char #\:) + (present arg 'string))) + (macrolet ((define-mode-change-with-hostmask-printer (&rest modes) `(progn ,@(loop for mode in modes From afuchs at common-lisp.net Thu Feb 16 23:46:57 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 16 Feb 2006 17:46:57 -0600 (CST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060216234657.7EA3D2A5C7@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv18918 Modified Files: application.lisp message-display.lisp receivers.lisp variables.lisp Log Message: query auto-closing; improve urls highlighting; resize new queries correctly. * Query auto-closing code: if *auto-close-inactive-query-windows-p* is set to T (nil is the default), beirc will automatically close windows that were inactive for more than *max-query-inactive-time* seconds (and all messages in the window were seen). * Highlight https:// urls; that should speak for itself (: * change the presentation of rewritten clhs URLs. instead of file://, we show clhs://; the link target is still the right one, of course. * add a change-space-requirements call that resizes new query panes to fit the size of the tab pane container. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/05 21:50:51 1.37 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/16 23:46:57 1.38 @@ -220,6 +220,8 @@ (defmethod handle-event ((frame beirc) (event bar-event)) (let ((pane (get-frame-pane frame 'status-bar))) (redisplay-frame-pane frame pane) + (when *auto-close-inactive-query-windows-p* + (com-close-inactive-queries)) (medium-force-output (sheet-medium pane)))) ;;; @@ -256,7 +258,8 @@ (when (interesting-message-p message) (incf (unseen-messages receiver))) (when (message-directed-to-me-p frame message) - (incf (messages-directed-to-me receiver)))) + (incf (messages-directed-to-me receiver))) + (incf (all-unseen-messages receiver))) (update-drawing-options receiver) (clim-internals::event-queue-prepend (climi::frame-event-queue frame) @@ -344,6 +347,22 @@ (irc:part connection channel))) (remove-receiver receiver *application-frame*)) +(define-beirc-command (com-close-inactive-queries :name t) () + (let ((receivers-to-close nil)) + (maphash (lambda (name receiver) + (declare (ignore name)) + (when (and (not (eql receiver (server-receiver *application-frame*))) + (not (eql receiver (current-receiver *application-frame*))) + (= 0 + (unseen-messages receiver) (all-unseen-messages receiver) + (messages-directed-to-me receiver)) + (null (irc:find-channel (current-connection *application-frame*) (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*)))) + (define-beirc-command (com-part :name t) () (irc:part (current-connection *application-frame*) (title (current-receiver *application-frame*)))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/10 20:48:23 1.30 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/16 23:46:57 1.31 @@ -6,13 +6,14 @@ :inherit-from 'string) (defun present-url (url) - (let ((start (search "http://www.lispworks.com/reference/HyperSpec/" url))) + (let* ((clhs-base "http://www.lispworks.com/reference/HyperSpec/") + (start (search clhs-base url))) (cond (start - (write-string (subseq url 0 start)) - (present (concatenate 'string - *hyperspec-base-url* - (subseq url (+ 45 start))) - 'url)) + (let* ((clhs-page (subseq url (+ start (length clhs-base)))) + (new-url (concatenate 'string *hyperspec-base-url* clhs-page))) + (write-string (subseq url 0 start)) + (with-output-as-presentation (t new-url 'url) + (format t "clhs://~A" clhs-page)))) ((> (length url) *default-fill-column*) (let ((new-url (concatenate 'string @@ -107,7 +108,7 @@ (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) (write-string stripped-preceding-punctuation) (cond - ((search "http://" word%) + ((or (search "http://" word%) (search "https://" word%)) (present-url word%)) ((or (nick-equals-my-nick-p word%) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/05 21:50:51 1.14 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/16 23:46:57 1.15 @@ -3,11 +3,13 @@ (defclass receiver () ((messages :accessor messages :initform nil) (unseen-messages :accessor unseen-messages :initform 0) + (all-unseen-messages :accessor all-unseen-messages :initform 0) (messages-directed-to-me :accessor messages-directed-to-me :initform 0) (channel :reader channel :initform nil :initarg :channel) (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. (focused-nicks :accessor focused-nicks :initform nil) (title :reader title :initarg :title) + (last-visited :accessor last-visited :initform 0) (pane :reader pane) (tab-pane :accessor tab-pane))) @@ -52,7 +54,8 @@ (progn (setf (slot-value receiver 'tab-pane) (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane)) - (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) + (add-pane (tab-pane receiver) (find-pane-named frame 'query)) + ;; resize the pane to fit the tab container change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) (defun find-receiver (name frame) @@ -74,7 +77,7 @@ (lambda (frame pane) (beirc-app-display frame pane receiver)) :display-time nil - :width 600 :height 800 + :min-width 600 :min-height 800 :incremental-redisplay t))) (setf (gethash normalized-name (receivers frame)) receiver) receiver))))) @@ -255,10 +258,14 @@ (find-in-tab-panes-list pane my-tab-layout-pane)))) (unless (null receiver) (setf (unseen-messages receiver) 0) + (setf (all-unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) + (setf (last-visited receiver) (get-universal-time)) (update-drawing-options receiver)))))) (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) + (setf (all-unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) + (setf (last-visited receiver) (get-universal-time)) (switch-to-pane (pane receiver) 'tab-layout-pane)) --- /project/beirc/cvsroot/beirc/variables.lisp 2005/10/02 23:47:51 1.8 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/02/16 23:46:57 1.9 @@ -19,4 +19,17 @@ (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") - (user-homedir-pathname))) \ No newline at end of file + (user-homedir-pathname))) + +(defvar *auto-close-inactive-query-windows-p* nil + "Indicates whether beirc automatically closes query windows +that were inactive for longer than *max-query-inactive-time* +seconds. If set to NIL, beirc doesn't automaticaly close query +windows. Closing inactive query windows is still available via +/Close Inactive Queries.") + +(defvar *max-query-inactive-time* 600 + "Longest time an inactive query window will be kept around by +the command /Close Inactive Queries and the automatic query +window closing mechanism (see +*auto-close-inactive-query-windows-p*).") \ No newline at end of file From afuchs at common-lisp.net Wed Feb 22 16:30:50 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 22 Feb 2006 10:30:50 -0600 (CST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060222163050.B95C869011@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv14752 Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: remove calls to deprecated function irc:trailing-argument and replace them (where useful) with the irc:destructuring-arguments binding form. also, fix the (change-space-requirements ) reader error that annoyed Paolo Amoroso. Sorry for that. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/16 23:46:57 1.38 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/22 16:30:50 1.39 @@ -244,9 +244,9 @@ (clim-sys:destroy-process ticker-process)))))))) (defun message-directed-to-me-p (frame message) - (let ((my-nick (slot-value frame 'nick)) - (text (or (irc:trailing-argument message) ""))) - (search my-nick text))) + (irc:destructuring-arguments (&last body) message + (let ((my-nick (slot-value frame 'nick))) + (search my-nick (or body ""))))) (defun interesting-message-p (message) (typep message '(or irc:irc-privmsg-message irc:irc-notice-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) @@ -411,8 +411,7 @@ (make-instance message-type :received-time (get-universal-time) :connection :local - :trailing-argument trailing-argument - :arguments arguments + :arguments `(, at arguments ,trailing-argument) :command command :HOST "localhost" :USER "localuser" @@ -788,15 +787,15 @@ nil) ;### put the server you initially connected to here. (defmethod trailing-argument* (message) - (irc:trailing-argument message)) + (car (last (irc:arguments message)))) (defmethod trailing-argument* ((message cl-irc:ctcp-action-message)) (or (ignore-errors ;### - (let ((p1 (position #\space (irc:trailing-argument message)))) - (subseq (irc:trailing-argument message) + (let ((p1 (position #\space (car (last (irc:arguments message)))))) + (subseq (car (last (irc:arguments message))) (1+ p1) - (1- (length (irc:trailing-argument message)))))) + (1- (length (car (last (irc:arguments message)))))))) "#Garbage parsing message#")) (defmethod process-message (*application-frame* (message cl-irc:ctcp-action-message)) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/16 23:46:57 1.31 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/22 16:30:50 1.32 @@ -1,5 +1,8 @@ (in-package :beirc) +(declaim (optimize (debug 2) (speed 0) + (space 0))) + (defvar *max-preamble-length* 0) (define-presentation-type url () @@ -29,6 +32,7 @@ (member (irc:source message) (focused-nicks receiver) :test #'string=)) (defun message-from-ignored-nick-p (message receiver) + (declare (ignore receiver)) (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) :test #'string=)) @@ -136,11 +140,12 @@ (with-text-face (*standard-output* (if (message-from-focused-nick-p message receiver) :bold :roman)) - (formatting-message (t message receiver) - ((write-string start-string *standard-output*) - (present (irc:source message) 'unhighlighted-nickname) - (write-string end-string *standard-output*)) - ((format-message* (irc:trailing-argument message)))))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((write-string start-string *standard-output*) + (present (irc:source message) 'unhighlighted-nickname) + (write-string end-string *standard-output*)) + ((format-message* body)))))))) (defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) (print-privmsg-like-message message receiver "<" ">")) @@ -149,13 +154,13 @@ (print-privmsg-like-message message receiver "-" "-")) (defmethod print-message ((message irc:ctcp-action-message) receiver) - (let ((source (cl-irc:source message)) - (matter (trailing-argument* message))) + (let ((source (cl-irc:source message))) (formatting-message (t message receiver) - ((format t "*")) - ((present source 'unhighlighted-nickname) - (format t " ") - (format-message* matter :start-length (+ 2 (length source))))))) + ((format t "*")) + ((present source 'unhighlighted-nickname) + (format t " ") + (format-message* (trailing-argument* message) + :start-length (+ 2 (length source))))))) (defmethod print-message ((message irc:ctcp-version-message) receiver) (let ((source (cl-irc:source message))) @@ -173,14 +178,13 @@ ,@(loop for (message-type . message-name) in message-specs collect `(defmethod print-message ((message ,message-type) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* - (format nil "~@[~A: ~]~{~A ~}~A" - ,message-name - (cdr (irc:arguments message)) - (irc:trailing-argument message))))))))))) + (irc:destructuring-arguments (_ &rest arguments &last body) message + (declare (ignore _)) + (formatting-message (t message receiver) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* + (format nil "~@[~A: ~]~{~A ~}~A" ,message-name (butlast arguments) body))))))))))) (define-server-message-printer ((irc:irc-rpl_motd-message . "MODT") (irc:irc-rpl_motdstart-message . "MOTD") (irc:irc-rpl_isupport-message) @@ -204,37 +208,25 @@ (irc:irc-rpl_noaway-message) (irc:irc-rpl_unaway-message)))) -(defmethod print-message ((message irc:irc-rpl_isupport-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 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))) - ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "~A ~A :~A" (irc:command message) - (irc:arguments message) - (irc:trailing-argument message)))))) + (irc:destructuring-arguments (&whole args &last body) message + (formatting-message (t message receiver) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "~A ~A :~A" (irc:command message) (butlast args) body)))))) ;;; user-related messages (defmethod print-message ((message irc:irc-quit-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Quit: ") - (present (irc:source message) 'nickname) - (format t ": ") - (format-message* (irc:trailing-argument message) - :start-length (+ 8 (length (irc:source message)))))))) + (irc:destructuring-arguments (&optional body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Quit: ") + (present (irc:source message) 'nickname) + (unless (null body) + (format t ": ") + (format-message* body :start-length (+ 8 (length (irc:source message)))))))))) (defun present-as-hostmask (user host) (write-char #\() @@ -243,61 +235,66 @@ (write-char #\))) (defmethod print-message ((message irc:irc-nick-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Nick change: ") - (present (irc:source message) 'nickname) - (write-string " ") - (present-as-hostmask (irc:user message) (irc:host message)) - (write-string " is now known as ") - (present (irc:trailing-argument message) 'nickname))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Nick change: ") + (present (irc:source message) 'nickname) + (write-string " ") + (present-as-hostmask (irc:user message) (irc:host message)) + (write-string " is now known as ") + (present body 'nickname)))))) (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver) (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me nickname user host &rest args) (irc:arguments message) - (declare (ignore me args)) + (irc:destructuring-arguments (me nickname user host &last ircname) message + (declare (ignore me)) (present nickname 'nickname) (format t " is ") (present-as-hostmask user host) - (format t " (~A)" (irc:trailing-argument message))))))) + (format t " (~A)" ircname)))))) (defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is in ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname &last body) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is in ~A" body) :start-length (length nickname))))))) (defmethod print-message ((message irc:irc-rpl_whoisserver-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is on ~A: ~A" - (third (irc:arguments message)) - (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname server &last server-callout) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is on ~A: ~A" server server-callout) + :start-length (length nickname))))))) (defmethod print-message ((message irc:irc-rpl_away-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is away: ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname &last away-msg) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is away: ~A" away-msg) + :start-length (length (second (irc:arguments message))))))))) (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (write-char #\Space) - (format-message* (irc:trailing-argument message) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname body) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (write-char #\Space) + (format-message* body :start-length (length (second (irc:arguments message))))))))) ;;; channel management messages @@ -305,20 +302,22 @@ (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (let* ((target (second (irc:arguments message))) - (close-p (string= (title receiver) - (irc:normalize-nickname (current-connection *application-frame*) - target)))) - (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" - target close-p)) - (when close-p - (present `(com-close ,receiver) 'command))))))) + (irc:destructuring-arguments (me target &rest rest) message + (declare (ignore me rest)) + (let* ((close-p (string= (title receiver) + (irc:normalize-nickname (current-connection *application-frame*) + target)))) + (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" + target close-p)) + (when close-p + (present `(com-close ,receiver) 'command)))))))) (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message))))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (format-message* (format nil "Not permitted: ~A" body))))))) (defun print-topic (receiver message sender channel topic) (formatting-message (t message receiver) @@ -331,38 +330,41 @@ (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))) + (irc:destructuring-arguments (channel &last topic) message + (print-topic receiver message (irc:source message) channel topic))) (defmethod print-message ((message irc:irc-rpl_topic-message) receiver) - (print-topic receiver message nil - (second (irc:arguments message)) (irc:trailing-argument message))) + (irc:destructuring-arguments (channel &last topic) message + (print-topic receiver message nil channel topic))) (defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver) (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me channel who time) (irc:arguments message) + (irc:destructuring-arguments (me channel who time) message (declare (ignore me time ; TODO: no date display for now. )) (format-message* (format nil "~A topic set by ~A" channel who))))))) (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))))))) + (irc:destructuring-arguments (me privacy channel &last nicks) message + (declare (ignore me privacy)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A Names: ~A" channel nicks))))))) (defmethod print-message ((message irc:irc-part-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Part: ") - (present (irc:source message) 'nickname) - (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) - (irc:trailing-argument message))))))) + (irc:destructuring-arguments (channel &optional part-msg) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Part: ") + (present (irc:source message) 'nickname) + (format t " left ~A" channel) + (unless (null part-msg) + (format-message* (format nil ": ~A" part-msg)))))))) (defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver) @@ -374,15 +376,17 @@ (present-as-hostmask (irc:user message) (irc:host message)))))) (defmethod print-message ((message irc:irc-kick-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (write-string " kicked ") - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil ": ~A" (irc:trailing-argument message)) - :start-length (+ 9 (length (second (irc:arguments message))) - (length (irc:source message)))))))) + (irc:destructuring-arguments (channel victim &optional kick-msg) message + (declare (ignore channel)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " kicked ") + (present victim 'nickname) + (unless (null kick-msg) + (format-message* (format nil ": ~A" kick-msg) + :start-length (+ 9 (length victim) (length (irc:source message)))))))))) ;;; XXX: uses unexported symbols from cl-irc, but I think their ;;; unexportedness is accidental. @@ -422,12 +426,12 @@ (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)))))))) + ((irc:destructuring-arguments (channel 1c-mode) message + (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A set mode ~A ~A" (irc:source message) + channel 1c-mode))))))) (t - (destructuring-bind (target &rest args) (irc:arguments message) + (irc:destructuring-arguments (target &rest args) message (let* ((connection (current-connection *application-frame*)) (target (or (irc:find-user connection target) (irc:find-channel connection target))) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/16 23:46:57 1.15 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/22 16:30:50 1.16 @@ -55,7 +55,8 @@ (setf (slot-value receiver 'tab-pane) (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane)) (add-pane (tab-pane receiver) (find-pane-named frame 'query)) - ;; resize the pane to fit the tab container change-space-requirements pane))) + ;; resize the pane to fit the tab container + (change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) (defun find-receiver (name frame) @@ -146,7 +147,7 @@ (macrolet ((define-nth-arg-message-receiver-lookup (&rest clauses) "Defines receiver-for-message methods that return the receiver associated with the nth arg of the - irc message or the trailing arg if NTH in the + irc message or the last arg if NTH in the clauses is nil. Each clause must have this format: @@ -158,7 +159,7 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (let ((target ,(if (numberp nth) `(nth ,nth (irc:arguments message)) - `(irc:trailing-argument message)))) + `(first (last (irc:arguments message)))))) (intern-receiver target frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message) From afuchs at common-lisp.net Thu Feb 23 19:43:29 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 23 Feb 2006 13:43:29 -0600 (CST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060223194329.226342A1D6@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv21256 Modified Files: application.lisp Log Message: rework command reading. user input will no long be erased when invoking a presentation to command translator. (i.e. clicking on a URL will preserve the content of the input buffer). This works only for non-command reading, though. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/22 16:30:50 1.39 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/23 19:43:29 1.40 @@ -125,6 +125,8 @@ (defvar *beirc-frame*) +(defvar *last-input-line* nil) + (defun beirc-status-display (*application-frame* *standard-output*) (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) @@ -233,7 +235,8 @@ (clim-sys:make-process (lambda () (progv syms vals - (let* ((frame (make-application-frame 'beirc)) + (let* ((*last-input-line* nil) + (frame (make-application-frame 'beirc)) (ticker-process (clim-sys:make-process (lambda () (ticker frame)) :name "Beirc Ticker"))) (setf *beirc-frame* frame) @@ -751,25 +754,32 @@ (connection-process frame) nil (slot-value frame 'nick) nil)) + + (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) - (multiple-value-prog1 - (clim:with-input-editing (stream) - (let ((c (clim:read-gesture :stream stream :peek-p t))) - (cond ((eql c #\/) - (clim:read-gesture :stream stream) - (clim:accept 'clim:command :stream stream :prompt nil)) - (t - (list 'com-say (accept 'mumble :prompt nil :stream stream)))))) + (multiple-value-prog1 + (clim:with-input-editing (stream) + (when *last-input-line* + (replace-input stream *last-input-line* :rescan t)) + (with-input-context ('command) (object) + (let ((c (clim:read-gesture :stream stream :peek-p t))) + (multiple-value-prog1 + (cond ((eql c #\/) + (clim:read-gesture :stream stream) + (clim:accept 'clim:command :stream stream :prompt nil)) + (t + (list 'com-say (accept 'mumble :prompt nil :stream stream)))) + (setf *last-input-line* nil))) + (command + (let ((buffer (stream-input-buffer stream))) + (when (every 'characterp buffer) + (setf *last-input-line* + (with-output-to-string (s) + (loop for char across buffer + do (write-char char s)))))) + object))) (window-clear stream))) -(defmethod read-frame-command :around ((frame beirc) - &key (stream *standard-input*)) - (with-input-context ('command) (object) - (call-next-method) - (command - (window-clear stream) - object))) - (defun restart-beirc () (clim-sys:destroy-process *gui-process*) (setf *beirc-frame* nil) From afuchs at common-lisp.net Sat Feb 25 15:22:23 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 25 Feb 2006 10:22:23 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060225152223.160753A004@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16258 Modified Files: application.lisp message-display.lisp presentations.lisp receivers.lisp Log Message: Multi-server support; also, make mode change printing more robust. There's a bug on /quit that I couldn't figure out; users are advised to use the terminate-thread restart for now (or help me find the bug (-:) Details: * /connect allows opening more than one connection now. * (current-connection frame) now returns the current connection of the currently selected receiver. * this means that every command operates on the current connection now. * (except /quit, which terminates all connections and closes the window) --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/23 19:43:29 1.40 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 15:22:22 1.41 @@ -70,12 +70,11 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) - ((connection :initform nil :reader current-connection) - (connection-process :initform nil :accessor connection-process) + ((connection-processes :initform nil :accessor connection-processes) (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) + (server-receivers :initform nil :reader server-receivers) (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) (:panes (io @@ -105,7 +104,7 @@ (default (vertically () (with-tab-layout ('receiver-pane :name 'query) - ("*Server*" server 'receiver-pane)) + ("*Not Connected*" server 'receiver-pane)) ;; (68 io) ;; no drop-shadow prompt (72 io) (20 pointer-doc) @@ -121,6 +120,26 @@ receiver nil))) +(defmethod current-connection ((frame beirc)) + (when (current-receiver frame) + (connection (current-receiver frame)))) + +(defmethod server-receiver ((frame beirc) + &optional (connection (current-connection *application-frame*))) + (cdr (assoc connection (server-receivers frame) :test #'connection=))) + +(defmethod (setf server-receiver) (newval (frame beirc) + &optional (connection (current-connection *application-frame*))) + (pushnew (cons connection newval) (slot-value frame 'server-receivers) + :key #'car :test #'connection=)) + +(defmethod connection-process ((frame beirc) connection) + (cdr (assoc connection (connection-processes frame) :test #'connection=))) + +(defmethod (setf connection-process) (newval (frame beirc) connection) + (pushnew (cons connection newval) (slot-value frame 'connection-processes) + :key #'car :test #'connection=)) + (defvar *gui-process* nil) (defvar *beirc-frame*) @@ -242,9 +261,8 @@ (setf *beirc-frame* frame) (load-user-init-file) (run-frame-top-level frame) - (unless (null (current-connection frame)) - (irc:quit (current-connection frame) "Client Quit")) - (clim-sys:destroy-process ticker-process)))))))) + (clim-sys:destroy-process ticker-process) + (disconnect-all frame "Client Quit")))))))) (defun message-directed-to-me-p (frame message) (irc:destructuring-arguments (&last body) message @@ -314,7 +332,8 @@ (format nil "IDENTIFY ~A" password))) (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) - (raise-receiver (intern-receiver nick *application-frame* :query nick))) + (raise-receiver (intern-receiver nick (current-connection *application-frame*) + *application-frame* :query nick))) (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) @@ -413,7 +432,7 @@ trailing-argument) (make-instance message-type :received-time (get-universal-time) - :connection :local + :connection (current-connection *application-frame*) :arguments `(, at arguments ,trailing-argument) :command command :HOST "localhost" @@ -467,13 +486,12 @@ (irc:away (current-connection *application-frame*) "")) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) - (when (current-connection *application-frame*) - (disconnect *application-frame* reason)) + (disconnect-all *application-frame* reason) (frame-exit *application-frame*)) (define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) - (disconnect *application-frame* reason))) + (disconnect (current-connection *application-frame*) *application-frame* reason))) (define-beirc-command (com-switch-timestamp-orientation :name t) () (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left) @@ -505,15 +523,14 @@ (com-msg (target) what)) (define-beirc-command (com-me :name t) ((what 'mumble :prompt nil)) - (with-slots (connection) *application-frame* - (let ((m (make-fake-irc-message 'irc:ctcp-action-message + (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)))))) + (irc:privmsg (current-connection *application-frame*) (target) + (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. @@ -697,9 +714,16 @@ (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) (define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) - (raise-receiver (intern-receiver channel *application-frame* :channel channel)) + (raise-receiver (intern-receiver channel (current-connection *application-frame*) + *application-frame* :channel channel)) (irc:join (current-connection *application-frame*) channel)) +(defun connection= (connection1 connection2) + ;; TODO: should compare by network, not by server name. + ;; TODO: also, there is no port that we could compare. + (and (equal (irc:nickname (irc:user connection1)) (irc:nickname (irc:user connection2))) + (equal (irc:server-name connection1) (irc:server-name connection2)))) + (define-beirc-command (com-connect :name t) ((server 'string :prompt "Server") &key @@ -707,54 +731,47 @@ (pass 'string :prompt "Password" :default nil) (port 'number :prompt "Port" :default irc::*default-irc-server-port*)) (let ((success nil)) - (cond ((current-connection *application-frame*) - (format *query-io* "You are already connected.~%")) - (t - (setf (slot-value *application-frame* 'connection) - (apply #'irc:connect - :nickname nick :server server :connection-type 'beirc-connection :port port - (if (null pass) - nil - `(:password ,pass)))) - (unwind-protect - (progn - (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*)) - (loop for receiver being the hash-values of (receivers frame) - if (channelp (channel receiver)) - do (irc:join connection (channel receiver))) - (join-missing-channels frame) - (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)) - (setf (connection-process *application-frame*) - (clim-sys:make-process #'(lambda () - (restart-case - (irc-event-loop frame connection) - (disconnect () - :report "Disconnect from IRC" - (disconnect frame "Client Disconnect")))) - :name "IRC Message Muffling Loop")))) - (setf success t)) - (unless success - (disconnect *application-frame* "Client error."))))))) + (let* ((frame *application-frame*) + (connection (apply #'irc:connect + :nickname nick :server server :connection-type 'beirc-connection :port port + (if (null pass) + nil + `(:password ,pass)))) + (server-receiver (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame))) + (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) + (find-pane-named frame 'query))) + (setf (server-receiver frame connection) server-receiver) + (setf (connection-process *application-frame* connection) + (clim-sys:make-process #'(lambda () + (restart-case + (irc-event-loop frame connection) + (disconnect () + :report "Terminate this connection" + (disconnect connection frame "Client Disconnect")))) + :name "IRC Message Muffling Loop")) + (setf success t)) + (unless success + (disconnect connection frame "Client error.")))))) -(defun disconnect (frame reason) +(defun disconnect (connection frame reason) (raise-receiver (server-receiver frame)) - (irc:quit (current-connection frame) reason) - (when (and (connection-process frame) + (irc:quit connection reason) + (when (and (connection-process frame connection) (not (eql (clim-sys:current-process) - (connection-process frame)))) - (destroy-process (connection-process frame))) - (setf (slot-value frame 'connection) nil - (connection-process frame) nil + (connection-process frame connection)))) + (destroy-process (connection-process frame connection))) + (setf (connection-process frame connection) nil (slot-value frame 'nick) nil)) - +(defun disconnect-all (frame reason) + (loop for (conn . receiver) in (server-receivers frame) + do (disconnect (connection receiver) frame reason))) (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) (multiple-value-prog1 @@ -768,7 +785,7 @@ (clim:read-gesture :stream stream) (clim:accept 'clim:command :stream stream :prompt nil)) (t - (list 'com-say (accept 'mumble :prompt nil :stream stream)))) + (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream)))) (setf *last-input-line* nil))) (command (let ((buffer (stream-input-buffer stream))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/22 16:30:50 1.32 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 15:22:22 1.33 @@ -396,8 +396,8 @@ target mode))) (defmethod print-mode-change (target op mode (user irc:user)) - (format t "~A~A:" op (mode-symbol-to-char target mode)) - (present (irc:nickname user) 'nickname)) + (format t "~A~A:" op (mode-symbol-to-char target mode)) + (present (irc:nickname user) 'nickname)) (defmethod print-mode-change (target op (mode (eql :limit)) arg) (format t "~A~A" op (mode-symbol-to-char target mode)) @@ -405,12 +405,6 @@ (write-char #\:) (present arg 'number))) -(defmethod print-mode-change (target op (mode (eql :key)) arg) - (format t "~A~A" op (mode-symbol-to-char target mode)) - (when (not (null arg)) - (write-char #\:) - (present arg 'string))) - (macrolet ((define-mode-change-with-hostmask-printer (&rest modes) `(progn ,@(loop for mode in modes @@ -419,8 +413,8 @@ (present mask 'hostmask)))))) (define-mode-change-with-hostmask-printer :ban :invite :except)) -(defmethod print-mode-change (target op mode (arg (eql nil))) - (format t "~A~A" op (mode-symbol-to-char target mode))) +(defmethod print-mode-change (target op mode arg) + (format t "~A~A~:[~;:~A~]" op (mode-symbol-to-char target mode) arg arg)) (defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/01/27 17:18:04 1.8 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/02/25 15:22:22 1.9 @@ -88,7 +88,7 @@ (defun nick-equals-my-nick-p (nickname) (and (not (null *application-frame*)) - (not (null (slot-value *application-frame* 'connection))) + (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*) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/22 16:30:50 1.16 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 15:22:22 1.17 @@ -6,6 +6,7 @@ (all-unseen-messages :accessor all-unseen-messages :initform 0) (messages-directed-to-me :accessor messages-directed-to-me :initform 0) (channel :reader channel :initform nil :initarg :channel) + (connection :accessor connection :initarg :connection) (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. (focused-nicks :accessor focused-nicks :initform nil) (title :reader title :initarg :title) @@ -59,17 +60,18 @@ (change-space-requirements pane))) (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) +(defun find-receiver (name connection frame) + (gethash (list connection (irc:normalize-channel-name connection name)) (receivers frame))) -(defun intern-receiver (name frame &rest initargs) - (let* ((normalized-name (irc:normalize-channel-name (slot-value frame 'connection) name)) - (rec (find-receiver name frame))) +(defun intern-receiver (name connection frame &rest initargs) + (let* ((normalized-name (irc:normalize-channel-name connection name)) + (rec (find-receiver name connection frame))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-paneless-receiver normalized-name initargs))) + (let ((receiver (apply 'make-paneless-receiver normalized-name :connection connection + initargs))) (initialize-receiver-with-pane receiver frame (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) @@ -80,7 +82,7 @@ :display-time nil :min-width 600 :min-height 800 :incremental-redisplay t))) - (setf (gethash normalized-name (receivers frame)) receiver) + (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver))))) (defun remove-receiver (receiver frame) @@ -115,19 +117,19 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (let* ((mynick (irc:normalize-nickname (current-connection frame) (slot-value frame 'nick))) - (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) + (nominal-target (irc:normalize-channel-name (irc:connection message) (first (irc:arguments message)))) (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (cond ((find-receiver target frame) - (intern-receiver target frame :channel 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) (equal nominal-target mynick))) - (server-receiver frame)) + (server-receiver frame (irc:connection message))) (t - (intern-receiver target frame :channel target))))))) + (intern-receiver target (irc:connection message) 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)) @@ -136,7 +138,7 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (remove nil (mapcar (lambda (channel) - (find-receiver (irc:name channel) frame)) + (find-receiver (irc:name channel) (irc:connection message) frame)) (let ((user (irc:find-user (current-connection frame) (irc:source message)))) (when user @@ -160,7 +162,7 @@ (let ((target ,(if (numberp nth) `(nth ,nth (irc:arguments message)) `(first (last (irc:arguments message)))))) - (intern-receiver target frame :channel target)))))))) + (intern-receiver target (irc:connection message) frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message) (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message @@ -172,17 +174,17 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) (if (and - (null (find-receiver target frame)) + (null (find-receiver target (irc:connection message) 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)))) + (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)) + (1 (server-receiver frame (irc:connection message))) (t (destructuring-bind (channel modes &rest args) (irc:arguments message) (declare (ignore modes args)) - (intern-receiver channel frame :channel channel))))) + (intern-receiver channel (irc:connection message) frame :channel channel))))) (macrolet ((define-current-receiver-message-types (&rest mtypes) `(progn @@ -226,7 +228,7 @@ (defmethod receiver-for-message ((message irc:irc-message) frame) #+or ; comment out to debug on uncaught messages. (break) - (server-receiver frame)) + (server-receiver frame (irc:connection message))) ;; TODO: more receiver-for-message methods. From afuchs at common-lisp.net Sat Feb 25 15:28:01 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 25 Feb 2006 10:28:01 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060225152801.AA72F3A004@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16518 Modified Files: application.lisp Log Message: fix the query auto-closer (use the receiver's connection, not the frame-current one) --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 15:22:22 1.41 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 15:28:01 1.42 @@ -378,7 +378,7 @@ (= 0 (unseen-messages receiver) (all-unseen-messages receiver) (messages-directed-to-me receiver)) - (null (irc:find-channel (current-connection *application-frame*) (title 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*)) From afuchs at common-lisp.net Sat Feb 25 16:33:46 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 25 Feb 2006 11:33:46 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060225163346.7187A4C001@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv25613 Modified Files: application.lisp message-display.lisp Log Message: Fix printing of mode changes and the query auto-closer for multi-server support --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 15:28:01 1.42 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 16:33:46 1.43 @@ -373,7 +373,7 @@ (let ((receivers-to-close nil)) (maphash (lambda (name receiver) (declare (ignore name)) - (when (and (not (eql receiver (server-receiver *application-frame*))) + (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) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 15:22:22 1.33 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 16:33:46 1.34 @@ -426,7 +426,7 @@ channel 1c-mode))))))) (t (irc:destructuring-arguments (target &rest args) message - (let* ((connection (current-connection *application-frame*)) + (let* ((connection (connection message)) (target (or (irc:find-user connection target) (irc:find-channel connection target))) (mode-changes (irc:parse-mode-arguments connection target args From afuchs at common-lisp.net Sat Feb 25 17:26:56 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 25 Feb 2006 12:26:56 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060225172656.3D0174C00D@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv32740 Modified Files: message-display.lisp Log Message: argh. I forgot to qualify irc:connection --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 16:33:46 1.34 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 17:26:56 1.35 @@ -426,7 +426,7 @@ channel 1c-mode))))))) (t (irc:destructuring-arguments (target &rest args) message - (let* ((connection (connection message)) + (let* ((connection (irc:connection message)) (target (or (irc:find-user connection target) (irc:find-channel connection target))) (mode-changes (irc:parse-mode-arguments connection target args From afuchs at common-lisp.net Sat Feb 25 19:55:56 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 25 Feb 2006 14:55:56 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060225195556.353A72500F@common-lisp.net> 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))))) From mretzlaff at common-lisp.net Sat Feb 25 22:22:47 2006 From: mretzlaff at common-lisp.net (mretzlaff) Date: Sat, 25 Feb 2006 17:22:47 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060225222247.E716E2604C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv6414 Modified Files: variables.lisp Log Message: - Newline at end of file. --- /project/beirc/cvsroot/beirc/variables.lisp 2006/02/16 23:46:57 1.9 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/02/25 22:22:47 1.10 @@ -32,4 +32,4 @@ "Longest time an inactive query window will be kept around by the command /Close Inactive Queries and the automatic query window closing mechanism (see -*auto-close-inactive-query-windows-p*).") \ No newline at end of file +*auto-close-inactive-query-windows-p*).") From afuchs at common-lisp.net Sat Feb 25 23:28:11 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 25 Feb 2006 18:28:11 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060225232811.39BBB32003@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv14611 Modified Files: receivers.lisp Log Message: Fix pane/receiver removal. We didn't use the right hash key. argh. --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 19:55:56 1.18 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 23:28:11 1.19 @@ -88,7 +88,7 @@ (defun remove-receiver (receiver frame) (tab-layout:remove-pane (tab-pane receiver) (find-pane-named frame 'query)) - (remhash (title receiver) (receivers frame))) + (remhash (list (connection receiver) (title receiver)) (receivers frame))) (defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "") "Sources whose private messages (PRIVMSG, NOTICE, ...) should From afuchs at common-lisp.net Sun Feb 26 00:07:15 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 25 Feb 2006 19:07:15 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060226000715.118F77C005@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv20220 Modified Files: application.lisp Log Message: Fix /close. Rename /close inactive queries to /delete in[...]. Fix /quit * /Close now accepts server receivers and DTRT when it hits them. * /close inactive queries was getting in the way of the /close command. rename it to /delete inactive queries. * /quit threw an error; fixed that. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 19:55:55 1.44 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 00:07:15 1.45 @@ -139,6 +139,11 @@ (pushnew (cons connection newval) (slot-value frame 'connection-processes) :key #'car :test #'connection=)) +(defmethod remove-connection-process ((frame beirc) connection) + (setf (slot-value *application-frame* 'connection-processes) + (delete connection (connection-processes *application-frame*) :key #'car))) + + (defmethod current-nickname (&optional (connection (current-connection *application-frame*))) (let ((user (when connection (irc:user connection)))) @@ -247,7 +252,7 @@ (let ((pane (get-frame-pane frame 'status-bar))) (redisplay-frame-pane frame pane) (when *auto-close-inactive-query-windows-p* - (com-close-inactive-queries)) + (com-remove-inactive-queries)) (medium-force-output (sheet-medium pane)))) ;;; @@ -366,15 +371,18 @@ (switch-to-pane (nth (1- position) list-of-panes) 'tab-layout-pane))))) (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) - (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 - (irc:part connection channel))) + (cond + ((member receiver (server-receivers *application-frame*) :key #'cdr) + (disconnect connection *application-frame* "Client Quit") + (setf (slot-value *application-frame* 'server-receivers) + (delete receiver (server-receivers *application-frame*) :key #'cdr))) + (channel + (irc:part connection channel)))) (remove-receiver receiver *application-frame*)) -(define-beirc-command (com-close-inactive-queries :name t) () +(define-beirc-command (com-remove-inactive-queries :name t) () (let ((receivers-to-close nil)) (maphash (lambda (name receiver) (declare (ignore name)) @@ -763,13 +771,14 @@ (disconnect connection frame "Client error.")))))) (defun disconnect (connection frame reason) - (raise-receiver (server-receiver frame)) - (irc:quit connection reason) - (when (and (connection-process frame connection) - (not (eql (clim-sys:current-process) - (connection-process frame connection)))) - (destroy-process (connection-process frame connection))) - (setf (connection-process frame connection) nil)) + (let ((*application-frame* frame)) + (raise-receiver (server-receiver frame connection)) + (when (connection-process frame connection) + (irc:quit connection reason) + (when (not (eql (clim-sys:current-process) + (connection-process frame connection))) + (destroy-process (print (connection-process frame connection) *debug-io*))) + (remove-connection-process frame connection)))) (defun disconnect-all (frame reason) (loop for (conn . receiver) in (server-receivers frame) From afuchs at common-lisp.net Sun Feb 26 15:53:30 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Feb 2006 10:53:30 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060226155330.D197360012@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv30518 Modified Files: application.lisp Log Message: add /interesting window {previous,next} and add keystrokes to /window {next,prev} --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 00:07:15 1.45 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 15:53:30 1.46 @@ -348,27 +348,36 @@ (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) -(define-beirc-command (com-window-next :name t);; :keystroke (:right :meta)) - () - (let* ((current-pane (tab-layout::tab-pane-pane - (enabled-pane (find-pane-named *application-frame* 'query)))) - (list-of-panes (sheet-children (sheet-parent current-pane))) - (position (position current-pane list-of-panes))) - (when list-of-panes - (if (>= position (1- (length list-of-panes))) - (switch-to-pane (car list-of-panes) 'tab-layout-pane) - (switch-to-pane (nth (1+ position) list-of-panes) 'tab-layout-pane))))) - -(define-beirc-command (com-window-previous :name t);; :keystroke (:left :meta)) - () - (let* ((current-pane (tab-layout::tab-pane-pane - (enabled-pane (find-pane-named *application-frame* 'query)))) - (list-of-panes (sheet-children (sheet-parent current-pane))) - (position (position current-pane list-of-panes))) - (when list-of-panes - (if (<= position 0) - (switch-to-pane (car (last list-of-panes)) 'tab-layout-pane) - (switch-to-pane (nth (1- position) list-of-panes) 'tab-layout-pane))))) +(macrolet ((define-window-switcher (name keystroke direction predicate) + `(define-beirc-command (,name :name t :keystroke ,keystroke) + () + (let* ((current-pane (tab-layout::tab-pane-pane + (enabled-pane (find-pane-named *application-frame* 'query)))) + (list-of-panes (sheet-children (sheet-parent current-pane))) + (n-panes (length list-of-panes)) + (current-pane-position (position current-pane list-of-panes)) + (position current-pane-position) + (predicate ,predicate) + (step-by ,direction) + (start-position (- current-pane-position (* step-by n-panes))) + (end-position (+ current-pane-position (* step-by n-panes)))) + (when list-of-panes + (setf position + (loop for i = (+ step-by start-position) then (+ i step-by) + until (or (= i end-position) + (funcall predicate (nth (mod (+ n-panes i) n-panes) list-of-panes))) + finally (return i))) + (switch-to-pane (nth (mod (+ n-panes position) n-panes) list-of-panes) + 'tab-layout-pane)))))) + (labels ((pane-interesting-p (pane) + (let ((receiver (receiver-from-tab-pane + (find-in-tab-panes-list pane 'tab-layout-pane)))) + (or (> (messages-directed-to-me receiver) 0) + (> (unseen-messages receiver) 0))))) + (define-window-switcher com-interesting-window-next (#\Tab :control) 1 #'pane-interesting-p) + (define-window-switcher com-interesting-window-previous (:iso-left-tab :control :shift) -1 #'pane-interesting-p) + (define-window-switcher com-window-next (:next :control) 1 (constantly t)) + (define-window-switcher com-window-previous (:prior :control) -1 (constantly t)))) (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) (let* ((connection (current-connection *application-frame*)) From afuchs at common-lisp.net Sun Feb 26 18:41:21 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Feb 2006 13:41:21 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060226184121.63C25550D9@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv17598 Modified Files: application.lisp beirc.asd message-display.lisp Added Files: message-processing.lisp Log Message: factor out (and clean up) message processing from application.lisp and implement away status tracking. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 15:53:30 1.46 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/26 18:41:21 1.47 @@ -74,7 +74,8 @@ (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) (server-receivers :initform nil :reader server-receivers) - (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) + (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers) + (presence :initform (make-hash-table :test #'equal) :reader presence)) (:panes (io :interactor) @@ -143,6 +144,11 @@ (setf (slot-value *application-frame* 'connection-processes) (delete connection (connection-processes *application-frame*) :key #'car))) +(defmethod away-status ((frame beirc) connection) + (gethash connection (presence frame))) + +(defmethod (setf away-status) (newval (frame beirc) connection) + (setf (gethash connection (presence frame)) newval)) (defmethod current-nickname (&optional (connection (current-connection *application-frame*))) (let ((user (when connection @@ -160,9 +166,10 @@ (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) seconds - (format t "~2,'0D:~2,'0D ~A on ~A~@[ speaking to ~A~]~100T~D messages" + (format t "~2,'0D:~2,'0D ~A~:[~;(away)~] on ~A~@[ speaking to ~A~]~100T~D messages" hours minutes (current-nickname) + (away-status *application-frame* (current-connection *application-frame*)) (current-channel) (current-query) (length (current-messages)))))) @@ -786,7 +793,7 @@ (irc:quit connection reason) (when (not (eql (clim-sys:current-process) (connection-process frame connection))) - (destroy-process (print (connection-process frame connection) *debug-io*))) + (destroy-process (connection-process frame connection))) (remove-connection-process frame connection)))) (defun disconnect-all (frame reason) @@ -817,64 +824,6 @@ object))) (window-clear stream))) -(defun restart-beirc () - (clim-sys:destroy-process *gui-process*) - (setf *beirc-frame* nil) - (beirc) - (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))) - - -;;;;;;;;; - -(defmethod process-message (*application-frame* (message irc:irc-ping-message)) -; (describe message *trace-output*) -; (finish-output *trace-output*) - ;; ### - (irc:pong (current-connection *application-frame*) "localhost") - nil) ;### put the server you initially connected to here. - -(defmethod trailing-argument* (message) - (car (last (irc:arguments message)))) - -(defmethod trailing-argument* ((message cl-irc:ctcp-action-message)) - (or - (ignore-errors ;### - (let ((p1 (position #\space (car (last (irc:arguments message)))))) - (subseq (car (last (irc:arguments message))) - (1+ p1) - (1- (length (car (last (irc:arguments message)))))))) - "#Garbage parsing message#")) - -(defmethod process-message (*application-frame* (message cl-irc:ctcp-action-message)) -; (describe message *trace-output*) -; (print (trailing-argument* message) *trace-output*) - ) - -(defmethod process-message (*application-frame* message) -; (describe message *trace-output*) -; (finish-output *trace-output*) - nil) - -(defclass beirc-connection (irc:connection) - ()) - -(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)) - (defun irc-event-loop (frame connection) (unwind-protect (let ((*application-frame* frame)) --- /project/beirc/cvsroot/beirc/beirc.asd 2005/09/25 15:48:32 1.5 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/02/26 18:41:21 1.6 @@ -12,4 +12,5 @@ (:file "receivers" :depends-on ("package" "variables")) (:file "presentations" :depends-on ("package" "variables" "receivers")) (:file "message-display" :depends-on ("package" "variables" "presentations")) - (:file "application" :depends-on ("package" "variables" "presentations" "receivers")))) \ No newline at end of file + (:file "application" :depends-on ("package" "variables" "presentations" "receivers")) + (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 19:55:56 1.36 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/26 18:41:21 1.37 @@ -133,6 +133,18 @@ ;;; privmsg-like messages +(defmethod trailing-argument* (message) + (car (last (irc:arguments message)))) + +(defmethod trailing-argument* ((message cl-irc:ctcp-action-message)) + (or + (ignore-errors ;### + (let ((p1 (position #\space (car (last (irc:arguments message)))))) + (subseq (car (last (irc:arguments message))) + (1+ p1) + (1- (length (car (last (irc:arguments message)))))))) + "#Garbage parsing message#")) + (defun print-privmsg-like-message (message receiver start-string end-string) (with-drawing-options (*standard-output* --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/02/26 18:41:21 NONE +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/02/26 18:41:21 1.1 (in-package :beirc) ;;; Functions and protocols related to message processing in beirc. ;;; Incoming IRC messages are caught by specializing ;;; irc:irc-message-event, which processes messages in this way: ;;; ;;; 1. The message is preprocessed by preprocess-message. ;;; 2. The message is posted to the application frame. ;;; 3. The message is processed by cl-irc's hooks. (defvar *beirc-message-hooks* (make-hash-table)) (defclass beirc-connection (irc:connection) ()) (defmethod initialize-instance :after ((instance beirc-connection) &rest initargs) (declare (ignore initargs)) (loop for hooks being the hash-values in *beirc-message-hooks* using (hash-key message-class) do (loop for hook in hooks do (irc:add-hook instance message-class hook)))) (defmethod irc:irc-message-event :around ((connection beirc-connection) message) "Dispatch IRC messages to Beirc for display before cl-irc mangles the channel/connection/user state." (preprocess-message connection message) (post-message *application-frame* message) (call-next-method)) ;;; Message preprocessing (defmethod preprocess-message ((connection beirc-connection) (message irc:irc-nick-message)) "Change the connection's local user's nickname if it is the local user that changed its nickname." (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) ;;; Traditional cl-irc message hooks (defmacro define-beirc-hook (hook-name ((message-var &rest message-types)) &body body) "Convenience macro for defining message hooks that are added at connection instantiation time." `(progn (defun ,hook-name (,message-var) , at body) ,@(loop for message-type in message-types collect `(pushnew ',hook-name (gethash ',message-type *beirc-message-hooks*))) ',hook-name)) (define-beirc-hook update-away-status ((message irc:irc-rpl_noaway-message irc:irc-rpl_unaway-message)) "Set/Unset away status." (print (away-status *application-frame* (irc:connection message)) *debug-io*) (setf (away-status *application-frame* (irc:connection message)) (typep message 'irc:irc-rpl_noaway-message))) From afuchs at common-lisp.net Sun Feb 26 18:42:43 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 26 Feb 2006 13:42:43 -0500 (EST) Subject: [beirc-cvs] CVS beirc Message-ID: <20060226184243.E83FD550DA@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv17637 Modified Files: message-processing.lisp Log Message: remove annoying print statement. --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/02/26 18:41:21 1.1 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/02/26 18:42:43 1.2 @@ -55,6 +55,5 @@ (define-beirc-hook update-away-status ((message irc:irc-rpl_noaway-message irc:irc-rpl_unaway-message)) "Set/Unset away status." - (print (away-status *application-frame* (irc:connection message)) *debug-io*) (setf (away-status *application-frame* (irc:connection message)) (typep message 'irc:irc-rpl_noaway-message)))