From dmurray at common-lisp.net Mon Sep 12 18:13:10 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 12 Sep 2005 20:13:10 +0200 (CEST) Subject: [beirc-cvs] CVS update: Module imported: beirc Message-ID: <20050912181310.D14508855C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv28074 Log Message: Initial import into CVS Status: Vendor Tag: dmurray Release Tags: start N beirc/beirc.lisp No conflicts created by this import Date: Mon Sep 12 20:13:10 2005 Author: dmurray New module beirc added From afuchs at common-lisp.net Tue Sep 13 20:48:12 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Tue, 13 Sep 2005 22:48:12 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050913204812.BF541880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv12696 Modified Files: beirc.lisp Log Message: The multi-channel ("receiver") hack. This patch comes with a lot of problems. But it's just way too cool to just leave it out. (-: problems: * on join (you or anybody else), you are thrown into the debugger, with a message about a bounding-rectangle method that's not applicable to (NIL). Not investigated yet. * every time anybody (including you) sends a PRIVMSG, the interactor pane is wiped. This is related to the frame-redisplay-panes call in the (handle-event frame foo-event) method. * Every IRC message that isn't a JOIN, QUIT or PRIVMSG will land you in the terminal debugger. feel free to implement more receiver-for-message methods. Date: Tue Sep 13 22:48:12 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.1.1.1 beirc/beirc.lisp:1.2 --- beirc/beirc.lisp:1.1.1.1 Mon Sep 12 20:13:09 2005 +++ beirc/beirc.lisp Tue Sep 13 22:48:11 2005 @@ -28,6 +28,11 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; +(cl:eval-when (:compile-toplevel :load-toplevel :execute) + (cl:require :split-sequence) + (cl:require :cl-irc) + (cl:require :mcclim)) + (defpackage :beirc (:use :clim :clim-lisp :clim-sys) (:export #:beirc)) @@ -60,21 +65,130 @@ ;; is just the rest of the input line. ;; is a nickname of someone, with completion +(defclass receiver () + ((name :reader receiver-name :initarg :name) + (messages :accessor messages :initform nil) + (channel :reader channel :initform nil :initarg :channel) + (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. + (pane :reader pane :initform nil) + (focused-nicks :accessor focused-nicks :initform nil))) + +(defmethod initialize-instance :after ((object receiver) &rest initargs) + (declare (ignore initargs)) + (setf (slot-value object 'pane) + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (print (make-clim-application-pane + :display-function + (lambda (frame pane) + (beirc-app-display frame pane object)) + :display-time :command-loop + :width 400 :height 600 + :incremental-redisplay t) *debug-io*)))) + +(defun make-receiver (name &rest initargs) + (let ((receiver (apply 'make-instance 'receiver :name name initargs))) + (setf (gethash name (receivers *application-frame*)) + receiver) + (setf (gethash (pane receiver) (receiver-panes *application-frame*)) + receiver) + receiver)) + +(defun intern-receiver (name frame &rest initargs) + (let ((rec (gethash name (receivers frame)))) + (if rec + rec + (let ((*application-frame* frame)) + (apply 'make-receiver name initargs))))) + +(defun receiver-for-pane (pane &optional (frame *application-frame*)) + (gethash pane (receiver-panes frame))) + + +(defmethod receiver-for-message ((message irc:irc-privmsg-message) frame) + ;; XXX: handle target=ournick + (let ((target (first (irc:arguments message)))) + (intern-receiver target frame :channel target))) + +(defmethod receiver-for-message ((message irc:irc-join-message) frame) + (let ((target (first (irc:arguments message)))) + (intern-receiver target frame :channel target))) + +(defmethod receiver-for-message ((message irc:irc-quit-message) frame) + (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on. + ) + +;; TODO: more receiver-for-message methods. + +(macrolet ((define-delegate (function-name accessor &optional define-setter-p) + `(progn + ,(when define-setter-p + `(defun (setf ,function-name) (new-value &optional (frame *application-frame*)) + (when (current-receiver frame) + (setf (,accessor (current-receiver frame)) new-value)))) + (defun ,function-name (&optional (frame *application-frame*)) + (when (current-receiver frame) + (,accessor (current-receiver frame))))))) + (define-delegate current-channel channel) + (define-delegate current-query query) + (define-delegate current-pane pane) + (define-delegate current-messages messages t) + (define-delegate current-focused-nicks focused-nicks t)) + + + +(defclass stack-layout-pane (clim:sheet-multiple-child-mixin + clim:basic-pane) + ()) + +(defmethod compose-space ((pane stack-layout-pane) &key width height) + (declare (ignore width height)) + (reduce (lambda (x y) + (space-requirement-combine #'max x y)) + (mapcar #'compose-space (sheet-children pane)) + :initial-value + (make-space-requirement :width 0 :min-width 0 :max-width 0 + :height 0 :min-height 0 :max-height 0))) + +(defmethod allocate-space ((pane stack-layout-pane) width height) + (dolist (child (sheet-children pane)) + (move-and-resize-sheet child 0 0 width height) + (allocate-space child width height))) + +(defmethod initialize-instance :after ((pane stack-layout-pane) + &rest args + &key initial-contents + &allow-other-keys) + (declare (ignore args)) + (dolist (k initial-contents) + (sheet-adopt-child pane k))) + +(defun raise-receiver (receiver &optional (frame *application-frame*)) + (setf (current-receiver frame) receiver) + (mapcar (lambda (pane) + (let ((pane-receiver (receiver-for-pane pane frame))) + (setf (sheet-enabled-p pane) + (eql receiver pane-receiver)))) + (sheet-children (find-pane-named frame 'query)))) + (define-application-frame beirc () - ((connection :initform nil) - (messages :initform nil) - (query :initform nil) + ((current-receiver :initform nil :accessor current-receiver) + (connection :initform nil) (nick :initform nil) - (channel :initform nil) - (focused-nicks :initform nil) - (ignored-nicks :initform nil)) + (ignored-nicks :initform nil) + (receivers :initform (make-hash-table :test 'equal) :reader receivers) + (receiver-panes :initform (make-hash-table :test 'eql) :reader receiver-panes)) (:panes - (app :application - :display-function 'beirc-app-display - :display-time :command-loop - :incremental-redisplay t) (io :interactor) + (query (make-pane 'stack-layout-pane)) + (receiver-bar + :application + :display-function 'beirc-receivers-display + :display-time :command-loop + :incremental-redisplay t + :height 20 + :scroll-bars nil) (status-bar :application :display-function 'beirc-status-display @@ -90,8 +204,10 @@ (:layouts (default (vertically () - app + query (60 io) + (20 + receiver-bar) (20 ;<-- Sigh! Bitrot! status-bar ))))) @@ -99,6 +215,14 @@ (defvar *beirc-frame*) +(defun beirc-receivers-display (*application-frame* *standard-output*) + (with-text-family (t :sans-serif) + (maphash (lambda (key value) + (declare (ignore key)) + (present value 'receiver :stream *standard-output*) + (format t " ")) + (receivers *application-frame*)))) + (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)) @@ -106,14 +230,14 @@ (format t "~2,'0D:~2,'0D ~A on ~A~@[ speaking to ~A~]~100T~D messages" hours minutes (slot-value *application-frame* 'nick) - (slot-value *application-frame* 'channel) - (slot-value *application-frame* 'query) - (length (slot-value *application-frame* 'messages)))))) + (current-channel) + (current-query) + (length (current-messages)))))) (defun beirc-prompt (*standard-output* *application-frame*) (format *standard-output* "Beirc ~A => " - (or (slot-value *application-frame* 'query) - (slot-value *application-frame* 'channel)))) + (or (current-query) + (current-channel)))) ;; (defun format-message (prefix mumble) ;; (write-line @@ -131,14 +255,14 @@ (cond (start (write-string (subseq url 0 start)) (present (concatenate 'string - "file://localhost/path/to/your/HyperSpec/" + "file://localhost/Users/dmurray/lisp/HyperSpec/" (subseq url (+ 45 start))) 'url)) (t (present url 'url))))) (defun format-message* (preamble mumble &key (prefix " ") - (limit 105)) + (limit 100)) (loop for word in (split-sequence:split-sequence #\Space mumble) with line-prefix = prefix with column = (+ (length line-prefix) (length preamble)) @@ -161,7 +285,7 @@ (define-presentation-type url () :inherit-from 'string) -(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE)) +(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) (with-drawing-options (*standard-output* :ink (if (string-equal "localhost" (irc:host message)) @@ -171,7 +295,7 @@ :test #'string=) (with-text-face (*standard-output* - (if (member (irc:source message) (slot-value *application-frame* 'focused-nicks) + (if (member (irc:source message) (current-focused-nicks) :test #'string=) :bold :roman)) @@ -189,7 +313,7 @@ (format nil "*~A*" (irc:source message))))))) (format-message* preamble (irc:trailing-argument message))))))) -(defmethod print-message ((message irc:ctcp-action-message)) +(defmethod print-message ((message irc:ctcp-action-message) receiver) (let ((source (cl-irc:source message)) (matter (trailing-argument* message)) (dest (car (cl-irc:arguments message)))) @@ -198,19 +322,18 @@ source) matter))) -(defmethod print-message ((message irc:irc-quit-message)) +(defmethod print-message ((message irc:irc-quit-message) receiver) (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format-message* (format nil "~10T Quit: ~A;" (irc:source message)) (irc:trailing-argument message)))) -(defmethod print-message ((message irc:irc-join-message)) +(defmethod print-message ((message irc:irc-join-message) receiver) (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format *standard-output* "~10T Join: ~A (~A@~A)" (irc:source message) (irc:user message) - (irc:host message) - (irc:trailing-argument message)) + (irc:host message)) (terpri) )) ;;; Here comes the trick: @@ -222,7 +345,8 @@ ;;; we send it to the frame. (defclass foo-event (clim:window-manager-event) - ((sheet :initarg :sheet :reader event-sheet))) + ((sheet :initarg :sheet :reader event-sheet) + (receiver :initarg :receiver :reader receiver))) ;;for updating the time display, triggered from TICKER (defclass bar-event (clim:window-manager-event) @@ -244,11 +368,14 @@ (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. - (let ((pane (get-frame-pane frame 'app))) + (let* ((receiver (receiver event)) + (pane (pane receiver))) ; FIXME: pane isn't a stream pane, but a VRACK-PANE. gack. (let ((btmp (pane-scrolled-to-bottom-p pane))) - (time (redisplay-frame-pane frame pane)) - (when btmp - (scroll-pane-to-bottom pane))) + (setf (pane-needs-redisplay pane) t) + (time (redisplay-frame-panes frame :force-p t)) +;; (when btmp +;; (scroll-pane-to-bottom pane)) + ) (medium-force-output (sheet-medium pane)) ;### )) @@ -273,12 +400,13 @@ (run-frame-top-level frame)))))))) (defun post-message (frame message) - (setf (slot-value frame 'messages) - (append (slot-value frame 'messages) (list message))) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame)) - nil) + (let ((receiver (receiver-for-message message frame))) + (setf (messages receiver) + (append (messages receiver) (list message))) + (clim-internals::event-queue-prepend + (climi::frame-event-queue frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil)) (defun ticker (frame) (loop @@ -293,13 +421,30 @@ res) (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) - (with-slots (connection nick channel) *application-frame* - (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection channel)))))) + (with-slots (connection nick) *application-frame* + (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))) (accept `(member , at users) :prompt nil)))) +(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) + (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) + (maphash #'suggest (receivers *application-frame*)))) + +(define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key) + (format t "~A" (receiver-name o))) + +(define-presentation-to-command-translator raise-this-receiver + (receiver com-raise-receiver beirc + :gesture :select + :documentation "Raise this receiver") + (presentation) + (list (presentation-object presentation))) + +(define-beirc-command (com-raise-receiver :name t) ((receiver 'receiver :prompt "Receiver")) + (raise-receiver receiver)) + (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) - (pushnew who (slot-value *application-frame* 'focused-nicks) :test #'string=)) + (pushnew who (current-focused-nicks) :test #'string=)) (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who")) (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) @@ -309,12 +454,12 @@ (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=))) (define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who")) - (setf (slot-value *application-frame* 'focused-nicks) - (remove who (slot-value *application-frame* 'focused-nicks) :test #'string=))) + (setf (current-focused-nicks) + (remove who (current-focused-nicks) :test #'string=))) (defun target (&optional (*application-frame* *application-frame*)) - (or (slot-value *application-frame* 'query) - (slot-value *application-frame* 'channel))) + (or (current-query) + (current-channel))) (define-beirc-command (com-say :name t) ((what 'mumble)) ;; make a fake IRC-PRIV-MESSAGE object @@ -347,11 +492,11 @@ (list (presentation-object presentation))) (define-beirc-command (com-join :name t) ((channel 'string :prompt "channel")) - (when (slot-value *application-frame* 'channel) - (irc:part - (slot-value *application-frame* 'connection) - (slot-value *application-frame* 'channel))) - (setf (slot-value *application-frame* 'channel) channel) + (setf (current-receiver *application-frame*) + (intern-receiver channel *application-frame* :channel channel)) + (sheet-adopt-child (find-pane-named *application-frame* 'query) + (pane (current-receiver *application-frame*))) + (raise-receiver (current-receiver *application-frame*)) (irc:join (slot-value *application-frame* 'connection) channel)) (define-beirc-command (com-connect :name t) @@ -381,12 +526,12 @@ (window-clear stream))) (defun restart-beirc () - (let ((m (slot-value *beirc-frame* 'messages))) + (let ((m (current-messages))) (clim-sys:destroy-process *gui-process*) (setf *beirc-frame* nil) (beirc) (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*)) - (setf (slot-value *beirc-frame* 'messages) m))) + (setf (current-messages) m))) ;;;;;;;;; @@ -436,36 +581,37 @@ (irc:read-message-loop connection) ) (irc:remove-all-hooks connection))) -(defun beirc-app-display (*application-frame* *standard-output*) +(defun beirc-app-display (*application-frame* *standard-output* receiver) ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly! + ;; Fix me: as is all that *standard-output* stuff + (print *standard-output* *debug-io*) + (print (pane receiver) *debug-io*) (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*)) (clim:stream-string-width *standard-output* "X")) - 2))) - (with-slots (messages) *application-frame* - (let ((k 100) - (n (length messages))) - (loop for i below (* k (ceiling n k)) by k do + 2)) + (messages (and receiver (messages receiver)))) + (let ((k 100) + (n (length messages))) + (loop for i below (* k (ceiling n k)) by k do + (updating-output (*standard-output* + :unique-id i + :cache-value + (list (min n (+ i k)) + (focused-nicks receiver) + (slot-value *application-frame* 'ignored-nicks) + w) + :cache-test #'equal) + (loop for j from i below (min n (+ i k)) do + (let ((m (elt messages j))) (updating-output (*standard-output* - :unique-id i + :unique-id j :cache-value - (list (min n (+ i k)) - (slot-value *application-frame* 'focused-nicks) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal - ) - (loop for j from i below (min n (+ i k)) do - (let ((m (elt messages j))) - (updating-output (*standard-output* - :unique-id j - :cache-value - (list m - (slot-value *application-frame* 'focused-nicks) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal - ) - (print-message m)))))))))) + (list m + (focused-nicks receiver) + (slot-value *application-frame* 'ignored-nicks) + w) + :cache-test #'equal) + (print-message m receiver))))))))) ;;; Hack: (defmethod allocate-space :after ((pane climi::viewport-pane) w h) From afuchs at common-lisp.net Wed Sep 14 20:12:43 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Wed, 14 Sep 2005 22:12:43 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050914201243.B0F908853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv15544 Modified Files: beirc.lisp Log Message: Fix (mostly) two of the three known problems and implement "unseen messages" functionality in the receiver list. * on join (you or anybody else), you are no longer thrown into the debugger (the problem was that I missed the : in the IRC spec for JOIN messages. the channel is passed as the trailing arg. * implemented more message types for the receiver finder; beirc can now stay on #lisp for more than 5 minutes without barfing! Date: Wed Sep 14 22:12:42 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.2 beirc/beirc.lisp:1.3 --- beirc/beirc.lisp:1.2 Tue Sep 13 22:48:11 2005 +++ beirc/beirc.lisp Wed Sep 14 22:12:40 2005 @@ -31,7 +31,8 @@ (cl:eval-when (:compile-toplevel :load-toplevel :execute) (cl:require :split-sequence) (cl:require :cl-irc) - (cl:require :mcclim)) + (cl:require :mcclim) + (cl:require :mcclim-freetype)) (defpackage :beirc (:use :clim :clim-lisp :clim-sys) @@ -68,6 +69,8 @@ (defclass receiver () ((name :reader receiver-name :initarg :name) (messages :accessor messages :initform nil) + (unseen-messages :accessor 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. (pane :reader pane :initform nil) @@ -105,18 +108,36 @@ (gethash pane (receiver-panes frame))) +;;; FIXME: many of these methods are the same and should be refactored +;;; into perhaps three types. (defmethod receiver-for-message ((message irc:irc-privmsg-message) frame) ;; XXX: handle target=ournick (let ((target (first (irc:arguments message)))) (intern-receiver target frame :channel target))) -(defmethod receiver-for-message ((message irc:irc-join-message) frame) +(defmethod receiver-for-message ((message irc:ctcp-action-message) frame) + ;; XXX: handle target=ournick (let ((target (first (irc:arguments message)))) (intern-receiver target frame :channel target))) +(defmethod receiver-for-message ((message irc:irc-notice-message) frame) + ;; XXX: handle target=ournick + (let ((target (first (irc:arguments message)))) + (intern-receiver target frame :channel target))) + +(defmethod receiver-for-message ((message irc:irc-join-message) frame) + (let ((target (irc:trailing-argument message))) + (intern-receiver target frame :channel target))) + (defmethod receiver-for-message ((message irc:irc-quit-message) frame) (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on. ) +(defmethod receiver-for-message ((message irc:irc-nick-message) frame) + (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on. + ) +(defmethod receiver-for-message ((message irc:irc-part-message) frame) + (let ((target (first (irc:arguments message)))) + (intern-receiver target frame :channel target))) ;; TODO: more receiver-for-message methods. @@ -160,11 +181,14 @@ &key initial-contents &allow-other-keys) (declare (ignore args)) - (dolist (k initial-contents) + (dolist (k (or initial-contents + (list (make-clim-application-pane)))) (sheet-adopt-child pane k))) (defun raise-receiver (receiver &optional (frame *application-frame*)) (setf (current-receiver frame) receiver) + (setf (unseen-messages receiver) 0) + (setf (messages-directed-to-me receiver) 0) (mapcar (lambda (pane) (let ((pane-receiver (receiver-for-pane pane frame))) (setf (sheet-enabled-p pane) @@ -399,10 +423,19 @@ :name "Beirc Ticker") (run-frame-top-level frame)))))))) +(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))) + (defun post-message (frame message) (let ((receiver (receiver-for-message message frame))) (setf (messages receiver) (append (messages receiver) (list message))) + (unless (eql receiver (current-receiver frame)) + (incf (unseen-messages receiver)) + (when (message-directed-to-me-p frame message) + (incf (messages-directed-to-me receiver)))) (clim-internals::event-queue-prepend (climi::frame-event-queue frame) (make-instance 'foo-event :sheet frame :receiver receiver)) @@ -431,7 +464,10 @@ (maphash #'suggest (receivers *application-frame*)))) (define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key) - (format t "~A" (receiver-name o))) + (with-drawing-options (t :ink (cond ((> (messages-directed-to-me o) 0) +green+) + ((> (unseen-messages o) 0) +red+) + (t +black+))) + (format t "~A" (receiver-name o)))) (define-presentation-to-command-translator raise-this-receiver (receiver com-raise-receiver beirc From afuchs at common-lisp.net Wed Sep 14 20:31:46 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Wed, 14 Sep 2005 22:31:46 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.asd beirc/package.lisp beirc/beirc.lisp Message-ID: <20050914203146.1BD1F8853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv17582 Modified Files: beirc.lisp Added Files: beirc.asd package.lisp Log Message: add a system definition for beirc and split out the package definition into package.lisp Date: Wed Sep 14 22:31:45 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.3 beirc/beirc.lisp:1.4 --- beirc/beirc.lisp:1.3 Wed Sep 14 22:12:40 2005 +++ beirc/beirc.lisp Wed Sep 14 22:31:44 2005 @@ -28,16 +28,6 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; -(cl:eval-when (:compile-toplevel :load-toplevel :execute) - (cl:require :split-sequence) - (cl:require :cl-irc) - (cl:require :mcclim) - (cl:require :mcclim-freetype)) - -(defpackage :beirc - (:use :clim :clim-lisp :clim-sys) - (:export #:beirc)) - (in-package :beirc) ;;;; Quick guide: From afuchs at common-lisp.net Wed Sep 14 21:00:41 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Wed, 14 Sep 2005 23:00:41 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050914210041.D7B8D8853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv18781 Modified Files: beirc.lisp Log Message: fix the last known issue: redisplay now leaves a good-looking set of panes. also, remove a lot of debug PRINT statements. Date: Wed Sep 14 23:00:40 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.4 beirc/beirc.lisp:1.5 --- beirc/beirc.lisp:1.4 Wed Sep 14 22:31:44 2005 +++ beirc/beirc.lisp Wed Sep 14 23:00:35 2005 @@ -66,18 +66,31 @@ (pane :reader pane :initform nil) (focused-nicks :accessor focused-nicks :initform nil))) +;;; KLUDGE: make-clim-application-pane doesn't return an application +;;; pane, but a pane that wraps the application pane. we need the +;;; application pane for redisplay, though. +(defun actual-application-pane (pane) + "Find the actual clim:application-pane buried the layers and + layers of wrapping panes that make-clim-application-pane + returns." + (if (typep pane 'clim:application-pane) + pane + (loop for child in (sheet-children pane) + for found-pane = (actual-application-pane child) + if found-pane do (return found-pane)))) + (defmethod initialize-instance :after ((object receiver) &rest initargs) (declare (ignore initargs)) (setf (slot-value object 'pane) (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) - (print (make-clim-application-pane + (make-clim-application-pane :display-function (lambda (frame pane) (beirc-app-display frame pane object)) :display-time :command-loop :width 400 :height 600 - :incremental-redisplay t) *debug-io*)))) + :incremental-redisplay t)))) (defun make-receiver (name &rest initargs) (let ((receiver (apply 'make-instance 'receiver :name name initargs))) @@ -383,13 +396,12 @@ ;; Hack: ;; Figure out if we are scrolled to the bottom. (let* ((receiver (receiver event)) - (pane (pane receiver))) ; FIXME: pane isn't a stream pane, but a VRACK-PANE. gack. + (pane (actual-application-pane (pane receiver)))) (let ((btmp (pane-scrolled-to-bottom-p pane))) (setf (pane-needs-redisplay pane) t) - (time (redisplay-frame-panes frame :force-p t)) -;; (when btmp -;; (scroll-pane-to-bottom pane)) - ) + (time (redisplay-frame-pane frame pane)) + (when btmp + (scroll-pane-to-bottom pane))) (medium-force-output (sheet-medium pane)) ;### )) @@ -610,8 +622,6 @@ (defun beirc-app-display (*application-frame* *standard-output* receiver) ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly! ;; Fix me: as is all that *standard-output* stuff - (print *standard-output* *debug-io*) - (print (pane receiver) *debug-io*) (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*)) (clim:stream-string-width *standard-output* "X")) 2)) From afuchs at common-lisp.net Wed Sep 14 21:24:01 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Wed, 14 Sep 2005 23:24:01 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050914212401.C7A098853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv20827 Modified Files: beirc.lisp Log Message: on linux systems, use the binary x-www-browser to open URLs. This assumes that every linux system runs debian. Umm. Don't they? Date: Wed Sep 14 23:24:01 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.5 beirc/beirc.lisp:1.6 --- beirc/beirc.lisp:1.5 Wed Sep 14 23:00:35 2005 +++ beirc/beirc.lisp Wed Sep 14 23:24:00 2005 @@ -400,6 +400,7 @@ (let ((btmp (pane-scrolled-to-bottom-p pane))) (setf (pane-needs-redisplay pane) t) (time (redisplay-frame-pane frame pane)) + (redisplay-frame-pane frame (find-pane-named frame 'receiver-bar)) (when btmp (scroll-pane-to-bottom pane))) (medium-force-output (sheet-medium pane)) ;### @@ -522,7 +523,11 @@ #+ (and sbcl darwin) (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil) #+ (and openmcl darwin) - (ccl:run-program "/usr/bin/open" `(,url) :wait nil)) + (ccl:run-program "/usr/bin/open" `(,url) :wait nil) + ;; XXX: daring assumption. perhaps this should use x-www-browser on + ;; debian/debian systems? + #+ (and sbcl linux) + (sb-ext:run-program "/usr/bin/x-www-browser" `(,url) :wait nil)) (define-presentation-to-command-translator url-to-browse-url-translator (url com-browse-url beirc) From afuchs at common-lisp.net Sat Sep 17 16:51:23 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 17 Sep 2005 18:51:23 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050917165123.491C188550@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv12615 Modified Files: beirc.lisp Log Message: fix printing of /me messages. Date: Sat Sep 17 18:51:22 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.6 beirc/beirc.lisp:1.7 --- beirc/beirc.lisp:1.6 Wed Sep 14 23:24:00 2005 +++ beirc/beirc.lisp Sat Sep 17 18:51:21 2005 @@ -674,7 +674,7 @@ (define-beirc-command (com-me :name t) ((what 'mumble)) (with-slots (connection nick) *application-frame* - (let ((m (make-instance 'irc:irc-privmsg-message + (let ((m (make-instance 'irc:ctcp-action-message :received-time (get-universal-time) :connection :local :trailing-argument From afuchs at common-lisp.net Sat Sep 17 19:23:16 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 17 Sep 2005 21:23:16 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp beirc/beirc.asd beirc/beirc.lisp Message-ID: <20050917192316.6CF4388031@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv23141 Modified Files: beirc.asd beirc.lisp Added Files: message-display.lisp Log Message: Factor out displaying of messages to message-display.lisp and add table-formatting. * move beirc-app-display and print-message methods into message-display.lisp * make print-message methods display messages inside a table to make their "interesting part" all start in the same column. (similar to XChat's message display or ERC's fill-static behavior) * PRESENT nicknames if we can identify them (currently, only by irc:source or if it's our own) * strip punctuation from URL and nickname presentation (but display them anyway) Date: Sat Sep 17 21:23:14 2005 Author: afuchs Index: beirc/beirc.asd diff -u beirc/beirc.asd:1.1 beirc/beirc.asd:1.2 --- beirc/beirc.asd:1.1 Wed Sep 14 22:31:44 2005 +++ beirc/beirc.asd Sat Sep 17 21:23:14 2005 @@ -8,4 +8,5 @@ (defsystem :beirc :depends-on (:mcclim :cl-irc :split-sequence) :components ((:file "package") - (:file "beirc" :depends-on ("package")))) \ No newline at end of file + (:file "beirc" :depends-on ("package")) + (:file "message-display" :depends-on ("package" "beirc")))) \ No newline at end of file Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.7 beirc/beirc.lisp:1.8 --- beirc/beirc.lisp:1.7 Sat Sep 17 18:51:21 2005 +++ beirc/beirc.lisp Sat Sep 17 21:23:14 2005 @@ -277,91 +277,6 @@ ;; "~:@>") ;; prefix))) -(defun present-url (url) - (let ((start (search "http://www.lispworks.com/reference/HyperSpec/" url))) - (cond (start - (write-string (subseq url 0 start)) - (present (concatenate 'string - "file://localhost/Users/dmurray/lisp/HyperSpec/" - (subseq url (+ 45 start))) - 'url)) - (t (present url 'url))))) - -(defun format-message* (preamble mumble - &key (prefix " ") - (limit 100)) - (loop for word in (split-sequence:split-sequence #\Space mumble) - with line-prefix = prefix - with column = (+ (length line-prefix) (length preamble)) - with column-limit = limit - initially (with-drawing-options (*standard-output* :ink +dark-red+) - (write-string preamble)) - when (> (+ column (length word)) column-limit) - do (terpri) - (write-string line-prefix) - (setf column (length line-prefix)) - else do (write-char #\Space) - (incf column) - do - (if (search "http://" word) - (present-url word) - (write-string word)) - (incf column (length word))) - (terpri)) - -(define-presentation-type url () - :inherit-from 'string) - -(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) - (with-drawing-options - (*standard-output* - :ink (if (string-equal "localhost" (irc:host message)) - +blue4+ - +black+)) - (unless (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) - :test #'string=) - (with-text-face - (*standard-output* - (if (member (irc:source message) (current-focused-nicks) - :test #'string=) - :bold - :roman)) - (format t "~&[~2,'0D:~2,'0D] " - (nth-value 2 (decode-universal-time (irc:received-time message))) - (nth-value 1 (decode-universal-time (irc:received-time message)))) - (let ((preamble - (cond ((string-equal "localhost" (irc:host message)) - (if (char= (char (first (irc:arguments message)) 0) #\#) - (format nil ">") - (format nil "-> *~A*" (first (irc:arguments message))))) - (t - (if (char= (char (first (irc:arguments message)) 0) #\#) - (format nil "<~A>" (irc:source message)) - (format nil "*~A*" (irc:source message))))))) - (format-message* preamble (irc:trailing-argument message))))))) - -(defmethod print-message ((message irc:ctcp-action-message) receiver) - (let ((source (cl-irc:source message)) - (matter (trailing-argument* message)) - (dest (car (cl-irc:arguments message)))) - (format-message* (format nil " *~A ~A" - (if (char= (char (first (irc:arguments message)) 0) #\#) "" ">") - source) - matter))) - -(defmethod print-message ((message irc:irc-quit-message) receiver) - (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~10T Quit: ~A;" - (irc:source message)) - (irc:trailing-argument message)))) - -(defmethod print-message ((message irc:irc-join-message) receiver) - (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format *standard-output* "~10T Join: ~A (~A@~A)" - (irc:source message) - (irc:user message) - (irc:host message)) - (terpri) )) ;;; Here comes the trick: @@ -466,6 +381,17 @@ (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) (maphash #'suggest (receivers *application-frame*)))) +(defun nick-equals-my-nick-p (nickname) + (and *application-frame* + (string= nickname (slot-value *application-frame* 'nick)))) + +(define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key) + (if (nick-equals-my-nick-p o) + (with-drawing-options (t :ink +green+) + (with-text-face (t :bold) + (format t "~A" o))) + (format t "~A" o))) + (define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key) (with-drawing-options (t :ink (cond ((> (messages-directed-to-me o) 0) +green+) ((> (unseen-messages o) 0) +red+) @@ -613,6 +539,10 @@ (progn (irc:add-hook connection 'irc:irc-privmsg-message (lambda (m) (post-message frame m))) + (irc:add-hook connection 'irc:irc-nick-message + (lambda (m) (post-message frame m))) + (irc:add-hook connection 'irc:irc-part-message + (lambda (m) (post-message frame m))) (irc:add-hook connection 'irc:irc-quit-message (lambda (m) (post-message frame m))) (irc:add-hook connection 'irc:irc-join-message @@ -624,35 +554,6 @@ (irc:read-message-loop connection) ) (irc:remove-all-hooks connection))) -(defun beirc-app-display (*application-frame* *standard-output* receiver) - ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly! - ;; Fix me: as is all that *standard-output* stuff - (let ((w (- (floor (bounding-rectangle-width (sheet-parent *standard-output*)) - (clim:stream-string-width *standard-output* "X")) - 2)) - (messages (and receiver (messages receiver)))) - (let ((k 100) - (n (length messages))) - (loop for i below (* k (ceiling n k)) by k do - (updating-output (*standard-output* - :unique-id i - :cache-value - (list (min n (+ i k)) - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (loop for j from i below (min n (+ i k)) do - (let ((m (elt messages j))) - (updating-output (*standard-output* - :unique-id j - :cache-value - (list m - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (print-message m receiver))))))))) ;;; Hack: (defmethod allocate-space :after ((pane climi::viewport-pane) w h) From afuchs at common-lisp.net Sat Sep 17 20:41:43 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 17 Sep 2005 22:41:43 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050917204143.A153788031@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv28251 Modified Files: beirc.lisp Log Message: add a KLUDGE-y workaround for mcclim bug "Application pane vertical scrolling does not work with table formatting" (from Tim Moore) Date: Sat Sep 17 22:41:43 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.8 beirc/beirc.lisp:1.9 --- beirc/beirc.lisp:1.8 Sat Sep 17 21:23:14 2005 +++ beirc/beirc.lisp Sat Sep 17 22:41:42 2005 @@ -198,7 +198,20 @@ (eql receiver pane-receiver)))) (sheet-children (find-pane-named frame 'query)))) -(define-application-frame beirc () +;;; KLUDGE: workaround for mcclim bug "Application pane vertical +;;; scrolling does not work with table formatting" + +(defclass redisplay-frame-mixin () + ()) + +(defmethod redisplay-frame-pane :after + ((frame redisplay-frame-mixin) (pane application-pane) &key force-p) + (declare (ignore force-p)) + (change-space-requirements + pane :height (bounding-rectangle-height (stream-output-history pane)))) + +(define-application-frame beirc (redisplay-frame-mixin + standard-application-frame) ((current-receiver :initform nil :accessor current-receiver) (connection :initform nil) (nick :initform nil) From afuchs at common-lisp.net Sat Sep 17 21:28:30 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 17 Sep 2005 23:28:30 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050917212830.A304188550@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv31339 Modified Files: beirc.lisp Log Message: Refactor the receiver-for-message definitions and fix incoming PRIVMSGs to us. Date: Sat Sep 17 23:28:30 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.9 beirc/beirc.lisp:1.10 --- beirc/beirc.lisp:1.9 Sat Sep 17 22:41:42 2005 +++ beirc/beirc.lisp Sat Sep 17 23:28:29 2005 @@ -101,49 +101,52 @@ receiver)) (defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash name (receivers frame)))) + (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) + name) (receivers frame)))) (if rec rec (let ((*application-frame* frame)) - (apply 'make-receiver name initargs))))) + (let ((receiver (apply 'make-receiver name initargs))) + (setf (sheet-enabled-p (pane receiver)) nil) + (sheet-adopt-child (find-pane-named *application-frame* 'query) + (pane receiver)) + receiver))))) (defun receiver-for-pane (pane &optional (frame *application-frame*)) (gethash pane (receiver-panes frame))) - -;;; FIXME: many of these methods are the same and should be refactored -;;; into perhaps three types. -(defmethod receiver-for-message ((message irc:irc-privmsg-message) frame) - ;; XXX: handle target=ournick - (let ((target (first (irc:arguments message)))) - (intern-receiver target frame :channel target))) - -(defmethod receiver-for-message ((message irc:ctcp-action-message) frame) - ;; XXX: handle target=ournick - (let ((target (first (irc:arguments message)))) - (intern-receiver target frame :channel target))) - -(defmethod receiver-for-message ((message irc:irc-notice-message) frame) - ;; XXX: handle target=ournick - (let ((target (first (irc:arguments message)))) - (intern-receiver target frame :channel target))) +(macrolet ((define-privmsg-receiver-lookup (message-type) + `(defmethod receiver-for-message ((message ,message-type) frame) + (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection) + (slot-value frame 'nick))) + (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) + (first (irc:arguments message)))) + (target (if (equal nominal-target mynick) + (irc:source message) + nominal-target))) + (intern-receiver target frame :channel target))))) + (define-privmsg-receiver-lookup irc:irc-privmsg-message) + (define-privmsg-receiver-lookup irc:ctcp-action-message) + (define-privmsg-receiver-lookup irc:irc-notice-message)) + +(macrolet ((define-global-message-receiver-lookup (message-type) + `(defmethod receiver-for-message ((message ,message-type) frame) + ;; FIXME: global messages should go to all + ;; channels/queries the source (user) was on. + (current-receiver frame)))) + (define-global-message-receiver-lookup irc:irc-quit-message) + (define-global-message-receiver-lookup irc:irc-nick-message)) (defmethod receiver-for-message ((message irc:irc-join-message) frame) (let ((target (irc:trailing-argument message))) (intern-receiver target frame :channel target))) -(defmethod receiver-for-message ((message irc:irc-quit-message) frame) - (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on. - ) -(defmethod receiver-for-message ((message irc:irc-nick-message) frame) - (current-receiver frame) ; FIXME: quit messages should go to all channels/queries the user was on. - ) (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) (intern-receiver target frame :channel target))) - ;; TODO: more receiver-for-message methods. + (macrolet ((define-delegate (function-name accessor &optional define-setter-p) `(progn ,(when define-setter-p @@ -476,8 +479,6 @@ (define-beirc-command (com-join :name t) ((channel 'string :prompt "channel")) (setf (current-receiver *application-frame*) (intern-receiver channel *application-frame* :channel channel)) - (sheet-adopt-child (find-pane-named *application-frame* 'query) - (pane (current-receiver *application-frame*))) (raise-receiver (current-receiver *application-frame*)) (irc:join (slot-value *application-frame* 'connection) channel)) From afuchs at common-lisp.net Sat Sep 17 22:23:00 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 18 Sep 2005 00:23:00 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050917222300.EA34588031@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv3523 Modified Files: beirc.lisp message-display.lisp Log Message: add more general nickname highlighting and use current-connection consistently Date: Sun Sep 18 00:22:58 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.10 beirc/beirc.lisp:1.11 --- beirc/beirc.lisp:1.10 Sat Sep 17 23:28:29 2005 +++ beirc/beirc.lisp Sun Sep 18 00:22:57 2005 @@ -162,8 +162,6 @@ (define-delegate current-messages messages t) (define-delegate current-focused-nicks focused-nicks t)) - - (defclass stack-layout-pane (clim:sheet-multiple-child-mixin clim:basic-pane) ()) @@ -216,7 +214,7 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) ((current-receiver :initform nil :accessor current-receiver) - (connection :initform nil) + (connection :initform nil :reader current-connection) (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test 'equal) :reader receivers) @@ -315,8 +313,11 @@ (defun pane-scrolled-to-bottom-p (pane) (multiple-value-bind (x y) (transform-position (sheet-transformation pane) 0 0) + (declare (ignore x)) (with-bounding-rectangle* (x1 y1 x2 y2) pane + (declare (ignore x1 y1 x2)) (with-bounding-rectangle* (ax1 ay1 ax2 ay2) (sheet-parent pane) + (declare (ignore ax1 ay1 ax2)) (<= (+ y y2) ay2))))) (defun scroll-pane-to-bottom (pane) @@ -455,11 +456,11 @@ :USER "localuser" :SOURCE (slot-value *application-frame* 'nick) )) - (irc:privmsg (slot-value *application-frame* 'connection) (target) what)) + (irc:privmsg (current-connection *application-frame*) (target) what)) (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 (slot-value *application-frame* 'connection) new-nick)) + (irc:nick (current-connection *application-frame*) new-nick)) (define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url")) #+ (and sbcl darwin) @@ -480,17 +481,17 @@ (setf (current-receiver *application-frame*) (intern-receiver channel *application-frame* :channel channel)) (raise-receiver (current-receiver *application-frame*)) - (irc:join (slot-value *application-frame* 'connection) channel)) + (irc:join (current-connection *application-frame*) channel)) (define-beirc-command (com-connect :name t) ((server 'string :prompt "Server") (nick 'string :prompt "Nick name")) - (cond ((slot-value *application-frame* 'connection) + (cond ((current-connection *application-frame*) (format *query-io* "You are already connected.~%")) (t (setf (slot-value *application-frame* 'connection) (irc:connect :nickname nick :server server)) (setf (slot-value *application-frame* 'nick) nick) - (let ((connection (slot-value *application-frame* 'connection))) + (let ((connection (current-connection *application-frame*))) (let ((frame *application-frame*)) (clim-sys:make-process #'(lambda () (irc-event-loop frame connection)) @@ -523,7 +524,7 @@ ; (describe message *trace-output*) ; (finish-output *trace-output*) ;; ### - (irc:pong (slot-value *application-frame* 'connection) "localhost") + (irc:pong (current-connection *application-frame*) "localhost") nil) ;### put the server you initially connected to here. (defmethod trailing-argument* (message) @@ -614,7 +615,7 @@ :HOST "localhost" :USER "localuser" :SOURCE (slot-value *application-frame* 'nick) )) - (irc:privmsg (slot-value *application-frame* 'connection) target what)) + (irc:privmsg (current-connection *application-frame*) target what)) (define-beirc-command (com-msg :name t) ((target 'nickname :prompt "who") (what 'mumble :prompt "what")) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.1 beirc/message-display.lisp:1.2 --- beirc/message-display.lisp:1.1 Sat Sep 17 21:23:14 2005 +++ beirc/message-display.lisp Sun Sep 18 00:22:57 2005 @@ -75,7 +75,7 @@ (cond ((search "http://" word*) (present-url word*)) - ((nick-equals-my-nick-p word*) + ((irc:find-user (current-connection *application-frame*) word*) (present word* 'nickname)) (t (write-string word*))) (write-string stripped-punctuation)) From afuchs at common-lisp.net Sat Sep 17 22:34:04 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 18 Sep 2005 00:34:04 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050917223404.267BD88031@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv4524 Modified Files: beirc.lisp message-display.lisp Log Message: fix highlighting of yor own nickname (which broke in the last checkin). Date: Sun Sep 18 00:34:02 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.11 beirc/beirc.lisp:1.12 --- beirc/beirc.lisp:1.11 Sun Sep 18 00:22:57 2005 +++ beirc/beirc.lisp Sun Sep 18 00:34:00 2005 @@ -400,7 +400,10 @@ (defun nick-equals-my-nick-p (nickname) (and *application-frame* - (string= nickname (slot-value *application-frame* 'nick)))) + (equal (irc:normalize-nickname (current-connection *application-frame*) + (slot-value *application-frame* 'nick)) + (irc:normalize-nickname (current-connection *application-frame*) + nickname)))) (define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key) (if (nick-equals-my-nick-p o) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.2 beirc/message-display.lisp:1.3 --- beirc/message-display.lisp:1.2 Sun Sep 18 00:22:57 2005 +++ beirc/message-display.lisp Sun Sep 18 00:34:00 2005 @@ -75,7 +75,9 @@ (cond ((search "http://" word*) (present-url word*)) - ((irc:find-user (current-connection *application-frame*) word*) + ((or + (nick-equals-my-nick-p word*) + (irc:find-user (current-connection *application-frame*) word*)) (present word* 'nickname)) (t (write-string word*))) (write-string stripped-punctuation)) From dmurray at common-lisp.net Fri Sep 23 09:52:42 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Fri, 23 Sep 2005 11:52:42 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp beirc/beirc.lisp Message-ID: <20050923095242.714AB880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv9434 Modified Files: message-display.lisp beirc.lisp Log Message: Switched time-stamps to right-hand column. Better wrapping of message column. Date: Fri Sep 23 11:52:41 2005 Author: dmurray Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.3 beirc/message-display.lisp:1.4 --- beirc/message-display.lisp:1.3 Sun Sep 18 00:34:00 2005 +++ beirc/message-display.lisp Fri Sep 23 11:52:40 2005 @@ -1,7 +1,7 @@ (in-package :beirc) (defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") -(defparameter *default-fill-column* 100) +(defparameter *default-fill-column* 80) (defvar *max-preamble-length* 0) @@ -16,6 +16,15 @@ *hyperspec-base-url* (subseq url (+ 45 start))) 'url)) + ((> (length url) *default-fill-column*) + (let ((new-url + (concatenate 'string + (subseq url 0 (floor *default-fill-column* 2)) + "..." + (subseq url (- (length url) + (- (floor *default-fill-column* 2) 3)))))) + (with-output-as-presentation (t url 'url) + (write-string new-url)))) (t (present url 'url))))) (defun message-from-focused-nick-p (message receiver) @@ -47,48 +56,49 @@ *max-preamble-length*) :cache-test #'equal) (formatting-row (,stream*) - (formatting-cell (,stream* :align-x :left) - (format ,stream* "~&[~2,'0D:~2,'0D] " - (nth-value 2 (decode-universal-time (irc:received-time message))) - (nth-value 1 (decode-universal-time (irc:received-time message))))) - (formatting-cell (,stream* :align-x :right) - (with-drawing-options (*standard-output* :ink +dark-red+) + (formatting-cell (,stream* :align-x :right :min-width '(16 :character)) + (with-drawing-options (,stream* :ink +dark-red+) , at preamble-column-body)) - (formatting-cell (,stream* :align-x :left) - , at message-body-column-body)))))) + (formatting-cell (,stream* :align-x :left + :min-width '(80 :character)) + , at message-body-column-body) + (formatting-cell (,stream* :align-x :left) + (with-drawing-options (,stream* :ink +gray+) + (format ,stream* "[~2,'0D:~2,'0D]" + (nth-value 2 (decode-universal-time (irc:received-time message))) + (nth-value 1 (decode-universal-time (irc:received-time message))))))))))) (defun strip-punctuation (word) (if (= (length word) 0) (values word "") (let ((last-char (char word (1- (length word))))) (case last-char - ((#\: #\, #\. #\;) + ((#\: #\, #\. #\; #\) #\] #\} #\> #\? #\! #\" #\') (values (subseq word 0 (1- (length word))) (string last-char))) (otherwise (values word "")))))) -(defun format-message* (mumble &key (limit *default-fill-column*)) +(defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) - with column = 0 - with column-limit = limit - do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word) - (cond - ((search "http://" word*) - (present-url word*)) - ((or - (nick-equals-my-nick-p word*) - (irc:find-user (current-connection *application-frame*) word*)) - (present word* 'nickname)) - (t (write-string word*))) - (write-string stripped-punctuation)) - ;; TODO: nick highlighting via presentations - (incf column (length word)) - when (> column column-limit) - do (setf column 0) - (terpri) - else unless (null rest) - do (write-char #\Space) - (incf column)) + with column = start-length + do (incf column (length word)) + when (> column limit) + do (setf column (length word)) + (terpri) + do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word) + (cond + ((search "http://" word*) + (present-url word*)) + ((or + (nick-equals-my-nick-p word*) + (irc:find-user (current-connection *application-frame*) word*)) + (present word* 'nickname)) + (t (write-string word*))) + (write-string stripped-punctuation)) + ;; TODO: more highlighting + unless (or (null rest) (>= column limit)) + do (write-char #\Space) + (incf column)) (terpri)) (defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) @@ -114,20 +124,21 @@ ((format t "*")) ((present source 'nickname) (format t " ") - (format-message* matter))))) + (format-message* matter :start-length (+ 2 (length source))))))) (defmethod print-message ((message irc:irc-quit-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((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)))))) + (format-message* (irc:trailing-argument message) + :start-length (+ 8 (length (irc:source message)))))))) (defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Join: ") (present (irc:source message) 'nickname) @@ -135,7 +146,7 @@ (defmethod print-message ((message irc:irc-nick-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Nick change: ") (present (irc:source message) 'nickname) @@ -144,7 +155,7 @@ (defmethod print-message ((message irc:irc-part-message) receiver) (formatting-message (t message receiver) - ((format t "***")) + ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Part: ") (present (irc:source message) 'nickname) Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.12 beirc/beirc.lisp:1.13 --- beirc/beirc.lisp:1.12 Sun Sep 18 00:34:00 2005 +++ beirc/beirc.lisp Fri Sep 23 11:52:40 2005 @@ -407,7 +407,7 @@ (define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key) (if (nick-equals-my-nick-p o) - (with-drawing-options (t :ink +green+) + (with-drawing-options (t :ink +darkgreen+) (with-text-face (t :bold) (format t "~A" o))) (format t "~A" o))) From afuchs at common-lisp.net Fri Sep 23 19:05:17 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Fri, 23 Sep 2005 21:05:17 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.asd beirc/beirc.lisp beirc/package.lisp Message-ID: <20050923190517.7796D880DB@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv15507 Modified Files: beirc.asd beirc.lisp package.lisp Log Message: Integrate Max-Gerd Retzlaff's tab-layout extension. Also, add a few p-to-command-translators for nicknames (focus, query, ignore) Date: Fri Sep 23 21:05:16 2005 Author: afuchs Index: beirc/beirc.asd diff -u beirc/beirc.asd:1.2 beirc/beirc.asd:1.3 --- beirc/beirc.asd:1.2 Sat Sep 17 21:23:14 2005 +++ beirc/beirc.asd Fri Sep 23 21:05:15 2005 @@ -6,7 +6,7 @@ (cl:in-package :beirc.system) (defsystem :beirc - :depends-on (:mcclim :cl-irc :split-sequence) + :depends-on (:mcclim :cl-irc :split-sequence :tab-layout) :components ((:file "package") (:file "beirc" :depends-on ("package")) (:file "message-display" :depends-on ("package" "beirc")))) Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.13 beirc/beirc.lisp:1.14 --- beirc/beirc.lisp:1.13 Fri Sep 23 11:52:40 2005 +++ beirc/beirc.lisp Fri Sep 23 21:05:15 2005 @@ -57,14 +57,15 @@ ;; is a nickname of someone, with completion (defclass receiver () - ((name :reader receiver-name :initarg :name) - (messages :accessor messages :initform nil) + ((messages :accessor messages :initform nil) (unseen-messages :accessor 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. - (pane :reader pane :initform nil) - (focused-nicks :accessor focused-nicks :initform nil))) + (focused-nicks :accessor focused-nicks :initform nil) + (title :reader title :initarg :title) + (pane :reader pane) + (tab-pane :accessor tab-pane))) ;;; KLUDGE: make-clim-application-pane doesn't return an application ;;; pane, but a pane that wraps the application pane. we need the @@ -88,33 +89,27 @@ :display-function (lambda (frame pane) (beirc-app-display frame pane object)) - :display-time :command-loop + :display-time nil :width 400 :height 600 - :incremental-redisplay t)))) + :incremental-redisplay t))) + (setf (slot-value object 'tab-pane) + (make-tab-pane-from-list (title object) (pane object) 'receiver))) (defun make-receiver (name &rest initargs) - (let ((receiver (apply 'make-instance 'receiver :name name initargs))) - (setf (gethash name (receivers *application-frame*)) - receiver) - (setf (gethash (pane receiver) (receiver-panes *application-frame*)) - receiver) + (let ((receiver (apply 'make-instance 'receiver :title name initargs))) receiver)) (defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) - name) (receivers frame)))) + (let ((rec (gethash name (receivers frame)))) (if rec rec (let ((*application-frame* frame)) (let ((receiver (apply 'make-receiver name initargs))) - (setf (sheet-enabled-p (pane receiver)) nil) - (sheet-adopt-child (find-pane-named *application-frame* 'query) - (pane receiver)) + (add-pane (tab-pane receiver) (find-pane-named frame 'query)) + (setf (gethash name (receivers frame)) receiver) + (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver) receiver))))) -(defun receiver-for-pane (pane &optional (frame *application-frame*)) - (gethash pane (receiver-panes frame))) - (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection) @@ -146,7 +141,6 @@ (intern-receiver target frame :channel target))) ;; TODO: more receiver-for-message methods. - (macrolet ((define-delegate (function-name accessor &optional define-setter-p) `(progn ,(when define-setter-p @@ -158,46 +152,29 @@ (,accessor (current-receiver frame))))))) (define-delegate current-channel channel) (define-delegate current-query query) - (define-delegate current-pane pane) (define-delegate current-messages messages t) (define-delegate current-focused-nicks focused-nicks t)) -(defclass stack-layout-pane (clim:sheet-multiple-child-mixin - clim:basic-pane) - ()) - -(defmethod compose-space ((pane stack-layout-pane) &key width height) - (declare (ignore width height)) - (reduce (lambda (x y) - (space-requirement-combine #'max x y)) - (mapcar #'compose-space (sheet-children pane)) - :initial-value - (make-space-requirement :width 0 :min-width 0 :max-width 0 - :height 0 :min-height 0 :max-height 0))) - -(defmethod allocate-space ((pane stack-layout-pane) width height) - (dolist (child (sheet-children pane)) - (move-and-resize-sheet child 0 0 width height) - (allocate-space child width height))) - -(defmethod initialize-instance :after ((pane stack-layout-pane) - &rest args - &key initial-contents - &allow-other-keys) - (declare (ignore args)) - (dolist (k (or initial-contents - (list (make-clim-application-pane)))) - (sheet-adopt-child pane k))) +(defun update-drawing-options (receiver) + (set-drawing-options-for-pane-in-tab-layout (pane receiver) + `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+) + ((> (unseen-messages receiver) 0) +red+) + (t +black+))))) + +(defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane))) + (let ((receiver (receiver-from-tab-pane + (find-in-tab-panes-list pane + (find-pane-named *application-frame* 'query))))) + (unless (null receiver) + (setf (unseen-messages receiver) 0) + (setf (messages-directed-to-me receiver) 0) + (update-drawing-options receiver)))) + -(defun raise-receiver (receiver &optional (frame *application-frame*)) - (setf (current-receiver frame) receiver) +(defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) - (mapcar (lambda (pane) - (let ((pane-receiver (receiver-for-pane pane frame))) - (setf (sheet-enabled-p pane) - (eql receiver pane-receiver)))) - (sheet-children (find-pane-named frame 'query)))) + (switch-to-pane (pane receiver) 'tab-layout-pane)) ;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" @@ -213,23 +190,14 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) - ((current-receiver :initform nil :accessor current-receiver) - (connection :initform nil :reader current-connection) + ((connection :initform nil :reader current-connection) (nick :initform nil) (ignored-nicks :initform nil) - (receivers :initform (make-hash-table :test 'equal) :reader receivers) - (receiver-panes :initform (make-hash-table :test 'eql) :reader receiver-panes)) + (receivers :initform (make-hash-table :test #'equal) :accessor receivers) + (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) (:panes (io :interactor) - (query (make-pane 'stack-layout-pane)) - (receiver-bar - :application - :display-function 'beirc-receivers-display - :display-time :command-loop - :incremental-redisplay t - :height 20 - :scroll-bars nil) (status-bar :application :display-function 'beirc-status-display @@ -239,31 +207,36 @@ :height 20 :scroll-bars nil :background +black+ - :foreground +white+) ) + :foreground +white+) + (server + :application + ;; TODO: server message display. + )) (:geometry :width 800 :height 600) (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt)) (:layouts (default (vertically () - query + (with-tab-layout ('receiver :name 'query) + ("Server" server)) (60 io) - (20 - receiver-bar) (20 ;<-- Sigh! Bitrot! status-bar ))))) +(defun receiver-from-tab-pane (tab-pane) + (gethash tab-pane + (tab-panes-to-receivers *application-frame*))) + +(defmethod current-receiver ((frame beirc)) + (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query))))) + (if (typep receiver 'receiver) + receiver + nil))) + (defvar *gui-process* nil) (defvar *beirc-frame*) -(defun beirc-receivers-display (*application-frame* *standard-output*) - (with-text-family (t :sans-serif) - (maphash (lambda (key value) - (declare (ignore key)) - (present value 'receiver :stream *standard-output*) - (format t " ")) - (receivers *application-frame*)))) - (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)) @@ -331,10 +304,8 @@ (pane (actual-application-pane (pane receiver)))) (let ((btmp (pane-scrolled-to-bottom-p pane))) (setf (pane-needs-redisplay pane) t) - (time (redisplay-frame-pane frame pane)) - (redisplay-frame-pane frame (find-pane-named frame 'receiver-bar)) - (when btmp - (scroll-pane-to-bottom pane))) + (time (redisplay-frame-panes frame)) + (when btmp (scroll-pane-to-bottom pane))) (medium-force-output (sheet-medium pane)) ;### )) @@ -368,9 +339,11 @@ (setf (messages receiver) (append (messages receiver) (list message))) (unless (eql receiver (current-receiver frame)) + (print "hallo" *debug-io*) (incf (unseen-messages receiver)) (when (message-directed-to-me-p frame message) (incf (messages-directed-to-me receiver)))) + (update-drawing-options receiver) (clim-internals::event-queue-prepend (climi::frame-event-queue frame) (make-instance 'foo-event :sheet frame :receiver receiver)) @@ -383,6 +356,7 @@ (sleep 1))) (define-presentation-type nickname ()) +(define-presentation-type ignored-nickname (nickname)) (defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) @@ -391,8 +365,11 @@ (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) (with-slots (connection nick) *application-frame* (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))) - (accept `(member , at users) - :prompt nil)))) + (accept `(member , at users) :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))) (define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) @@ -412,12 +389,6 @@ (format t "~A" o))) (format t "~A" o))) -(define-presentation-method present (o (type receiver) *standard-output* (view textual-view) &key) - (with-drawing-options (t :ink (cond ((> (messages-directed-to-me o) 0) +green+) - ((> (unseen-messages o) 0) +red+) - (t +black+))) - (format t "~A" (receiver-name o)))) - (define-presentation-to-command-translator raise-this-receiver (receiver com-raise-receiver beirc :gesture :select @@ -425,7 +396,10 @@ (presentation) (list (presentation-object presentation))) -(define-beirc-command (com-raise-receiver :name t) ((receiver 'receiver :prompt "Receiver")) +(define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) + (raise-receiver (intern-receiver nick *application-frame* :query nick))) + +(define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) @@ -434,7 +408,7 @@ (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who")) (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) -(define-beirc-command (com-unignore :name t) ((who 'nickname :prompt "who")) +(define-beirc-command (com-unignore :name t) ((who 'ignored-nickname :prompt "who")) (setf (slot-value *application-frame* 'ignored-nicks) (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=))) @@ -442,6 +416,9 @@ (setf (current-focused-nicks) (remove who (current-focused-nicks) :test #'string=))) +(define-beirc-command (com-quit :name t) ((reason 'string :prompt "reason")) + (irc:quit (current-connection *application-frame*) reason)) + (defun target (&optional (*application-frame* *application-frame*)) (or (current-query) (current-channel))) @@ -475,15 +452,37 @@ #+ (and sbcl linux) (sb-ext:run-program "/usr/bin/x-www-browser" `(,url) :wait nil)) +(define-presentation-to-command-translator nickname-to-ignore-translator + (nickname com-ignore beirc + :gesture :menu + :menu t + :documentation "Ignore this user") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-focus-translator + (nickname com-focus beirc + :gesture :menu + :menu t + :documentation "Focus this user") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-query-translator + (nickname com-query beirc + :gesture :menu + :menu t + :documentation "Query this user") + (object) + (list object)) + (define-presentation-to-command-translator url-to-browse-url-translator (url com-browse-url beirc) (presentation) (list (presentation-object presentation))) (define-beirc-command (com-join :name t) ((channel 'string :prompt "channel")) - (setf (current-receiver *application-frame*) - (intern-receiver channel *application-frame* :channel channel)) - (raise-receiver (current-receiver *application-frame*)) + (raise-receiver (intern-receiver channel *application-frame* :channel channel)) (irc:join (current-connection *application-frame*) channel)) (define-beirc-command (com-connect :name t) @@ -493,6 +492,8 @@ (t (setf (slot-value *application-frame* 'connection) (irc:connect :nickname nick :server server)) + (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*)) Index: beirc/package.lisp diff -u beirc/package.lisp:1.1 beirc/package.lisp:1.2 --- beirc/package.lisp:1.1 Wed Sep 14 22:31:44 2005 +++ beirc/package.lisp Fri Sep 23 21:05:15 2005 @@ -1,3 +1,3 @@ (cl:defpackage :beirc - (:use :clim :clim-lisp :clim-sys) + (:use :clim :clim-lisp :clim-sys :tab-layout) (:export #:beirc)) From afuchs at common-lisp.net Fri Sep 23 21:31:41 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Fri, 23 Sep 2005 23:31:41 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050923213141.C88D1880DB@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv25178 Modified Files: beirc.lisp message-display.lisp Log Message: baby steps towards a server buffer. * don't register hook functions into cl-irc anymore, just catch all of them and tries to print them in a mostly sensible manner in the *Server* buffer. * doesn't actually display the messages, as redisplay is broken, for only the Server buffer. * requires cl-irc cvs patched with http://common-lisp.net/pipermail/cl-irc-devel/2005-September/000061.html anybody who can fix the redisplay issue is welcome to do so (-: Date: Fri Sep 23 23:31:39 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.14 beirc/beirc.lisp:1.15 --- beirc/beirc.lisp:1.14 Fri Sep 23 21:05:15 2005 +++ beirc/beirc.lisp Fri Sep 23 23:31:27 2005 @@ -80,34 +80,57 @@ for found-pane = (actual-application-pane child) if found-pane do (return found-pane)))) -(defmethod initialize-instance :after ((object receiver) &rest initargs) - (declare (ignore initargs)) - (setf (slot-value object 'pane) - (with-look-and-feel-realization - ((frame-manager *application-frame*) *application-frame*) - (make-clim-application-pane - :display-function - (lambda (frame pane) - (beirc-app-display frame pane object)) - :display-time nil - :width 400 :height 600 - :incremental-redisplay t))) - (setf (slot-value object 'tab-pane) - (make-tab-pane-from-list (title object) (pane object) 'receiver))) - -(defun make-receiver (name &rest initargs) - (let ((receiver (apply 'make-instance 'receiver :title name initargs))) - receiver)) +;;; another KLUDGE: define-application-frame-defined panes (as +;;; find-pane-named returns them) /don't/ come wrapped - they are +;;; stored as the application pane itself. Of course, tab-layout +;;; /expects/ them wrapped, so we recurse through the parents to find +;;; the granddaughter of a tab-layout-pane. +(defun direct-tab-pane-child-from (pane) + "Given a pane, find the parent pane that is the direct child of +a tab-layout-pane's radio-layout-pane." + (labels ((has-parent-p (pane) (and (typep pane 'clim:sheet-parent-mixin) + (not (null (sheet-parent pane))))) + (grandparent (pane) + (if (and (has-parent-p pane) (has-parent-p (sheet-parent pane))) + (sheet-parent (sheet-parent pane))))) + (cond + ((typep (grandparent pane) 'tab-layout-pane) pane) + ((has-parent-p pane) (direct-tab-pane-child-from (sheet-parent pane))) + (t nil)))) + +(defun make-paneless-receiver (name &rest initargs) + (apply 'make-instance 'receiver :title name initargs)) + +(defun initialize-receiver-with-pane (receiver frame pane &key (add-pane-p t)) + (setf (slot-value receiver 'pane) pane) + (if (not add-pane-p) + (setf (slot-value receiver 'tab-pane) + (find-in-tab-panes-list (direct-tab-pane-child-from pane) + 'tab-layout-pane)) + (progn + (setf (slot-value receiver 'tab-pane) + (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver)) + (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) + (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) (defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash name (receivers frame)))) + (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) + (receivers frame)))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-receiver name initargs))) - (add-pane (tab-pane receiver) (find-pane-named frame 'query)) + (let ((receiver (apply 'make-paneless-receiver name initargs))) + (initialize-receiver-with-pane receiver frame + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (make-clim-application-pane + :display-function + (lambda (frame pane) + (beirc-app-display frame pane receiver)) + :display-time nil + :width 400 :height 600 + :incremental-redisplay t))) (setf (gethash name (receivers frame)) receiver) - (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver) receiver))))) (macrolet ((define-privmsg-receiver-lookup (message-type) @@ -122,7 +145,8 @@ (intern-receiver target frame :channel target))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) - (define-privmsg-receiver-lookup irc:irc-notice-message)) + ;; (define-privmsg-receiver-lookup irc:irc-notice-message) ; XXX: NOTICEs in freenode are a bit tricky. + ) (macrolet ((define-global-message-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) @@ -139,6 +163,10 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) (intern-receiver target frame :channel target))) + +(defmethod receiver-for-message ((message irc:irc-message) frame) + (server-receiver frame)) + ;; TODO: more receiver-for-message methods. (macrolet ((define-delegate (function-name accessor &optional define-setter-p) @@ -156,7 +184,7 @@ (define-delegate current-focused-nicks focused-nicks t)) (defun update-drawing-options (receiver) - (set-drawing-options-for-pane-in-tab-layout (pane receiver) + (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver)) `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+) ((> (unseen-messages receiver) 0) +red+) (t +black+))))) @@ -174,7 +202,7 @@ (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) - (switch-to-pane (pane receiver) 'tab-layout-pane)) + (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane)) ;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" @@ -194,6 +222,7 @@ (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) + (server-receiver :initform (make-paneless-receiver "*Server*") :reader server-receiver) (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) (:panes (io @@ -210,22 +239,25 @@ :foreground +white+) (server :application - ;; TODO: server message display. - )) + :display (lambda (frame pane) + (beirc-app-display frame pane (server-receiver *application-frame*))) + :display-time :command-loop + :width 400 + :height 600 + :incremental-redisplay t)) (:geometry :width 800 :height 600) (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt)) (:layouts (default (vertically () (with-tab-layout ('receiver :name 'query) - ("Server" server)) + ("*Server*" server)) (60 io) (20 ;<-- Sigh! Bitrot! - status-bar ))))) + status-bar))))) (defun receiver-from-tab-pane (tab-pane) - (gethash tab-pane - (tab-panes-to-receivers *application-frame*))) + (gethash tab-pane (tab-panes-to-receivers *application-frame*))) (defmethod current-receiver ((frame beirc)) (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query))))) @@ -339,7 +371,6 @@ (setf (messages receiver) (append (messages receiver) (list message))) (unless (eql receiver (current-receiver frame)) - (print "hallo" *debug-io*) (incf (unseen-messages receiver)) (when (message-directed-to-me-p frame message) (incf (messages-directed-to-me receiver)))) @@ -364,8 +395,9 @@ (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) (with-slots (connection nick) *application-frame* - (let ((users (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))) - (accept `(member , at users) :prompt nil)))) + (let ((users (unless (null (current-channel)) + (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))) + (accept `(or (member , at users) string) :prompt nil)))) (define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key) (with-slots (ignored-nicks) *application-frame* @@ -491,12 +523,15 @@ (format *query-io* "You are already connected.~%")) (t (setf (slot-value *application-frame* 'connection) - (irc:connect :nickname nick :server server)) + (irc:connect :nickname nick :server server :connection-type 'beirc-connection)) (setf (irc:client-stream (current-connection *application-frame*)) (make-broadcast-stream)) (setf (slot-value *application-frame* 'nick) nick) (let ((connection (current-connection *application-frame*))) (let ((frame *application-frame*)) + (initialize-receiver-with-pane (server-receiver frame) frame + (find-pane-named frame 'server) + :add-pane-p nil) (clim-sys:make-process #'(lambda () (irc-event-loop frame connection)) :name "IRC Message Muffling Loop") ))))) @@ -553,24 +588,18 @@ ; (finish-output *trace-output*) nil) +(defclass beirc-connection (irc:connection) + ()) + +(defmethod irc:read-message :around ((connection beirc-connection)) + (let ((message (call-next-method connection))) + (post-message *application-frame* message) + message)) + (defun irc-event-loop (frame connection) (unwind-protect - (progn - (irc:add-hook connection 'irc:irc-privmsg-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-nick-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-part-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-quit-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-join-message - (lambda (m) (post-message frame m))) - (irc:add-hook connection 'irc:irc-ping-message - (lambda (m) (process-message frame m))) - (irc:add-hook connection 'cl-irc:ctcp-action-message - (lambda (m) (post-message frame m))) - (irc:read-message-loop connection) ) + (let ((*application-frame* frame)) + (irc:read-message-loop connection)) (irc:remove-all-hooks connection))) ;;; Hack: Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.4 beirc/message-display.lisp:1.5 --- beirc/message-display.lisp:1.4 Fri Sep 23 11:52:40 2005 +++ beirc/message-display.lisp Fri Sep 23 23:31:27 2005 @@ -101,7 +101,7 @@ (incf column)) (terpri)) -(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) +(defun print-privmsg-like-message (message receiver start-string end-string) (with-drawing-options (*standard-output* :ink (if (string-equal "localhost" (irc:host message)) @@ -112,10 +112,16 @@ (*standard-output* (if (message-from-focused-nick-p message receiver) :bold :roman)) (formatting-message (t message receiver) - ((format t "<") - (present (irc:source message) 'nickname) - (format t ">")) - ((format-message* (irc:trailing-argument message)))))))) + ((write-string start-string *standard-output*) + (present (irc:source message) 'nickname) + (write-string end-string *standard-output*)) + ((format-message* (irc:trailing-argument message)))))))) + +(defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) + (print-privmsg-like-message message receiver "<" ">")) + +(defmethod print-message ((message irc:IRC-NOTICE-MESSAGE) receiver) + (print-privmsg-like-message message receiver "-" "-")) (defmethod print-message ((message irc:ctcp-action-message) receiver) (let ((source (cl-irc:source message)) @@ -161,6 +167,11 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) +(defmethod print-message (message receiver) + (formatting-message (t message receiver) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message)))))) (defgeneric preamble-length (message) (:method ((message irc:irc-privmsg-message)) From afuchs at common-lisp.net Fri Sep 23 22:06:00 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 00:06:00 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050923220600.6AFF0880DB@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv28512 Modified Files: beirc.lisp Log Message: Make server buffer display messages & delete previous KLUDGE. * Also, try and dtrt on /quit. Date: Sat Sep 24 00:06:00 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.15 beirc/beirc.lisp:1.16 --- beirc/beirc.lisp:1.15 Fri Sep 23 23:31:27 2005 +++ beirc/beirc.lisp Sat Sep 24 00:05:54 2005 @@ -80,24 +80,6 @@ for found-pane = (actual-application-pane child) if found-pane do (return found-pane)))) -;;; another KLUDGE: define-application-frame-defined panes (as -;;; find-pane-named returns them) /don't/ come wrapped - they are -;;; stored as the application pane itself. Of course, tab-layout -;;; /expects/ them wrapped, so we recurse through the parents to find -;;; the granddaughter of a tab-layout-pane. -(defun direct-tab-pane-child-from (pane) - "Given a pane, find the parent pane that is the direct child of -a tab-layout-pane's radio-layout-pane." - (labels ((has-parent-p (pane) (and (typep pane 'clim:sheet-parent-mixin) - (not (null (sheet-parent pane))))) - (grandparent (pane) - (if (and (has-parent-p pane) (has-parent-p (sheet-parent pane))) - (sheet-parent (sheet-parent pane))))) - (cond - ((typep (grandparent pane) 'tab-layout-pane) pane) - ((has-parent-p pane) (direct-tab-pane-child-from (sheet-parent pane))) - (t nil)))) - (defun make-paneless-receiver (name &rest initargs) (apply 'make-instance 'receiver :title name initargs)) @@ -105,7 +87,7 @@ (setf (slot-value receiver 'pane) pane) (if (not add-pane-p) (setf (slot-value receiver 'tab-pane) - (find-in-tab-panes-list (direct-tab-pane-child-from pane) + (find-in-tab-panes-list pane 'tab-layout-pane)) (progn (setf (slot-value receiver 'tab-pane) @@ -184,7 +166,7 @@ (define-delegate current-focused-nicks focused-nicks t)) (defun update-drawing-options (receiver) - (set-drawing-options-for-pane-in-tab-layout (direct-tab-pane-child-from (pane receiver)) + (set-drawing-options-for-pane-in-tab-layout (pane receiver) `(:ink ,(cond ((> (messages-directed-to-me receiver) 0) +green+) ((> (unseen-messages receiver) 0) +red+) (t +black+))))) @@ -202,7 +184,7 @@ (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) - (switch-to-pane (direct-tab-pane-child-from (pane receiver)) 'tab-layout-pane)) + (switch-to-pane (pane receiver) 'tab-layout-pane)) ;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" @@ -238,13 +220,13 @@ :background +black+ :foreground +white+) (server - :application - :display (lambda (frame pane) - (beirc-app-display frame pane (server-receiver *application-frame*))) - :display-time :command-loop - :width 400 - :height 600 - :incremental-redisplay t)) + (make-clim-application-pane + :display-function + (lambda (frame pane) + (beirc-app-display frame pane (server-receiver *application-frame*))) + :display-time nil + :width 400 :height 600 + :incremental-redisplay t))) (:geometry :width 800 :height 600) (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt)) (:layouts @@ -448,7 +430,7 @@ (setf (current-focused-nicks) (remove who (current-focused-nicks) :test #'string=))) -(define-beirc-command (com-quit :name t) ((reason 'string :prompt "reason")) +(define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (irc:quit (current-connection *application-frame*) reason)) (defun target (&optional (*application-frame* *application-frame*)) From afuchs at common-lisp.net Fri Sep 23 23:04:23 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 01:04:23 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050923230423.9A36C880DB@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv430 Modified Files: beirc.lisp message-display.lisp Log Message: add NAMES and TOPIC reply output; fix /raise ; add pointer-documentation also, remove the defunct raise-this-receiver p-t-c-translator Date: Sat Sep 24 01:04:22 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.16 beirc/beirc.lisp:1.17 --- beirc/beirc.lisp:1.16 Sat Sep 24 00:05:54 2005 +++ beirc/beirc.lisp Sat Sep 24 01:04:21 2005 @@ -67,6 +67,8 @@ (pane :reader pane) (tab-pane :accessor tab-pane))) +(define-presentation-type receiver-pane ()) + ;;; KLUDGE: make-clim-application-pane doesn't return an application ;;; pane, but a pane that wraps the application pane. we need the ;;; application pane for redisplay, though. @@ -91,7 +93,7 @@ 'tab-layout-pane)) (progn (setf (slot-value receiver 'tab-pane) - (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver)) + (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane)) (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) @@ -138,6 +140,15 @@ (define-global-message-receiver-lookup irc:irc-quit-message) (define-global-message-receiver-lookup irc:irc-nick-message)) +(defmethod receiver-for-message ((message irc:irc-topic-message) frame) + (intern-receiver (first (irc:arguments message)) frame :channel (first (irc:arguments message)))) + +(defmethod receiver-for-message ((message irc:irc-rpl_topic-message) frame) + (intern-receiver (second (irc:arguments message)) frame :channel (second (irc:arguments message)))) + +(defmethod receiver-for-message ((message irc:irc-rpl_namreply-message) frame) + (intern-receiver (third (irc:arguments message)) frame :channel (third (irc:arguments message)))) + (defmethod receiver-for-message ((message irc:irc-join-message) frame) (let ((target (irc:trailing-argument message))) (intern-receiver target frame :channel target))) @@ -232,8 +243,8 @@ (:layouts (default (vertically () - (with-tab-layout ('receiver :name 'query) - ("*Server*" server)) + (with-tab-layout ('receiver-pane :name 'query) + ("*Server*" server 'receiver-pane)) (60 io) (20 ;<-- Sigh! Bitrot! status-bar))))) @@ -389,6 +400,13 @@ (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) (maphash #'suggest (receivers *application-frame*)))) +(define-presentation-translator receiver-pane-to-receiver-translator + (receiver-pane receiver beirc) + (object) + (receiver-from-tab-pane + (find-in-tab-panes-list object + (find-pane-named *application-frame* 'query)))) + (defun nick-equals-my-nick-p (nickname) (and *application-frame* (equal (irc:normalize-nickname (current-connection *application-frame*) @@ -403,13 +421,6 @@ (format t "~A" o))) (format t "~A" o))) -(define-presentation-to-command-translator raise-this-receiver - (receiver com-raise-receiver beirc - :gesture :select - :documentation "Raise this receiver") - (presentation) - (list (presentation-object presentation))) - (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) (raise-receiver (intern-receiver nick *application-frame* :query nick))) @@ -470,7 +481,8 @@ (nickname com-ignore beirc :gesture :menu :menu t - :documentation "Ignore this user") + :documentation "Ignore this user" + :pointer-documentation "Ignore this user") (object) (list object)) @@ -478,7 +490,8 @@ (nickname com-focus beirc :gesture :menu :menu t - :documentation "Focus this user") + :documentation "Focus this user" + :pointer-documentation "Focus this user") (object) (list object)) @@ -486,7 +499,8 @@ (nickname com-query beirc :gesture :menu :menu t - :documentation "Query this user") + :documentation "Query this user" + :pointer-documentation "Query this user") (object) (list object)) @@ -514,6 +528,7 @@ (initialize-receiver-with-pane (server-receiver frame) frame (find-pane-named frame 'server) :add-pane-p nil) + (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) (clim-sys:make-process #'(lambda () (irc-event-loop frame connection)) :name "IRC Message Muffling Loop") ))))) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.5 beirc/message-display.lisp:1.6 --- beirc/message-display.lisp:1.5 Fri Sep 23 23:31:27 2005 +++ beirc/message-display.lisp Sat Sep 24 01:04:21 2005 @@ -78,6 +78,16 @@ (string last-char))) (otherwise (values word "")))))) +(defun strip-op-signs (word) + (if (= (length word) 0) + (values word "") + (let ((first-char (char word 0))) + (case first-char + ((#\@ #\+) + (values (subseq word 1) + (string first-char))) + (otherwise (values word "")))))) + (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) with column = start-length @@ -85,16 +95,18 @@ when (> column limit) do (setf column (length word)) (terpri) - do (multiple-value-bind (word* stripped-punctuation) (strip-punctuation word) - (cond - ((search "http://" word*) - (present-url word*)) - ((or - (nick-equals-my-nick-p word*) - (irc:find-user (current-connection *application-frame*) word*)) - (present word* 'nickname)) - (t (write-string word*))) - (write-string stripped-punctuation)) + do (multiple-value-bind (%word stripped-opsigns) (strip-op-signs word) + (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) + (write-string stripped-opsigns) + (cond + ((search "http://" word%) + (present-url word%)) + ((or + (nick-equals-my-nick-p word%) + (irc:find-user (current-connection *application-frame*) word%)) + (present word% 'nickname)) + (t (write-string word%))) + (write-string stripped-punctuation))) ;; TODO: more highlighting unless (or (null rest) (>= column limit)) do (write-char #\Space) @@ -158,6 +170,31 @@ (present (irc:source message) 'nickname) (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) (present (irc:trailing-argument message) 'nickname))))) + +(defun print-topic (receiver message sender channel topic) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (if (null sender) + (format-message* (format nil "Topic for ~A: ~A" channel topic)) + (progn + (present sender 'nickname) + (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) + +(defmethod print-message ((message irc:irc-topic-message) receiver) + (print-topic receiver message (irc:source message) + (first (irc:arguments message)) (irc:trailing-argument message))) + +(defmethod print-message ((message irc:irc-rpl_topic-message) receiver) + (print-topic receiver message nil + (second (irc:arguments message)) (irc:trailing-argument message))) + +(defmethod print-message ((message irc:irc-rpl_namreply-message) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A Names: ~A" (third (irc:arguments message)) + (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-part-message) receiver) (formatting-message (t message receiver) From afuchs at common-lisp.net Fri Sep 23 23:22:51 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 01:22:51 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050923232251.5EE6F880DB@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv1525 Modified Files: beirc.lisp Log Message: Fix a few uses to find-in-tab-panes-list to use the recommended API Date: Sat Sep 24 01:22:50 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.17 beirc/beirc.lisp:1.18 --- beirc/beirc.lisp:1.17 Sat Sep 24 01:04:21 2005 +++ beirc/beirc.lisp Sat Sep 24 01:22:50 2005 @@ -184,8 +184,7 @@ (defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane))) (let ((receiver (receiver-from-tab-pane - (find-in-tab-panes-list pane - (find-pane-named *application-frame* 'query))))) + (find-in-tab-panes-list pane 'tab-layout-pane)))) (unless (null receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) @@ -404,8 +403,7 @@ (receiver-pane receiver beirc) (object) (receiver-from-tab-pane - (find-in-tab-panes-list object - (find-pane-named *application-frame* 'query)))) + (find-in-tab-panes-list object 'tab-layout-pane))) (defun nick-equals-my-nick-p (nickname) (and *application-frame* From afuchs at common-lisp.net Sat Sep 24 09:14:05 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 11:14:05 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050924091405.33FB088542@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv8786 Modified Files: beirc.lisp message-display.lisp Log Message: Fix /quit, /disconnect commands and quitting the irc worker thread. * /quit, /disconnect and later /connect commands now work, hopefully in all combinations. * This change also introduces a level of thread hygiene. When beirc's application frame exits, every thread (except the clim/clx listener thread) should be killed as well. Date: Sat Sep 24 11:14:04 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.18 beirc/beirc.lisp:1.19 --- beirc/beirc.lisp:1.18 Sat Sep 24 01:22:50 2005 +++ beirc/beirc.lisp Sat Sep 24 11:14:03 2005 @@ -190,7 +190,6 @@ (setf (messages-directed-to-me receiver) 0) (update-drawing-options receiver)))) - (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) @@ -211,6 +210,7 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) ((connection :initform nil :reader current-connection) + (connection-process :initform nil :accessor connection-process) (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) @@ -347,11 +347,12 @@ (clim-sys:make-process (lambda () (progv syms vals - (let ((frame (make-application-frame 'beirc))) + (let* ((frame (make-application-frame 'beirc)) + (ticker-process (clim-sys:make-process (lambda () (ticker frame)) + :name "Beirc Ticker"))) (setf *beirc-frame* frame) - (clim-sys:make-process (lambda () (ticker frame)) - :name "Beirc Ticker") - (run-frame-top-level frame)))))))) + (run-frame-top-level frame) + (clim-sys:destroy-process ticker-process)))))))) (defun message-directed-to-me-p (frame message) (let ((my-nick (slot-value frame 'nick)) @@ -372,11 +373,16 @@ (make-instance 'foo-event :sheet frame :receiver receiver)) nil)) +;;; XXX: ticker continues to run even if the frame is no longer active +;;; or on the display. (defun ticker (frame) - (loop - (clim-internals::event-queue-prepend (climi::frame-event-queue frame) - (make-instance 'bar-event :sheet frame)) - (sleep 1))) + (handler-case + (loop + (clim-internals::event-queue-prepend (climi::frame-event-queue frame) + (make-instance 'bar-event :sheet frame)) + (sleep 1)) + (frame-exit () + nil))) (define-presentation-type nickname ()) (define-presentation-type ignored-nickname (nickname)) @@ -406,7 +412,8 @@ (find-in-tab-panes-list object 'tab-layout-pane))) (defun nick-equals-my-nick-p (nickname) - (and *application-frame* + (and (not (null *application-frame*)) + (not (null (slot-value *application-frame* 'connection))) (equal (irc:normalize-nickname (current-connection *application-frame*) (slot-value *application-frame* 'nick)) (irc:normalize-nickname (current-connection *application-frame*) @@ -440,7 +447,13 @@ (remove who (current-focused-nicks) :test #'string=))) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) - (irc:quit (current-connection *application-frame*) reason)) + (when (current-connection *application-frame*) + (quit *application-frame* reason)) + (frame-exit *application-frame*)) + +(define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason")) + (when (current-connection *application-frame*) + (quit *application-frame* reason))) (defun target (&optional (*application-frame* *application-frame*)) (or (current-query) @@ -527,9 +540,45 @@ (find-pane-named frame 'server) :add-pane-p nil) (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) - (clim-sys:make-process #'(lambda () - (irc-event-loop frame connection)) - :name "IRC Message Muffling Loop") ))))) + (setf (connection-process *application-frame*) + (clim-sys:make-process #'(lambda () + (unwind-protect + (irc-event-loop frame connection) + (disconnect frame))) + :name "IRC Message Muffling Loop")) ))))) + +(defun disconnect (frame) + (let ((old-nickname (slot-value frame 'nick))) + (raise-receiver (server-receiver frame)) + (post-message frame + (make-instance 'irc:irc-quit-message + :received-time (get-universal-time) + :connection :local + :trailing-argument + (format nil "You disconnected from IRC") + :arguments nil + :command "QUIT" + :host "localhost" ;### + :user "localuser" ;### + :source old-nickname)) + (when (and (connection-process frame) + (not (eql (clim-sys:current-process) + (connection-process frame)))) + (destroy-process (connection-process frame))) + (setf (slot-value frame 'connection) nil + (connection-process frame) nil + (slot-value frame 'nick) nil))) + +(defun quit (frame reason) + (raise-receiver (server-receiver frame)) + (irc:quit (current-connection frame) reason) + (when (and (connection-process frame) + (not (eql (clim-sys:current-process) + (connection-process frame)))) + (destroy-process (connection-process frame))) + (setf (slot-value frame 'connection) nil + (connection-process frame) nil + (slot-value frame 'nick) nil)) (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) (multiple-value-prog1 @@ -544,12 +593,10 @@ (window-clear stream))) (defun restart-beirc () - (let ((m (current-messages))) - (clim-sys:destroy-process *gui-process*) - (setf *beirc-frame* nil) - (beirc) - (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*)) - (setf (current-messages) m))) + (clim-sys:destroy-process *gui-process*) + (setf *beirc-frame* nil) + (beirc) + (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))) ;;;;;;;;; Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.6 beirc/message-display.lisp:1.7 --- beirc/message-display.lisp:1.6 Sat Sep 24 01:04:21 2005 +++ beirc/message-display.lisp Sat Sep 24 11:14:03 2005 @@ -103,7 +103,8 @@ (present-url word%)) ((or (nick-equals-my-nick-p word%) - (irc:find-user (current-connection *application-frame*) word%)) + (and (current-connection *application-frame*) + (irc:find-user (current-connection *application-frame*) word%))) (present word% 'nickname)) (t (write-string word%))) (write-string stripped-punctuation))) From afuchs at common-lisp.net Sat Sep 24 11:43:38 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 13:43:38 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050924114338.4507B880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv19320 Modified Files: beirc.lisp Log Message: fix NOTICE handling, including network service notices. also, revert the TICKER function back to its old self; the handler-case in there served no purpose. Date: Sat Sep 24 13:43:37 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.19 beirc/beirc.lisp:1.20 --- beirc/beirc.lisp:1.19 Sat Sep 24 11:14:03 2005 +++ beirc/beirc.lisp Sat Sep 24 13:43:37 2005 @@ -97,13 +97,17 @@ (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) +(defun find-receiver (name frame) + (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) + (receivers frame))) + (defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) - (receivers frame)))) + (let* ((normalized-name (irc:normalize-channel-name (slot-value frame 'connection) name)) + (rec (find-receiver name frame))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-paneless-receiver name initargs))) + (let ((receiver (apply 'make-paneless-receiver normalized-name initargs))) (initialize-receiver-with-pane receiver frame (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) @@ -117,20 +121,35 @@ (setf (gethash name (receivers frame)) receiver) receiver))))) +(defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "") + "Sources whose private messages (PRIVMSG, NOTICE, ...) should + be treated as if they came from the connected server itself, + unless the user has opened a query window to the source + already.") + +(defun network-service-p (source frame) + (member source *network-service-sources* + :test (lambda (source1 source2) + (string= (irc:normalize-nickname (current-connection frame) source1) + (irc:normalize-nickname (current-connection frame) source2))))) + (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) - (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection) - (slot-value frame 'nick))) - (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) - (first (irc:arguments message)))) - (target (if (equal nominal-target mynick) - (irc:source message) - nominal-target))) - (intern-receiver target frame :channel target))))) + (if (or + (find-receiver (irc:source message) frame) + (not (network-service-p (irc:source message) frame))) + (let* ((mynick (irc:normalize-nickname (current-connection frame) + (slot-value frame 'nick))) + (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) + (first (irc:arguments message)))) + (target (if (equal nominal-target mynick) + (irc:source message) + nominal-target))) + (intern-receiver target frame :channel target)) + (server-receiver frame))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) - ;; (define-privmsg-receiver-lookup irc:irc-notice-message) ; XXX: NOTICEs in freenode are a bit tricky. - ) + (define-privmsg-receiver-lookup irc:irc-notice-message)) (macrolet ((define-global-message-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) @@ -361,28 +380,24 @@ (defun post-message (frame message) (let ((receiver (receiver-for-message message frame))) - (setf (messages receiver) - (append (messages receiver) (list message))) - (unless (eql receiver (current-receiver frame)) - (incf (unseen-messages receiver)) - (when (message-directed-to-me-p frame message) - (incf (messages-directed-to-me receiver)))) - (update-drawing-options receiver) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) - nil)) + (unless (null receiver) + (setf (messages receiver) + (append (messages receiver) (list message))) + (unless (eql receiver (current-receiver frame)) + (incf (unseen-messages receiver)) + (when (message-directed-to-me-p frame message) + (incf (messages-directed-to-me receiver)))) + (update-drawing-options receiver) + (clim-internals::event-queue-prepend + (climi::frame-event-queue frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil))) -;;; XXX: ticker continues to run even if the frame is no longer active -;;; or on the display. (defun ticker (frame) - (handler-case - (loop - (clim-internals::event-queue-prepend (climi::frame-event-queue frame) - (make-instance 'bar-event :sheet frame)) - (sleep 1)) - (frame-exit () - nil))) + (loop + (clim-internals::event-queue-prepend (climi::frame-event-queue frame) + (make-instance 'bar-event :sheet frame)) + (sleep 1))) (define-presentation-type nickname ()) (define-presentation-type ignored-nickname (nickname)) From afuchs at common-lisp.net Sat Sep 24 14:36:35 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 16:36:35 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050924143635.1DAB7880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv31756 Modified Files: beirc.lisp message-display.lisp Log Message: Handle printing of the server's MOTD. Add an /Eval command to debug cl-irc commands. Date: Sat Sep 24 16:36:32 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.20 beirc/beirc.lisp:1.21 --- beirc/beirc.lisp:1.20 Sat Sep 24 13:43:37 2005 +++ beirc/beirc.lisp Sat Sep 24 16:36:31 2005 @@ -461,6 +461,12 @@ (setf (current-focused-nicks) (remove who (current-focused-nicks) :test #'string=))) +(define-beirc-command (com-eval :name t) ((command 'string :prompt "command") + (args '(sequence string) :prompt "arguments")) + (multiple-value-bind (symbol status) (find-symbol command :irc) + (when (eql status :external) + (apply symbol (current-connection *application-frame*) (coerce args 'list))))) + (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) (quit *application-frame* reason)) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.7 beirc/message-display.lisp:1.8 --- beirc/message-display.lisp:1.7 Sat Sep 24 11:14:03 2005 +++ beirc/message-display.lisp Sat Sep 24 16:36:31 2005 @@ -205,6 +205,12 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) +(defmethod print-message ((message irc:irc-rpl_motd-message) receiver) + (formatting-message (t message receiver) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "MOTD: ~A" (irc:trailing-argument message)))))) + (defmethod print-message (message receiver) (formatting-message (t message receiver) ((format t "!!! ~A" (irc:source message))) From afuchs at common-lisp.net Sat Sep 24 15:04:09 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 17:04:09 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050924150409.5A8C3880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv1363 Modified Files: beirc.lisp message-display.lisp Log Message: further printing / command features: * don't print "end of " replies from the server. * add a /topic, /names, /op, /deop command. * add a method to print irc-mode-messages. Date: Sat Sep 24 17:04:07 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.21 beirc/beirc.lisp:1.22 --- beirc/beirc.lisp:1.21 Sat Sep 24 16:36:31 2005 +++ beirc/beirc.lisp Sat Sep 24 17:04:06 2005 @@ -176,6 +176,34 @@ (let ((target (first (irc:arguments message)))) (intern-receiver target frame :channel target))) +(defmethod receiver-for-message ((message irc:irc-mode-message) frame) + (destructuring-bind (channel modes args) (irc:arguments message) + (declare (ignore modes args)) + (intern-receiver channel frame :channel channel))) + +(macrolet ((define-ignore-message-types (&rest mtypes) + `(progn + ,@(loop for mtype in mtypes + collect `(defmethod receiver-for-message ((message ,mtype) frame) + nil))))) + (define-ignore-message-types cl-irc:irc-rpl_endofwhowas-message + cl-irc:irc-rpl_endoflinks-message + cl-irc:irc-rpl_endoptions-message + cl-irc:irc-rpl_endofwhois-message + cl-irc:irc-rpl_endsitelist-message + cl-irc:irc-rpl_endofinvitelist-message + cl-irc:irc-rpl_endofservices-message + cl-irc:irc-rpl_endmode-message + cl-irc:irc-rpl_endofmap-message + cl-irc:irc-rpl_endofnames-message + cl-irc:irc-rpl_endofusers-message + cl-irc:irc-rpl_endofbanlist-message + cl-irc:irc-rpl_endofmotd-message + cl-irc:irc-rpl_endofinfo-message + cl-irc:irc-rpl_endofstats-message + cl-irc:irc-rpl_endofwho-message + cl-irc:irc-rpl_endofexceptlist-message)) + (defmethod receiver-for-message ((message irc:irc-message) frame) (server-receiver frame)) @@ -463,9 +491,21 @@ (define-beirc-command (com-eval :name t) ((command 'string :prompt "command") (args '(sequence string) :prompt "arguments")) - (multiple-value-bind (symbol status) (find-symbol command :irc) + (multiple-value-bind (symbol status) (find-symbol (string-upcase command) :irc) (when (eql status :external) (apply symbol (current-connection *application-frame*) (coerce args 'list))))) + +(define-beirc-command (com-topic :name t) ((topic 'mumble :prompt "topic")) + (irc:topic- (current-connection *application-frame*) (target) topic)) + +(define-beirc-command (com-op :name t) ((who 'nickname :prompt "who")) + (irc:op (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who")) + (irc:deop (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-names :name t) () + (irc:names (current-connection *application-frame*) (target))) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.8 beirc/message-display.lisp:1.9 --- beirc/message-display.lisp:1.8 Sat Sep 24 16:36:31 2005 +++ beirc/message-display.lisp Sat Sep 24 17:04:06 2005 @@ -205,6 +205,15 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) +(defmethod print-message ((message irc:irc-mode-message) receiver) + (destructuring-bind (target modes args) (irc:arguments message) + (declare (ignore target)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (format-message* (format nil " set mode ~A ~A" modes args))))))) + (defmethod print-message ((message irc:irc-rpl_motd-message) receiver) (formatting-message (t message receiver) ((format t "~A" (irc:source message))) From afuchs at common-lisp.net Sat Sep 24 17:28:39 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 19:28:39 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050924172839.614CB880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv11001 Modified Files: beirc.lisp message-display.lisp Log Message: * refactor message faking * fix display of irc-MODE-messages that deal with user modes * rework /topic to display the topic if no string is passed * add presentation type CHANNEL and an accept method so that /join doesn't do stupid things anymore on empty input. * add minimal receiver closing functionality. Date: Sat Sep 24 19:28:38 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.22 beirc/beirc.lisp:1.23 --- beirc/beirc.lisp:1.22 Sat Sep 24 17:04:06 2005 +++ beirc/beirc.lisp Sat Sep 24 19:28:38 2005 @@ -121,6 +121,10 @@ (setf (gethash name (receivers frame)) receiver) receiver))))) +(defun remove-receiver (receiver frame) + (remove-pane (tab-pane receiver) (find-pane-named frame 'query)) + (remhash (title receiver) (receivers frame))) + (defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "") "Sources whose private messages (PRIVMSG, NOTICE, ...) should be treated as if they came from the connected server itself, @@ -177,9 +181,11 @@ (intern-receiver target frame :channel target))) (defmethod receiver-for-message ((message irc:irc-mode-message) frame) - (destructuring-bind (channel modes args) (irc:arguments message) - (declare (ignore modes args)) - (intern-receiver channel frame :channel channel))) + (case (length (irc:arguments message)) + (1 (server-receiver frame)) + (3 (destructuring-bind (channel modes args) (irc:arguments message) + (declare (ignore modes args)) + (intern-receiver channel frame :channel channel))))) (macrolet ((define-ignore-message-types (&rest mtypes) `(progn @@ -244,7 +250,6 @@ ;;; KLUDGE: workaround for mcclim bug "Application pane vertical ;;; scrolling does not work with table formatting" - (defclass redisplay-frame-mixin () ()) @@ -469,12 +474,31 @@ (format t "~A" o))) (format t "~A" o))) +(define-presentation-type channel () :inherit-from 'string) + +(define-presentation-method presentation-typep (object (type channel)) + (channelp object)) + +(defun channelp (channel) + (and (stringp channel) + (> (length channel) 2) + (not (null (member (char channel 0) '(#\# #\+ #\! #\&)))))) + +(define-presentation-method accept ((type channel) *standard-input* (view textual-view) &key) + (let ((channel (accept 'string :view view :prompt nil))) + (if (not (presentation-typep channel 'channel)) + (input-not-of-required-type channel 'channel) + channel))) + (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) (raise-receiver (intern-receiver nick *application-frame* :query nick))) (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) +(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) + (remove-receiver receiver *application-frame*)) + (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) (pushnew who (current-focused-nicks) :test #'string=)) @@ -495,8 +519,30 @@ (when (eql status :external) (apply symbol (current-connection *application-frame*) (coerce args 'list))))) -(define-beirc-command (com-topic :name t) ((topic 'mumble :prompt "topic")) - (irc:topic- (current-connection *application-frame*) (target) topic)) +(defun make-fake-irc-message (message-type &key command arguments + (source (slot-value *application-frame* 'nick)) + trailing-argument) + (make-instance message-type + :received-time (get-universal-time) + :connection :local + :trailing-argument trailing-argument + :arguments arguments + :command command + :HOST "localhost" + :USER "localuser" + :SOURCE source)) + +(define-beirc-command (com-topic :name t) (&key (topic 'mumble :prompt "New topic")) + (if (and (not (string= topic ""))) + (irc:topic- (current-connection *application-frame*) (target) topic) + (post-message *application-frame* + (make-fake-irc-message 'irc:irc-rpl_topic-message + :command "332" + :arguments `("=" ,(target)) + :trailing-argument (irc:topic + (irc:find-channel + (current-connection *application-frame*) + (target))))))) (define-beirc-command (com-op :name t) ((who 'nickname :prompt "who")) (irc:op (current-connection *application-frame*) (target) who)) @@ -523,16 +569,10 @@ (define-beirc-command (com-say :name t) ((what 'mumble)) ;; make a fake IRC-PRIV-MESSAGE object (post-message *application-frame* - (make-instance 'irc:irc-privmsg-message - :received-time (get-universal-time) - :connection :local - :trailing-argument what - :arguments (list (target)) - :command "PRIVMSG" - :HOST "localhost" - :USER "localuser" - :SOURCE (slot-value *application-frame* 'nick) - )) + (make-fake-irc-message 'irc:irc-privmsg-message + :trailing-argument what + :arguments (list (target)) + :command "PRIVMSG")) (irc:privmsg (current-connection *application-frame*) (target) what)) (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick")) @@ -581,7 +621,7 @@ (presentation) (list (presentation-object presentation))) -(define-beirc-command (com-join :name t) ((channel 'string :prompt "channel")) +(define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) (raise-receiver (intern-receiver channel *application-frame* :channel channel)) (irc:join (current-connection *application-frame*) channel)) @@ -609,26 +649,18 @@ :name "IRC Message Muffling Loop")) ))))) (defun disconnect (frame) - (let ((old-nickname (slot-value frame 'nick))) - (raise-receiver (server-receiver frame)) - (post-message frame - (make-instance 'irc:irc-quit-message - :received-time (get-universal-time) - :connection :local - :trailing-argument - (format nil "You disconnected from IRC") - :arguments nil - :command "QUIT" - :host "localhost" ;### - :user "localuser" ;### - :source old-nickname)) - (when (and (connection-process frame) - (not (eql (clim-sys:current-process) - (connection-process frame)))) - (destroy-process (connection-process frame))) - (setf (slot-value frame 'connection) nil - (connection-process frame) nil - (slot-value frame 'nick) nil))) + (raise-receiver (server-receiver frame)) + (post-message frame + (make-fake-irc-message 'irc:irc-quit-message + :trailing-argument "You disconnected from IRC" + :command "QUIT")) + (when (and (connection-process frame) + (not (eql (clim-sys:current-process) + (connection-process frame)))) + (destroy-process (connection-process frame))) + (setf (slot-value frame 'connection) nil + (connection-process frame) nil + (slot-value frame 'nick) nil)) (defun quit (frame reason) (raise-receiver (server-receiver frame)) @@ -725,32 +757,22 @@ (write-char (read-char) bag))))))) (define-beirc-command (com-me :name t) ((what 'mumble)) - (with-slots (connection nick) *application-frame* - (let ((m (make-instance 'irc:ctcp-action-message - :received-time (get-universal-time) - :connection :local - :trailing-argument - (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) - :arguments (list (target)) - :command "PRIVMSG" - :host "localhost" ;### - :user "localuser" ;### - :source nick))) ;### + (with-slots (connection) *application-frame* + (let ((m (make-fake-irc-message 'irc:ctcp-action-message + :trailing-argument + (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) + :arguments (list (target)) + :command "PRIVMSG"))) ;### (post-message *application-frame* m) (irc:privmsg connection (target) (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))) (defun send-private-message (target what) (post-message *application-frame* - (make-instance 'irc:irc-privmsg-message - :received-time (get-universal-time) - :connection :local - :trailing-argument what - :arguments (list target) - :command "PRIVMSG" - :HOST "localhost" - :USER "localuser" - :SOURCE (slot-value *application-frame* 'nick) )) + (make-fake-irc-message 'irc:irc-privmsg-message + :trailing-argument what + :arguments (list target) + :command "PRIVMSG")) (irc:privmsg (current-connection *application-frame*) target what)) (define-beirc-command (com-msg :name t) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.9 beirc/message-display.lisp:1.10 --- beirc/message-display.lisp:1.9 Sat Sep 24 17:04:06 2005 +++ beirc/message-display.lisp Sat Sep 24 19:28:38 2005 @@ -206,13 +206,20 @@ (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) (defmethod print-message ((message irc:irc-mode-message) receiver) - (destructuring-bind (target modes args) (irc:arguments message) - (declare (ignore target)) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (format-message* (format nil " set mode ~A ~A" modes args))))))) + (case (length (irc:arguments message)) + (1 (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A set mode ~A ~A" (irc:source message) + (irc:trailing-argument message) + (first (irc:arguments message)))))))) + (3 (destructuring-bind (target modes args) (irc:arguments message) + (declare (ignore target)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (format-message* (format nil " set mode ~A ~A" modes args))))))))) (defmethod print-message ((message irc:irc-rpl_motd-message) receiver) (formatting-message (t message receiver) From afuchs at common-lisp.net Sat Sep 24 17:39:36 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 19:39:36 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050924173936.EEA1C880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv12043 Modified Files: beirc.lisp Log Message: add /part and better /close functionality. * /part exits the current channel and leaves the receiver intact. * /close closes the receiver and parts the channel (if the closed receiver is a channel). The part message from a closed channel goes to the server buffer. Date: Sat Sep 24 19:39:36 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.23 beirc/beirc.lisp:1.24 --- beirc/beirc.lisp:1.23 Sat Sep 24 19:28:38 2005 +++ beirc/beirc.lisp Sat Sep 24 19:39:36 2005 @@ -178,7 +178,11 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) - (intern-receiver target frame :channel target))) + (if (and + (null (find-receiver target frame)) + (string= (irc:source message) (slot-value frame 'nick))) + (server-receiver frame) ; don't re-open previously closed channels. + (intern-receiver target frame :channel target)))) (defmethod receiver-for-message ((message irc:irc-mode-message) frame) (case (length (irc:arguments message)) @@ -497,7 +501,15 @@ (raise-receiver receiver)) (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) + (let* ((connection (current-connection *application-frame*)) + (channel (irc:find-channel connection (title receiver)))) + (when channel + (irc:part connection channel))) (remove-receiver receiver *application-frame*)) + +(define-beirc-command (com-part :name t) () + (irc:part (current-connection *application-frame*) + (title (current-receiver *application-frame*)))) (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) (pushnew who (current-focused-nicks) :test #'string=)) From afuchs at common-lisp.net Sat Sep 24 18:13:45 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 20:13:45 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050924181345.7F19A880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv14202 Modified Files: beirc.lisp message-display.lisp Log Message: don't highlight the user's nickname in the first column. Date: Sat Sep 24 20:13:44 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.24 beirc/beirc.lisp:1.25 --- beirc/beirc.lisp:1.24 Sat Sep 24 19:39:36 2005 +++ beirc/beirc.lisp Sat Sep 24 20:13:44 2005 @@ -437,7 +437,8 @@ (sleep 1))) (define-presentation-type nickname ()) -(define-presentation-type ignored-nickname (nickname)) +(define-presentation-type unhighlighted-nickname () :inherit-from 'nickname) +(define-presentation-type ignored-nickname () :inherit-from 'nickname) (defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) @@ -471,12 +472,15 @@ (irc:normalize-nickname (current-connection *application-frame*) 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) (with-drawing-options (t :ink +darkgreen+) (with-text-face (t :bold) - (format t "~A" o))) - (format t "~A" o))) + (write-string o))) + (write-string o))) (define-presentation-type channel () :inherit-from 'string) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.10 beirc/message-display.lisp:1.11 --- beirc/message-display.lisp:1.10 Sat Sep 24 19:28:38 2005 +++ beirc/message-display.lisp Sat Sep 24 20:13:44 2005 @@ -126,7 +126,7 @@ (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) 'nickname) + (present (irc:source message) 'unhighlighted-nickname) (write-string end-string *standard-output*)) ((format-message* (irc:trailing-argument message)))))))) From afuchs at common-lisp.net Sat Sep 24 18:14:28 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 20:14:28 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050924181428.07867880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv14230 Modified Files: beirc.lisp Log Message: don't display PING messages. The *Server* buffer should only light up if something important happens, now. Date: Sat Sep 24 20:14:28 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.25 beirc/beirc.lisp:1.26 --- beirc/beirc.lisp:1.25 Sat Sep 24 20:13:44 2005 +++ beirc/beirc.lisp Sat Sep 24 20:14:28 2005 @@ -212,7 +212,8 @@ cl-irc:irc-rpl_endofinfo-message cl-irc:irc-rpl_endofstats-message cl-irc:irc-rpl_endofwho-message - cl-irc:irc-rpl_endofexceptlist-message)) + cl-irc:irc-rpl_endofexceptlist-message + cl-irc:irc-ping-message)) (defmethod receiver-for-message ((message irc:irc-message) frame) (server-receiver frame)) From afuchs at common-lisp.net Sat Sep 24 19:03:16 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 21:03:16 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050924190316.84B44880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv18453 Modified Files: beirc.lisp message-display.lisp Log Message: implement kicking & banning; reorder and group print-message methods Date: Sat Sep 24 21:03:15 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.26 beirc/beirc.lisp:1.27 --- beirc/beirc.lisp:1.26 Sat Sep 24 20:14:28 2005 +++ beirc/beirc.lisp Sat Sep 24 21:03:14 2005 @@ -163,18 +163,29 @@ (define-global-message-receiver-lookup irc:irc-quit-message) (define-global-message-receiver-lookup irc:irc-nick-message)) -(defmethod receiver-for-message ((message irc:irc-topic-message) frame) - (intern-receiver (first (irc:arguments message)) frame :channel (first (irc:arguments message)))) +(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 + clauses is nil. -(defmethod receiver-for-message ((message irc:irc-rpl_topic-message) frame) - (intern-receiver (second (irc:arguments message)) frame :channel (second (irc:arguments message)))) - -(defmethod receiver-for-message ((message irc:irc-rpl_namreply-message) frame) - (intern-receiver (third (irc:arguments message)) frame :channel (third (irc:arguments message)))) - -(defmethod receiver-for-message ((message irc:irc-join-message) frame) - (let ((target (irc:trailing-argument message))) - (intern-receiver target frame :channel target))) + Each clause must have this format: + (nth message-type ...)" + `(progn + ,@(loop for (nth . messages) in clauses + do (print messages) + nconc (loop for message-type in messages + collect + `(defmethod receiver-for-message ((message ,message-type) frame) + (let ((target ,(if (numberp nth) + `(nth ,nth (irc:arguments message)) + `(irc:trailing-argument message)))) + (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) + (2 irc:irc-rpl_namreply-message) + (nil irc:irc-join-message))) (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) @@ -440,6 +451,8 @@ (define-presentation-type nickname ()) (define-presentation-type unhighlighted-nickname () :inherit-from 'nickname) (define-presentation-type ignored-nickname () :inherit-from 'nickname) +(define-presentation-type channel () :inherit-from 'string) +(define-presentation-type hostmask () :inherit-from 'string) (defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) @@ -465,6 +478,11 @@ (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane))) +(define-presentation-translator nickname-to-hostmask-translator + (nickname hostmask beirc) + (object) + (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) + (defun nick-equals-my-nick-p (nickname) (and (not (null *application-frame*)) (not (null (slot-value *application-frame* 'connection))) @@ -483,8 +501,6 @@ (write-string o))) (write-string o))) -(define-presentation-type channel () :inherit-from 'string) - (define-presentation-method presentation-typep (object (type channel)) (channelp object)) @@ -567,6 +583,15 @@ (define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who")) (irc:deop (current-connection *application-frame*) (target) who)) +(define-beirc-command (com-ban-nick :name t) ((who 'nickname :prompt "who")) + (irc:ban (current-connection *application-frame*) (target) (format nil "~A!*@*" who))) + +(define-beirc-command (com-ban-hostmask :name t) ((who 'hostmask :prompt "hostmask")) + (irc:ban (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who")) + (irc:kick (current-connection *application-frame*) (target) who)) + (define-beirc-command (com-names :name t) () (irc:names (current-connection *application-frame*) (target))) @@ -662,8 +687,8 @@ (clim-sys:make-process #'(lambda () (unwind-protect (irc-event-loop frame connection) - (disconnect frame))) - :name "IRC Message Muffling Loop")) ))))) + (quit frame "IRC event loop terminated."))) + :name "IRC Message Muffling Loop"))))))) (defun disconnect (frame) (raise-receiver (server-receiver frame)) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.11 beirc/message-display.lisp:1.12 --- beirc/message-display.lisp:1.11 Sat Sep 24 20:13:44 2005 +++ beirc/message-display.lisp Sat Sep 24 21:03:15 2005 @@ -114,6 +114,8 @@ (incf column)) (terpri)) +;;; privmsg-like messages + (defun print-privmsg-like-message (message receiver start-string end-string) (with-drawing-options (*standard-output* @@ -145,6 +147,22 @@ (format t " ") (format-message* matter :start-length (+ 2 (length source))))))) +;;; server messages + +(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 "args: ~A :~A" (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 " ")) @@ -155,22 +173,16 @@ (format-message* (irc:trailing-argument message) :start-length (+ 8 (length (irc:source 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) - (format t " (~A@~A)" (irc:user message) (irc:host message)))))) - (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) - (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) - (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) + (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) + (present (irc:trailing-argument message) 'nickname))))) + +;;; channel management messages (defun print-topic (receiver message sender channel topic) (formatting-message (t message receiver) @@ -205,6 +217,25 @@ (present (irc:source message) 'nickname) (format t " 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) + (format t " (~A@~A)" (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)))))))) + (defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) (1 (formatting-message (t message receiver) @@ -221,17 +252,7 @@ (present (irc:source message) 'nickname) (format-message* (format nil " set mode ~A ~A" modes args))))))))) -(defmethod print-message ((message irc:irc-rpl_motd-message) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((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 "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message)))))) +;;; the display function (& utilities) (defgeneric preamble-length (message) (:method ((message irc:irc-privmsg-message)) @@ -247,30 +268,4 @@ maximize (preamble-length message)))) (formatting-table (t) (loop for message in messages - do (print-message message receiver))))) - - -#| - (let ((k 100) - (n (length messages))) - (loop for i below (* k (ceiling n k)) by k do - (updating-output (*standard-output* - :unique-id i - :cache-value - (list (min n (+ i k)) - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (loop for j from i below (min n (+ i k)) do - (let ((m (elt messages j))) - (updating-output (*standard-output* - :unique-id j - :cache-value - (list m - (focused-nicks receiver) - (slot-value *application-frame* 'ignored-nicks) - w) - :cache-test #'equal) - (print-message m receiver))))))) -|# \ No newline at end of file + do (print-message message receiver))))) \ No newline at end of file From afuchs at common-lisp.net Sat Sep 24 19:13:55 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 24 Sep 2005 21:13:55 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050924191355.6F11D880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv18565 Modified Files: beirc.lisp Log Message: add kick and ban presentation translators for nicknames. Date: Sat Sep 24 21:13:54 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.27 beirc/beirc.lisp:1.28 --- beirc/beirc.lisp:1.27 Sat Sep 24 21:03:14 2005 +++ beirc/beirc.lisp Sat Sep 24 21:13:54 2005 @@ -658,6 +658,33 @@ (object) (list object)) +(define-presentation-to-command-translator nickname-to-kick-translator + (nickname com-kick beirc + :gesture :menu + :menu t + :documentation "Kick this user" + :pointer-documentation "Kick this user") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-ban-nick-translator + (nickname com-ban-nick beirc + :gesture :menu + :menu t + :documentation "Ban this user's nickname" + :pointer-documentation "Ban this user's nickname") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-ban-hostmask-translator + (nickname com-ban-hostmask beirc + :gesture :menu + :menu t + :documentation "Ban this user's hostmask" + :pointer-documentation "Ban this user's hostmask") + (object) + (list object)) + (define-presentation-to-command-translator url-to-browse-url-translator (url com-browse-url beirc) (presentation) From afuchs at common-lisp.net Sat Sep 24 22:30:27 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 00:30:27 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp Message-ID: <20050924223027.6DA42880DE@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv32347 Modified Files: beirc.lisp message-display.lisp Log Message: add a customizable variable for timestamp orientation, and fix redisplay on focus/ignore/etc. command * new variable *timestamp-column-orientation* (this is for you, mgr) * new command /Switch Timestamp Orientation * /S-T-O, /{,un}ignore, /{,un}focus now redraw the panes they affect. * comment out the nickname to hostmask ptype translator. for some reason it was always activated. Date: Sun Sep 25 00:30:25 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.28 beirc/beirc.lisp:1.29 --- beirc/beirc.lisp:1.28 Sat Sep 24 21:13:54 2005 +++ beirc/beirc.lisp Sun Sep 25 00:30:23 2005 @@ -389,6 +389,17 @@ (scroll-extent pane 0 (max 0 (- (bounding-rectangle-height pane) (bounding-rectangle-height (sheet-parent pane)))))) +(defun redraw-receiver (receiver) + (let ((pane (actual-application-pane (pane receiver)))) + (setf (pane-needs-redisplay pane) t) + (redisplay-frame-pane *application-frame* pane))) + +(defun redraw-all-receivers () + (maphash (lambda (name receiver) + (declare (ignore name)) + (redraw-receiver receiver)) + (receivers *application-frame*))) + (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. @@ -478,6 +489,8 @@ (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane))) +;;; XXX: for some reason, this translator is activated when accepting NICKNAME. +#+(or) (define-presentation-translator nickname-to-hostmask-translator (nickname hostmask beirc) (object) @@ -533,18 +546,22 @@ (title (current-receiver *application-frame*)))) (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) - (pushnew who (current-focused-nicks) :test #'string=)) + (pushnew who (current-focused-nicks) :test #'string=) + (redraw-receiver (current-receiver *application-frame*))) (define-beirc-command (com-ignore :name t) ((who 'nickname :prompt "who")) - (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) + (pushnew who (slot-value *application-frame* 'ignored-nicks) :test #'string=) + (redraw-all-receivers)) (define-beirc-command (com-unignore :name t) ((who 'ignored-nickname :prompt "who")) (setf (slot-value *application-frame* 'ignored-nicks) - (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=))) + (remove who (slot-value *application-frame* 'ignored-nicks) :test #'string=)) + (redraw-all-receivers)) (define-beirc-command (com-unfocus :name t) ((who 'nickname :prompt "who")) (setf (current-focused-nicks) - (remove who (current-focused-nicks) :test #'string=))) + (remove who (current-focused-nicks) :test #'string=)) + (redraw-receiver (current-receiver *application-frame*))) (define-beirc-command (com-eval :name t) ((command 'string :prompt "command") (args '(sequence string) :prompt "arguments")) @@ -604,6 +621,12 @@ (when (current-connection *application-frame*) (quit *application-frame* reason))) +(define-beirc-command (com-switch-timestamp-orientation :name t) () + (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left) + :right + :left)) + (redraw-all-receivers)) + (defun target (&optional (*application-frame* *application-frame*)) (or (current-query) (current-channel))) @@ -714,7 +737,7 @@ (clim-sys:make-process #'(lambda () (unwind-protect (irc-event-loop frame connection) - (quit frame "IRC event loop terminated."))) + (disconnect frame))) :name "IRC Message Muffling Loop"))))))) (defun disconnect (frame) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.12 beirc/message-display.lisp:1.13 --- beirc/message-display.lisp:1.12 Sat Sep 24 21:03:15 2005 +++ beirc/message-display.lisp Sun Sep 25 00:30:24 2005 @@ -2,6 +2,7 @@ (defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") (defparameter *default-fill-column* 80) +(defparameter *timestamp-column-orientation* :right) (defvar *max-preamble-length* 0) @@ -34,39 +35,47 @@ (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) :test #'string=)) +(defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer) + (let* ((stream* (if (eql stream t) *standard-output* stream)) + (width (- (floor (bounding-rectangle-width (sheet-parent stream*)) + (clim:stream-string-width stream* "X")) + 2))) + (labels ((output-timestamp-column (position) + (when (eql position *timestamp-column-orientation*) + (formatting-cell (stream* :align-x :left) + (with-drawing-options (stream* :ink +gray+) + (format stream* "[~2,'0D:~2,'0D]" + (nth-value 2 (decode-universal-time (irc:received-time message))) + (nth-value 1 (decode-universal-time (irc:received-time message))))))))) + (updating-output (stream* + :cache-value + (list message + (focused-nicks receiver) + (slot-value *application-frame* 'ignored-nicks) + width + *max-preamble-length* + *timestamp-column-orientation*) + :cache-test #'equal) + (formatting-row (stream*) + (output-timestamp-column :left) + (formatting-cell (stream* :align-x :right :min-width '(16 :character)) + (with-drawing-options (stream* :ink +dark-red+) + (funcall preamble-writer))) + (formatting-cell (stream* :align-x :left + :min-width '(80 :character)) + (funcall message-body-writer)) + (output-timestamp-column :right)))))) + (defmacro formatting-message ((stream message receiver) (&body preamble-column-body) (&body message-body-column-body)) ;; Fix me: This usage of UPDATING-OUTPUT is sub-optimal and ugly! ;; (asf 2005-09-17: is it still?) - (let ((width (gensym)) - (%stream% (gensym)) - (stream* (gensym))) - `(let* ((,%stream% ,stream) - (,stream* (if (eql ,%stream% t) *standard-output* ,%stream%)) - (,width (- (floor (bounding-rectangle-width (sheet-parent ,stream*)) - (clim:stream-string-width ,stream* "X")) - 2))) - (updating-output (,stream* - :cache-value - (list ,message - (focused-nicks ,receiver) - (slot-value *application-frame* 'ignored-nicks) - ,width - *max-preamble-length*) - :cache-test #'equal) - (formatting-row (,stream*) - (formatting-cell (,stream* :align-x :right :min-width '(16 :character)) - (with-drawing-options (,stream* :ink +dark-red+) - , at preamble-column-body)) - (formatting-cell (,stream* :align-x :left - :min-width '(80 :character)) - , at message-body-column-body) - (formatting-cell (,stream* :align-x :left) - (with-drawing-options (,stream* :ink +gray+) - (format ,stream* "[~2,'0D:~2,'0D]" - (nth-value 2 (decode-universal-time (irc:received-time message))) - (nth-value 1 (decode-universal-time (irc:received-time message))))))))))) + `(invoke-formatting-message ,stream ,message ,receiver + (lambda () + , at preamble-column-body) + (lambda () + , at message-body-column-body))) (defun strip-punctuation (word) (if (= (length word) 0) From afuchs at common-lisp.net Sun Sep 25 12:31:14 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 14:31:14 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/beirc.lisp Message-ID: <20050925123114.728848853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv25317 Modified Files: beirc.lisp Log Message: Show QUIT and NICK messages in every channel the user and me are in. This change comes at a price: I had to basically copy cl-irc's READ-MESSAGE method, and use a lot of unexported symbols, too. Ugh. Date: Sun Sep 25 14:31:13 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.29 beirc/beirc.lisp:1.30 --- beirc/beirc.lisp:1.29 Sun Sep 25 00:30:23 2005 +++ beirc/beirc.lisp Sun Sep 25 14:31:05 2005 @@ -157,9 +157,11 @@ (macrolet ((define-global-message-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) - ;; FIXME: global messages should go to all - ;; channels/queries the source (user) was on. - (current-receiver frame)))) + (remove nil + (mapcar (lambda (channel) + (find-receiver (irc:name channel) frame)) + (irc:channels (irc:find-user (beirc::current-connection frame) + (irc:source message)))))))) (define-global-message-receiver-lookup irc:irc-quit-message) (define-global-message-receiver-lookup irc:irc-nick-message)) @@ -438,20 +440,26 @@ (text (or (irc:trailing-argument message) ""))) (search my-nick text))) +(defun post-message-to-receiver (frame message receiver) + (setf (messages receiver) + (append (messages receiver) (list message))) + (unless (eql receiver (current-receiver frame)) + (incf (unseen-messages receiver)) + (when (message-directed-to-me-p frame message) + (incf (messages-directed-to-me receiver)))) + (update-drawing-options receiver) + (clim-internals::event-queue-prepend + (climi::frame-event-queue frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil) + (defun post-message (frame message) (let ((receiver (receiver-for-message message frame))) - (unless (null receiver) - (setf (messages receiver) - (append (messages receiver) (list message))) - (unless (eql receiver (current-receiver frame)) - (incf (unseen-messages receiver)) - (when (message-directed-to-me-p frame message) - (incf (messages-directed-to-me receiver)))) - (update-drawing-options receiver) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) - nil))) + (cond ((consp receiver) + (loop for 1-receiver in receiver + do (post-message-to-receiver frame message 1-receiver))) + ((null receiver) nil) + (t (post-message-to-receiver frame message receiver))))) (defun ticker (frame) (loop @@ -818,10 +826,23 @@ (defclass beirc-connection (irc:connection) ()) -(defmethod irc:read-message :around ((connection beirc-connection)) - (let ((message (call-next-method connection))) - (post-message *application-frame* message) - message)) +;;; 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 irc:read-message ((connection beirc-connection)) + (handler-case + (when (irc::connectedp connection) + (let ((message (irc::read-irc-message connection))) + (post-message *application-frame* message) + (irc::irc-message-event message) + message)) + (stream-error (c) (signal 'irc::invalidate-me :stream + (irc:server-stream connection) + :condition c)))) (defun irc-event-loop (frame connection) (unwind-protect From afuchs at common-lisp.net Sun Sep 25 12:43:54 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 14:43:54 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/presentations.lisp beirc/receivers.lisp beirc/variables.lisp beirc/beirc.asd beirc/message-display.lisp beirc/beirc.lisp Message-ID: <20050925124354.C598B8853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv26166 Modified Files: beirc.asd message-display.lisp Added Files: application.lisp presentations.lisp receivers.lisp variables.lisp Removed Files: beirc.lisp Log Message: Split beirc.lisp further (and remove it): * application-frame, irc functions and clim commands are in application.lisp * receiver functions are in receivers.lisp * presentation types and presentation methods are in presentations.lisp. * user-customizable variables are in variables.lisp. Date: Sun Sep 25 14:43:53 2005 Author: afuchs Index: beirc/beirc.asd diff -u beirc/beirc.asd:1.3 beirc/beirc.asd:1.4 --- beirc/beirc.asd:1.3 Fri Sep 23 21:05:15 2005 +++ beirc/beirc.asd Sun Sep 25 14:43:52 2005 @@ -8,5 +8,8 @@ (defsystem :beirc :depends-on (:mcclim :cl-irc :split-sequence :tab-layout) :components ((:file "package") - (:file "beirc" :depends-on ("package")) - (:file "message-display" :depends-on ("package" "beirc")))) \ No newline at end of file + (:file "variables" :depends-on ("package")) + (:file "receivers" :depends-on ("package" "variables")) + (:file "presentations" :depends-on ("package" "variables")) + (:file "message-display" :depends-on ("package" "variables" "presentations")) + (:file "application" :depends-on ("package" "variables" "presentations" "receivers")))) \ No newline at end of file Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.13 beirc/message-display.lisp:1.14 --- beirc/message-display.lisp:1.13 Sun Sep 25 00:30:24 2005 +++ beirc/message-display.lisp Sun Sep 25 14:43:52 2005 @@ -1,9 +1,5 @@ (in-package :beirc) -(defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") -(defparameter *default-fill-column* 80) -(defparameter *timestamp-column-orientation* :right) - (defvar *max-preamble-length* 0) (define-presentation-type url () From afuchs at common-lisp.net Sun Sep 25 12:55:11 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 14:55:11 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp beirc/package.lisp beirc/variables.lisp Message-ID: <20050925125511.AA0F18853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv27244 Modified Files: message-display.lisp package.lisp variables.lisp Log Message: Load a beirc customization file when the system is loaded. (possibly not the perfect way to do it.) Also, add the *default-fill-column* to the updating-output form, so that changing the fill column redraws all columns. Date: Sun Sep 25 14:55:10 2005 Author: afuchs Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.14 beirc/message-display.lisp:1.15 --- beirc/message-display.lisp:1.14 Sun Sep 25 14:43:52 2005 +++ beirc/message-display.lisp Sun Sep 25 14:55:10 2005 @@ -50,7 +50,8 @@ (slot-value *application-frame* 'ignored-nicks) width *max-preamble-length* - *timestamp-column-orientation*) + *timestamp-column-orientation* + *default-fill-column*) :cache-test #'equal) (formatting-row (stream*) (output-timestamp-column :left) @@ -58,7 +59,7 @@ (with-drawing-options (stream* :ink +dark-red+) (funcall preamble-writer))) (formatting-cell (stream* :align-x :left - :min-width '(80 :character)) + :min-width `(,*default-fill-column* :character)) (funcall message-body-writer)) (output-timestamp-column :right)))))) Index: beirc/package.lisp diff -u beirc/package.lisp:1.2 beirc/package.lisp:1.3 --- beirc/package.lisp:1.2 Fri Sep 23 21:05:15 2005 +++ beirc/package.lisp Sun Sep 25 14:55:10 2005 @@ -1,3 +1,4 @@ (cl:defpackage :beirc (:use :clim :clim-lisp :clim-sys :tab-layout) - (:export #:beirc)) + (:export #:beirc + #:*hyperspec-base-url* #:*default-fill-column* #:*timestamp-column-orientation*)) Index: beirc/variables.lisp diff -u beirc/variables.lisp:1.1 beirc/variables.lisp:1.2 --- beirc/variables.lisp:1.1 Sun Sep 25 14:43:52 2005 +++ beirc/variables.lisp Sun Sep 25 14:55:10 2005 @@ -3,3 +3,9 @@ (defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") (defparameter *default-fill-column* 80) (defparameter *timestamp-column-orientation* :right) + +(defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") + (user-homedir-pathname))) + +(when (probe-file *beirc-user-init-file*) + (load *beirc-user-init-file*)) \ No newline at end of file From afuchs at common-lisp.net Sun Sep 25 15:09:02 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 17:09:02 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20050925150902.C624E88545@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv4035 Modified Files: application.lisp Log Message: add an :around method to read-frame-command. This innocent-sounding summary line enables clicking on presentations without having to enter / first. WOO YAY! Date: Sun Sep 25 17:09:01 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.1 beirc/application.lisp:1.2 --- beirc/application.lisp:1.1 Sun Sep 25 14:43:52 2005 +++ beirc/application.lisp Sun Sep 25 17:09:01 2005 @@ -507,6 +507,14 @@ (list 'com-say (read-line stream)))))) (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 Sun Sep 25 15:48:33 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 17:48:33 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/beirc.asd beirc/presentations.lisp Message-ID: <20050925154833.A7EF988556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv7018 Modified Files: application.lisp beirc.asd presentations.lisp Log Message: quit if the application frame is exited with an active connection. also, rearrange presentations.lisp a bit and add a missing asdf dependency. Date: Sun Sep 25 17:48:32 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.2 beirc/application.lisp:1.3 --- beirc/application.lisp:1.2 Sun Sep 25 17:09:01 2005 +++ beirc/application.lisp Sun Sep 25 17:48:32 2005 @@ -224,6 +224,8 @@ :name "Beirc Ticker"))) (setf *beirc-frame* frame) (run-frame-top-level frame) + (unless (null (current-connection frame)) + (irc:quit (current-connection frame) "Client Quit")) (clim-sys:destroy-process ticker-process)))))))) (defun message-directed-to-me-p (frame message) @@ -443,6 +445,19 @@ (presentation) (list (presentation-object presentation))) +(define-presentation-translator receiver-pane-to-receiver-translator + (receiver-pane receiver beirc) + (object) + (receiver-from-tab-pane + (find-in-tab-panes-list object 'tab-layout-pane))) + +#+(or) ; XXX: for some reason, this translator is activated when accepting NICKNAME. +(define-presentation-translator nickname-to-hostmask-translator + (nickname hostmask beirc) + (object) + (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)) (irc:join (current-connection *application-frame*) channel)) @@ -587,17 +602,6 @@ (redisplay-frame-pane (pane-frame pane) pane))) ;;;;;; - -(define-presentation-type mumble ()) - -(define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) - (with-output-to-string (bag) - (loop - (let ((c (peek-char nil))) - (cond ((char= c #\newline) - (return)) - (t - (write-char (read-char) bag))))))) (define-beirc-command (com-me :name t) ((what 'mumble)) (with-slots (connection) *application-frame* Index: beirc/beirc.asd diff -u beirc/beirc.asd:1.4 beirc/beirc.asd:1.5 --- beirc/beirc.asd:1.4 Sun Sep 25 14:43:52 2005 +++ beirc/beirc.asd Sun Sep 25 17:48:32 2005 @@ -10,6 +10,6 @@ :components ((:file "package") (:file "variables" :depends-on ("package")) (:file "receivers" :depends-on ("package" "variables")) - (:file "presentations" :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")))) Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.1 beirc/presentations.lisp:1.2 --- beirc/presentations.lisp:1.1 Sun Sep 25 14:43:52 2005 +++ beirc/presentations.lisp Sun Sep 25 17:48:32 2005 @@ -1,5 +1,7 @@ (in-package :beirc) +(define-presentation-type mumble ()) + (define-presentation-type nickname ()) (define-presentation-type unhighlighted-nickname () :inherit-from 'nickname) (define-presentation-type ignored-nickname () :inherit-from 'nickname) @@ -10,6 +12,19 @@ (maphash (lambda (k v) (push (cons k v) res)) hashtable) res) +;;; mumble + +(define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) + (with-output-to-string (bag) + (loop + (let ((c (peek-char nil))) + (cond ((char= c #\newline) + (return)) + (t + (write-char (read-char) bag))))))) + +;;; nicknames + (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) (with-slots (connection nick) *application-frame* (let ((users (unless (null (current-channel)) @@ -20,23 +35,6 @@ (with-slots (ignored-nicks) *application-frame* (accept `(member , at ignored-nicks) :prompt nil))) -(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) - (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) - (maphash #'suggest (receivers *application-frame*)))) - -(define-presentation-translator receiver-pane-to-receiver-translator - (receiver-pane receiver beirc) - (object) - (receiver-from-tab-pane - (find-in-tab-panes-list object 'tab-layout-pane))) - -;;; XXX: for some reason, this translator is activated when accepting NICKNAME. -#+(or) -(define-presentation-translator nickname-to-hostmask-translator - (nickname hostmask beirc) - (object) - (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) - (defun nick-equals-my-nick-p (nickname) (and (not (null *application-frame*)) (not (null (slot-value *application-frame* 'connection))) @@ -54,6 +52,14 @@ (with-text-face (t :bold) (write-string o))) (write-string o))) + +;;; receivers + +(define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) + (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) + (maphash #'suggest (receivers *application-frame*)))) + +;;; channels (define-presentation-method presentation-typep (object (type channel)) (channelp object)) From afuchs at common-lisp.net Sun Sep 25 16:08:03 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 18:08:03 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20050925160803.5F77588545@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv8527 Modified Files: application.lisp Log Message: remove the ugly DISCONNECT function. it did the wrong thing, anyway. Date: Sun Sep 25 18:07:58 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.3 beirc/application.lisp:1.4 --- beirc/application.lisp:1.3 Sun Sep 25 17:48:32 2005 +++ beirc/application.lisp Sun Sep 25 18:07:58 2005 @@ -480,25 +480,8 @@ (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) (setf (connection-process *application-frame*) (clim-sys:make-process #'(lambda () - (unwind-protect - (irc-event-loop frame connection) - (disconnect frame))) + (irc-event-loop frame connection)) :name "IRC Message Muffling Loop"))))))) - -(defun disconnect (frame) - (raise-receiver (server-receiver frame)) - (post-message frame - (make-fake-irc-message 'irc:irc-quit-message - :trailing-argument "You disconnected from IRC" - :command "QUIT")) - (when (and (connection-process frame) - (not (eql (clim-sys:current-process) - (connection-process frame)))) - (destroy-process (connection-process frame))) - (setf (slot-value frame 'connection) nil - (connection-process frame) nil - (slot-value frame 'nick) nil)) - (defun quit (frame reason) (raise-receiver (server-receiver frame)) (irc:quit (current-connection frame) reason) From afuchs at common-lisp.net Sun Sep 25 16:30:42 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 18:30:42 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20050925163042.A134C88545@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv9767 Modified Files: application.lisp Log Message: rename QUIT->DISCONNECT and use it from a restart in the irc listener process. also, use :prompt nil on /Me. Date: Sun Sep 25 18:30:40 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.4 beirc/application.lisp:1.5 --- beirc/application.lisp:1.4 Sun Sep 25 18:07:58 2005 +++ beirc/application.lisp Sun Sep 25 18:30:40 2005 @@ -346,12 +346,12 @@ (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) - (quit *application-frame* reason)) + (disconnect *application-frame* reason)) (frame-exit *application-frame*)) (define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) - (quit *application-frame* reason))) + (disconnect *application-frame* reason))) (define-beirc-command (com-switch-timestamp-orientation :name t) () (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left) @@ -480,9 +480,13 @@ (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) (setf (connection-process *application-frame*) (clim-sys:make-process #'(lambda () - (irc-event-loop frame connection)) + (restart-case + (irc-event-loop frame connection) + (disconnect () + :report "Disconnect from IRC" + (disconnect frame "Client Disconnect")))) :name "IRC Message Muffling Loop"))))))) -(defun quit (frame reason) +(defun disconnect (frame reason) (raise-receiver (server-receiver frame)) (irc:quit (current-connection frame) reason) (when (and (connection-process frame) @@ -586,7 +590,7 @@ ;;;;;; -(define-beirc-command (com-me :name t) ((what 'mumble)) +(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 :trailing-argument From afuchs at common-lisp.net Sun Sep 25 17:51:36 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 19:51:36 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/receivers.lisp Message-ID: <20050925175136.7D6EC88556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv15809 Modified Files: application.lisp receivers.lisp Log Message: commit mgr's pointer documentation pane patch. Thanks! Date: Sun Sep 25 19:51:35 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.5 beirc/application.lisp:1.6 --- beirc/application.lisp:1.5 Sun Sep 25 18:30:40 2005 +++ beirc/application.lisp Sun Sep 25 19:51:34 2005 @@ -80,6 +80,7 @@ (:panes (io :interactor) + (pointer-doc :pointer-documentation) (status-bar :application :display-function 'beirc-status-display @@ -106,6 +107,7 @@ (with-tab-layout ('receiver-pane :name 'query) ("*Server*" server 'receiver-pane)) (60 io) + (20 pointer-doc) (20 ;<-- Sigh! Bitrot! status-bar))))) @@ -446,7 +448,11 @@ (list (presentation-object presentation))) (define-presentation-translator receiver-pane-to-receiver-translator - (receiver-pane receiver beirc) + (receiver-pane receiver beirc + :documentation ((object stream) + (format stream "Reiceiver: ~A" + (title (receiver-from-tab-pane + (find-in-tab-panes-list object 'tab-layout-pane)))))) (object) (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane))) Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.1 beirc/receivers.lisp:1.2 --- beirc/receivers.lisp:1.1 Sun Sep 25 14:43:52 2005 +++ beirc/receivers.lisp Sun Sep 25 19:51:34 2005 @@ -11,6 +11,16 @@ (pane :reader pane) (tab-pane :accessor tab-pane))) +(defun slot-value-or-something (object &key (slot 'name) (something "without name")) + (if (slot-boundp object slot) + (slot-value object slot) + something)) + +(defmethod print-object ((receiver receiver) stream) + (print-unreadable-object (receiver stream :type t) + (write-string (slot-value-or-something receiver :slot 'title :something "without title") + stream))) + (define-presentation-type receiver-pane ()) ;;; KLUDGE: make-clim-application-pane doesn't return an application From afuchs at common-lisp.net Sun Sep 25 17:55:27 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 19:55:27 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp Message-ID: <20050925175527.9E9C788556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv15846 Modified Files: application.lisp message-display.lisp Log Message: fix topic display and presentation of URLs within <> brackets Date: Sun Sep 25 19:55:26 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.6 beirc/application.lisp:1.7 --- beirc/application.lisp:1.6 Sun Sep 25 19:51:34 2005 +++ beirc/application.lisp Sun Sep 25 19:55:26 2005 @@ -317,7 +317,8 @@ :SOURCE source)) (define-beirc-command (com-topic :name t) (&key (topic 'mumble :prompt "New topic")) - (if (and (not (string= topic ""))) + (if (and (not (null topic)) + (not (equal topic ""))) (irc:topic- (current-connection *application-frame*) (target) topic) (post-message *application-frame* (make-fake-irc-message 'irc:irc-rpl_topic-message Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.15 beirc/message-display.lisp:1.16 --- beirc/message-display.lisp:1.15 Sun Sep 25 14:55:10 2005 +++ beirc/message-display.lisp Sun Sep 25 19:55:26 2005 @@ -84,12 +84,12 @@ (string last-char))) (otherwise (values word "")))))) -(defun strip-op-signs (word) +(defun strip-preceding-punctuation (word) (if (= (length word) 0) (values word "") (let ((first-char (char word 0))) (case first-char - ((#\@ #\+) + ((#\@ #\+ #\<) (values (subseq word 1) (string first-char))) (otherwise (values word "")))))) @@ -101,9 +101,9 @@ when (> column limit) do (setf column (length word)) (terpri) - do (multiple-value-bind (%word stripped-opsigns) (strip-op-signs word) + do (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word) (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) - (write-string stripped-opsigns) + (write-string stripped-preceding-punctuation) (cond ((search "http://" word%) (present-url word%)) From afuchs at common-lisp.net Sun Sep 25 17:58:14 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 19:58:14 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20050925175814.CBEB688556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv15876 Modified Files: application.lisp Log Message: don't do anything on /say . Date: Sun Sep 25 19:58:14 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.7 beirc/application.lisp:1.8 --- beirc/application.lisp:1.7 Sun Sep 25 19:55:26 2005 +++ beirc/application.lisp Sun Sep 25 19:58:14 2005 @@ -367,13 +367,13 @@ (current-channel))) (define-beirc-command (com-say :name t) ((what 'mumble)) - ;; make a fake IRC-PRIV-MESSAGE object - (post-message *application-frame* - (make-fake-irc-message 'irc:irc-privmsg-message - :trailing-argument what - :arguments (list (target)) - :command "PRIVMSG")) - (irc:privmsg (current-connection *application-frame*) (target) what)) + (unless (string= what "") + (post-message *application-frame* + (make-fake-irc-message 'irc:irc-privmsg-message + :trailing-argument what + :arguments (list (target)) + :command "PRIVMSG")) + (irc:privmsg (current-connection *application-frame*) (target) what))) (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick")) (setf (slot-value *application-frame* 'nick) new-nick) ;This is _not_ the way to do it. From afuchs at common-lisp.net Sun Sep 25 18:19:29 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 20:19:29 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp beirc/receivers.lisp Message-ID: <20050925181929.9C33C88556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv17917 Modified Files: message-display.lisp receivers.lisp Log Message: * handle "you need channel operator status" message right. * fix intern-receiver: should always use the normalized-name Date: Sun Sep 25 20:19:28 2005 Author: afuchs Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.16 beirc/message-display.lisp:1.17 --- beirc/message-display.lisp:1.16 Sun Sep 25 19:55:26 2005 +++ beirc/message-display.lisp Sun Sep 25 20:19:28 2005 @@ -190,6 +190,12 @@ ;;; channel management messages +(defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :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 " ")) Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.2 beirc/receivers.lisp:1.3 --- beirc/receivers.lisp:1.2 Sun Sep 25 19:51:34 2005 +++ beirc/receivers.lisp Sun Sep 25 20:19:28 2005 @@ -72,7 +72,7 @@ :display-time nil :width 400 :height 600 :incremental-redisplay t))) - (setf (gethash name (receivers frame)) receiver) + (setf (gethash normalized-name (receivers frame)) receiver) receiver))))) (defun remove-receiver (receiver frame) @@ -138,7 +138,7 @@ (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) + (1 irc:irc-rpl_topic-message irc:irc-err_chanoprivsneeded-message) (2 irc:irc-rpl_namreply-message) (nil irc:irc-join-message))) @@ -181,7 +181,11 @@ cl-irc:irc-rpl_endofexceptlist-message cl-irc:irc-ping-message)) + +;;; default receiver. (defmethod receiver-for-message ((message irc:irc-message) frame) + #+or ; comment out to debug on uncaught messages. + (break) (server-receiver frame)) ;; TODO: more receiver-for-message methods. From afuchs at common-lisp.net Sun Sep 25 18:21:09 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 20:21:09 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20050925182109.76AFB88556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv17956 Modified Files: application.lisp Log Message: add "unfocus" translator by mgr. Date: Sun Sep 25 20:21:08 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.8 beirc/application.lisp:1.9 --- beirc/application.lisp:1.8 Sun Sep 25 19:58:14 2005 +++ beirc/application.lisp Sun Sep 25 20:21:08 2005 @@ -407,6 +407,15 @@ (object) (list object)) +(define-presentation-to-command-translator nickname-to-unfocus-translator + (nickname com-unfocus beirc + :gesture :menu + :menu t + :documentation "Unfocus this user" + :pointer-documentation "Unfocus this user") + (object) + (list object)) + (define-presentation-to-command-translator nickname-to-query-translator (nickname com-query beirc :gesture :menu From afuchs at common-lisp.net Sun Sep 25 18:53:54 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 25 Sep 2005 20:53:54 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/receivers.lisp Message-ID: <20050925185354.F422E88556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv20130 Modified Files: receivers.lisp Log Message: fix receiver lookup in the presence of global notices and Chanserv on channels. Date: Sun Sep 25 20:53:54 2005 Author: afuchs Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.3 beirc/receivers.lisp:1.4 --- beirc/receivers.lisp:1.3 Sun Sep 25 20:19:28 2005 +++ beirc/receivers.lisp Sun Sep 25 20:53:53 2005 @@ -70,7 +70,7 @@ (lambda (frame pane) (beirc-app-display frame pane receiver)) :display-time nil - :width 400 :height 600 + :width 600 :height 800 :incremental-redisplay t))) (setf (gethash normalized-name (receivers frame)) receiver) receiver))))) @@ -85,26 +85,30 @@ unless the user has opened a query window to the source already.") -(defun network-service-p (source frame) +(defun from-network-service-p (source frame) (member source *network-service-sources* :test (lambda (source1 source2) (string= (irc:normalize-nickname (current-connection frame) source1) (irc:normalize-nickname (current-connection frame) source2))))) +(defun global-notice-p (message target) + (and (typep message 'irc:irc-notice-message) (string= target "$*"))) + (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) - (if (or - (find-receiver (irc:source message) frame) - (not (network-service-p (irc:source message) frame))) - (let* ((mynick (irc:normalize-nickname (current-connection frame) + (let* ((mynick (irc:normalize-nickname (current-connection frame) (slot-value frame 'nick))) (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) (first (irc:arguments message)))) (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (intern-receiver target frame :channel target)) - (server-receiver frame))))) + (if (or (find-receiver (irc:source message) frame) + (not (from-network-service-p (irc:source message) frame)) + (and (string= nominal-target target) + (not (global-notice-p message nominal-target)))) + (intern-receiver target frame :channel target) + (server-receiver frame)))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) (define-privmsg-receiver-lookup irc:irc-notice-message)) From mretzlaff at common-lisp.net Sun Sep 25 18:57:26 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Sun, 25 Sep 2005 20:57:26 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/variables.lisp Message-ID: <20050925185726.4B6F588556@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv20162 Modified Files: application.lisp variables.lisp Log Message: Adds the new variable *default-nick* with the default value "brucio-X" (where X is a random number below 100). The second parameter NICK of COM-CONNECT is now a &KEY parameter, the default being *default-nick*. Date: Sun Sep 25 20:57:25 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.9 beirc/application.lisp:1.10 --- beirc/application.lisp:1.9 Sun Sep 25 20:21:08 2005 +++ beirc/application.lisp Sun Sep 25 20:57:25 2005 @@ -479,7 +479,9 @@ (irc:join (current-connection *application-frame*) channel)) (define-beirc-command (com-connect :name t) - ((server 'string :prompt "Server") (nick 'string :prompt "Nick name")) + ((server 'string :prompt "Server") + &key + (nick 'string :prompt "Nick name" :default *default-nick*)) (cond ((current-connection *application-frame*) (format *query-io* "You are already connected.~%")) (t Index: beirc/variables.lisp diff -u beirc/variables.lisp:1.2 beirc/variables.lisp:1.3 --- beirc/variables.lisp:1.2 Sun Sep 25 14:55:10 2005 +++ beirc/variables.lisp Sun Sep 25 20:57:25 2005 @@ -1,8 +1,9 @@ (in-package :beirc) -(defparameter *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") -(defparameter *default-fill-column* 80) -(defparameter *timestamp-column-orientation* :right) +(defvar *hyperspec-base-url* "file://localhost/Users/dmurray/lisp/HyperSpec/") +(defvar *default-fill-column* 80) +(defvar *timestamp-column-orientation* :right) +(defvar *default-nick* (format nil "Brucio-~d" (random 100))) (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") (user-homedir-pathname))) From afuchs at common-lisp.net Mon Sep 26 08:28:13 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 26 Sep 2005 10:28:13 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20050926082813.2B9D98815C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv11537 Modified Files: application.lisp Log Message: replace (read-line ...) with (accept 'mumble ...) in read-frame-command. this makes RET in the middle of the line work! Date: Mon Sep 26 10:28:10 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.10 beirc/application.lisp:1.11 --- beirc/application.lisp:1.10 Sun Sep 25 20:57:25 2005 +++ beirc/application.lisp Mon Sep 26 10:28:10 2005 @@ -524,7 +524,7 @@ (clim:accept 'clim:command :stream stream :prompt nil)) (t - (list 'com-say (read-line stream)))))) + (list 'com-say (accept 'mumble :prompt nil :stream stream)))))) (window-clear stream))) (defmethod read-frame-command :around ((frame beirc) From afuchs at common-lisp.net Mon Sep 26 09:02:41 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 26 Sep 2005 11:02:41 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp Message-ID: <20050926090241.C57BD8815C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv14580 Modified Files: message-display.lisp Log Message: present the sender nickname in ctcp-action messages as unhighlighted-nickname. Date: Mon Sep 26 11:02:41 2005 Author: afuchs Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.17 beirc/message-display.lisp:1.18 --- beirc/message-display.lisp:1.17 Sun Sep 25 20:19:28 2005 +++ beirc/message-display.lisp Mon Sep 26 11:02:41 2005 @@ -149,7 +149,7 @@ (matter (trailing-argument* message))) (formatting-message (t message receiver) ((format t "*")) - ((present source 'nickname) + ((present source 'unhighlighted-nickname) (format t " ") (format-message* matter :start-length (+ 2 (length source))))))) From afuchs at common-lisp.net Mon Sep 26 09:46:29 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 26 Sep 2005 11:46:29 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/receivers.lisp Message-ID: <20050926094629.7417F8815C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv17689 Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: add a /whois command, nick translator, display methods, and a channel->join translator. Date: Mon Sep 26 11:46:25 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.11 beirc/application.lisp:1.12 --- beirc/application.lisp:1.11 Mon Sep 26 10:28:10 2005 +++ beirc/application.lisp Mon Sep 26 11:46:25 2005 @@ -297,6 +297,9 @@ (remove who (current-focused-nicks) :test #'string=)) (redraw-receiver (current-receiver *application-frame*))) +(define-beirc-command (com-whois :name t) ((who 'nickname :prompt "who")) + (irc:whois (current-connection *application-frame*) who)) + (define-beirc-command (com-eval :name t) ((command 'string :prompt "command") (args '(sequence string) :prompt "arguments")) (multiple-value-bind (symbol status) (find-symbol (string-upcase command) :irc) @@ -449,6 +452,24 @@ :menu t :documentation "Ban this user's hostmask" :pointer-documentation "Ban this user's hostmask") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-whois-translator + (nickname com-whois beirc + :gesture :select + :menu t + :documentation "Perform WHOIS query on user" + :pointer-documentation "Perform WHOIS query on user") + (object) + (list object)) + +(define-presentation-to-command-translator channel-to-join-translator + (channel com-join beirc + :gesture :describe + :menu t + :documentation "Join this channel" + :pointer-documentation "Join this channel") (object) (list object)) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.18 beirc/message-display.lisp:1.19 --- beirc/message-display.lisp:1.18 Mon Sep 26 11:02:41 2005 +++ beirc/message-display.lisp Mon Sep 26 11:46:25 2005 @@ -112,6 +112,7 @@ (and (current-connection *application-frame*) (irc:find-user (current-connection *application-frame*) word%))) (present word% 'nickname)) + ((channelp word%) (present word% 'channel)) (t (write-string word%))) (write-string stripped-punctuation))) ;; TODO: more highlighting @@ -153,6 +154,15 @@ (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)))))))) + ;;; server messages (defmethod print-message ((message irc:irc-rpl_motd-message) receiver) @@ -165,7 +175,7 @@ (formatting-message (t message receiver) ((format t "!!! ~A" (irc:source message))) ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message)))))) + (format t "~A ~A :~A" (irc:command message) (irc:arguments message) (irc:trailing-argument message)))))) ;;; user-related messages @@ -187,6 +197,50 @@ (present (irc:source message) 'nickname) (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) (present (irc:trailing-argument message) 'nickname))))) + +(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 (~A@~A) (~A)" user host (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)))))))) + +(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)))))))) + +(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)))))))) + +(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)))))))) ;;; channel management messages Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.4 beirc/receivers.lisp:1.5 --- beirc/receivers.lisp:1.4 Sun Sep 25 20:53:53 2005 +++ beirc/receivers.lisp Mon Sep 26 11:46:25 2005 @@ -142,7 +142,7 @@ (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-err_chanoprivsneeded-message) + (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message irc:irc-err_chanoprivsneeded-message irc:irc-err_nosuchnick-message) (2 irc:irc-rpl_namreply-message) (nil irc:irc-join-message))) @@ -160,6 +160,16 @@ (3 (destructuring-bind (channel modes args) (irc:arguments message) (declare (ignore modes args)) (intern-receiver channel frame :channel channel))))) + +(macrolet ((define-current-receiver-message-types (&rest mtypes) + `(progn + ,@(loop for mtype in mtypes + collect `(defmethod receiver-for-message ((message ,mtype) frame) + (current-receiver frame)))))) + (define-current-receiver-message-types + irc:irc-rpl_whoisuser-message + irc:irc-rpl_whoischannels-message + irc:irc-rpl_whoisserver-message)) (macrolet ((define-ignore-message-types (&rest mtypes) `(progn From afuchs at common-lisp.net Mon Sep 26 10:52:06 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 26 Sep 2005 12:52:06 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/receivers.lisp Message-ID: <20050926105206.DCEE088549@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv22379 Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: add handling for the "no such nick or channel" message. Date: Mon Sep 26 12:52:05 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.12 beirc/application.lisp:1.13 --- beirc/application.lisp:1.12 Mon Sep 26 11:46:25 2005 +++ beirc/application.lisp Mon Sep 26 12:52:05 2005 @@ -269,6 +269,8 @@ (raise-receiver receiver)) (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!")) (let* ((connection (current-connection *application-frame*)) (channel (irc:find-channel connection (title receiver)))) (when channel Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.19 beirc/message-display.lisp:1.20 --- beirc/message-display.lisp:1.19 Mon Sep 26 11:46:25 2005 +++ beirc/message-display.lisp Mon Sep 26 12:52:05 2005 @@ -244,10 +244,23 @@ ;;; 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))))))) + (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) (formatting-message (t message receiver) ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + ((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) @@ -267,6 +280,16 @@ (defmethod print-message ((message irc:irc-rpl_topic-message) receiver) (print-topic receiver message nil (second (irc:arguments message)) (irc:trailing-argument message))) + +(defmethod print-message ((message irc:irc-rpl_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))))))) (defmethod print-message ((message irc:irc-rpl_namreply-message) receiver) (formatting-message (t message receiver) Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.5 beirc/receivers.lisp:1.6 --- beirc/receivers.lisp:1.5 Mon Sep 26 11:46:25 2005 +++ beirc/receivers.lisp Mon Sep 26 12:52:05 2005 @@ -142,7 +142,7 @@ (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 irc:irc-err_nosuchnick-message) + (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message irc:irc-err_chanoprivsneeded-message) (2 irc:irc-rpl_namreply-message) (nil irc:irc-join-message))) @@ -169,7 +169,8 @@ (define-current-receiver-message-types irc:irc-rpl_whoisuser-message irc:irc-rpl_whoischannels-message - irc:irc-rpl_whoisserver-message)) + irc:irc-rpl_whoisserver-message + irc:irc-err_nosuchnick-message)) (macrolet ((define-ignore-message-types (&rest mtypes) `(progn From afuchs at common-lisp.net Tue Sep 27 20:53:42 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Tue, 27 Sep 2005 22:53:42 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/presentations.lisp beirc/receivers.lisp Message-ID: <20050927205342.268D688558@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv2856 Modified Files: application.lisp presentations.lisp receivers.lisp Log Message: Add nickname tab completion using complete-input and a custom completion function. Date: Tue Sep 27 22:53:41 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.13 beirc/application.lisp:1.14 --- beirc/application.lisp:1.13 Mon Sep 26 12:52:05 2005 +++ beirc/application.lisp Tue Sep 27 22:53:41 2005 @@ -352,6 +352,9 @@ (define-beirc-command (com-names :name t) () (irc:names (current-connection *application-frame*) (target))) +(define-beirc-command (com-away :name t) ((reason 'mumble :prompt "reason")) + (irc:away (current-connection *application-frame*) reason)) + (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) (disconnect *application-frame* reason)) Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.2 beirc/presentations.lisp:1.3 --- beirc/presentations.lisp:1.2 Sun Sep 25 17:48:32 2005 +++ beirc/presentations.lisp Tue Sep 27 22:53:41 2005 @@ -14,14 +14,54 @@ ;;; mumble +(defun split-input-line (so-far) + (multiple-value-bind (word subseq-index) + (split-sequence:split-sequence #\Space so-far + :from-end t + :remove-empty-subseqs nil + :count 1) + (values (first word) + (if (= 0 subseq-index) + "" + (concatenate 'string (subseq so-far 0 subseq-index) " "))))) + +(defun nickname-completer (so-far mode) + (multiple-value-bind (word prefix) (split-input-line so-far) + (labels ((prefixify (word) + (if (zerop (length prefix)) + (concatenate 'string word ": ") + (concatenate 'string prefix word " ")))) + (multiple-value-bind (string success object nmatches possibilities) + (complete-from-possibilities word + (if (not (null (current-channel))) + (hash-alist + (irc:users + (irc:find-channel + (current-connection *application-frame*) + (current-channel)))) + nil) + '() + :action mode + :value-key #'cdr) + (values (prefixify string) + success object nmatches (mapcar (lambda (possibility) + (cons (prefixify (car possibility)) + (cdr possibility))) + possibilities)))))) + +;; FIXME/FIXMCCLIM: :possibility-printer is ignored in current +;; McCLIM's COMPLETE-INPUT implementation. +#+(or) +(defun nickname-completion-printer (string object stream) + (declare (ignore string)) + (present (irc:name object) 'nickname :stream stream)) + (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) - (with-output-to-string (bag) - (loop - (let ((c (peek-char nil))) - (cond ((char= c #\newline) - (return)) - (t - (write-char (read-char) bag))))))) + (let ((*completion-gestures* '(#\Tab))) + (nth-value 2 + (complete-input *standard-input* 'nickname-completer + #+(or):possibility-printer #+(or) 'nickname-competion-printer + :allow-any-input t)))) ;;; nicknames Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.6 beirc/receivers.lisp:1.7 --- beirc/receivers.lisp:1.6 Mon Sep 26 12:52:05 2005 +++ beirc/receivers.lisp Tue Sep 27 22:53:41 2005 @@ -170,6 +170,7 @@ irc:irc-rpl_whoisuser-message irc:irc-rpl_whoischannels-message irc:irc-rpl_whoisserver-message + irc:irc-rpl_whoisidentified-message irc:irc-err_nosuchnick-message)) (macrolet ((define-ignore-message-types (&rest mtypes) From afuchs at common-lisp.net Tue Sep 27 20:58:43 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Tue, 27 Sep 2005 22:58:43 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/presentations.lisp Message-ID: <20050927205843.962A788558@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv2916 Modified Files: presentations.lisp Log Message: fix case in completion results. This means that completion is now case-insensitive and always completes to the correct case. Date: Tue Sep 27 22:58:42 2005 Author: afuchs Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.3 beirc/presentations.lisp:1.4 --- beirc/presentations.lisp:1.3 Tue Sep 27 22:53:41 2005 +++ beirc/presentations.lisp Tue Sep 27 22:58:41 2005 @@ -43,7 +43,9 @@ '() :action mode :value-key #'cdr) - (values (prefixify string) + (values (if (null object) + (prefixify string) + (prefixify (irc:nickname object))) success object nmatches (mapcar (lambda (possibility) (cons (prefixify (car possibility)) (cdr possibility))) @@ -54,7 +56,7 @@ #+(or) (defun nickname-completion-printer (string object stream) (declare (ignore string)) - (present (irc:name object) 'nickname :stream stream)) + (present (irc:nickname object) 'nickname :stream stream)) (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) (let ((*completion-gestures* '(#\Tab))) From afuchs at common-lisp.net Wed Sep 28 19:33:29 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Wed, 28 Sep 2005 21:33:29 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/presentations.lisp Message-ID: <20050928193329.E513D88031@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv711 Modified Files: application.lisp message-display.lisp presentations.lisp Log Message: Fix accepting 'mumble when entering /command args; some style issues; fix accepting 'nickname when in non-channel buffers. Date: Wed Sep 28 21:33:28 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.14 beirc/application.lisp:1.15 --- beirc/application.lisp:1.14 Tue Sep 27 22:53:41 2005 +++ beirc/application.lisp Wed Sep 28 21:33:28 2005 @@ -547,8 +547,7 @@ (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)) + (clim:accept 'clim:command :stream stream :prompt nil)) (t (list 'com-say (accept 'mumble :prompt nil :stream stream)))))) (window-clear stream))) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.20 beirc/message-display.lisp:1.21 --- beirc/message-display.lisp:1.20 Mon Sep 26 12:52:05 2005 +++ beirc/message-display.lisp Wed Sep 28 21:33:28 2005 @@ -230,7 +230,7 @@ ((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)) + (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) Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.4 beirc/presentations.lisp:1.5 --- beirc/presentations.lisp:1.4 Tue Sep 27 22:58:41 2005 +++ beirc/presentations.lisp Wed Sep 28 21:33:28 2005 @@ -33,19 +33,20 @@ (concatenate 'string prefix word " ")))) (multiple-value-bind (string success object nmatches possibilities) (complete-from-possibilities word - (if (not (null (current-channel))) - (hash-alist - (irc:users - (irc:find-channel - (current-connection *application-frame*) - (current-channel)))) - nil) + (let ((channel (and + (current-channel) + (irc:find-channel + (current-connection *application-frame*) + (current-channel))))) + (if (not (null channel)) + (hash-alist (irc:users channel)) + nil)) '() :action mode :value-key #'cdr) - (values (if (null object) - (prefixify string) - (prefixify (irc:nickname object))) + (values (prefixify (if (null object) + string + (irc:nickname object))) success object nmatches (mapcar (lambda (possibility) (cons (prefixify (car possibility)) (cdr possibility))) @@ -59,18 +60,22 @@ (present (irc:nickname object) 'nickname :stream stream)) (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) - (let ((*completion-gestures* '(#\Tab))) + (with-delimiter-gestures (nil :override t) + (let ((*completion-gestures* '(#\Tab))) (nth-value 2 (complete-input *standard-input* 'nickname-completer #+(or):possibility-printer #+(or) 'nickname-competion-printer - :allow-any-input t)))) + :allow-any-input t + :partial-completers '()))))) ;;; nicknames (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) (with-slots (connection nick) *application-frame* - (let ((users (unless (null (current-channel)) - (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))) + (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)))) (define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key) From afuchs at common-lisp.net Wed Sep 28 19:40:08 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Wed, 28 Sep 2005 21:40:08 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20050928194008.A875C88031@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv766 Modified Files: application.lisp Log Message: Fix the hostname translator: add a tester to it that returns true only for the 'hostmask input-context. Date: Wed Sep 28 21:40:08 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.15 beirc/application.lisp:1.16 --- beirc/application.lisp:1.15 Wed Sep 28 21:33:28 2005 +++ beirc/application.lisp Wed Sep 28 21:40:07 2005 @@ -493,9 +493,11 @@ (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane))) -#+(or) ; XXX: for some reason, this translator is activated when accepting NICKNAME. (define-presentation-translator nickname-to-hostmask-translator - (nickname hostmask beirc) + (nickname hostmask beirc + :tester ((object context-type) + (declare (ignore object)) + (eql context-type 'hostmask))) (object) (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) From afuchs at common-lisp.net Thu Sep 29 14:51:26 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Thu, 29 Sep 2005 16:51:26 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/receivers.lisp Message-ID: <20050929145126.58C7588549@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv16324 Modified Files: application.lisp receivers.lisp Log Message: change (EQL input-context 'hostmask) to (presenation-subtypep i-c 'h);. Date: Thu Sep 29 16:51:25 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.16 beirc/application.lisp:1.17 --- beirc/application.lisp:1.16 Wed Sep 28 21:40:07 2005 +++ beirc/application.lisp Thu Sep 29 16:51:25 2005 @@ -497,7 +497,7 @@ (nickname hostmask beirc :tester ((object context-type) (declare (ignore object)) - (eql context-type 'hostmask))) + (presentation-subtypep context-type 'hostmask))) (object) (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.7 beirc/receivers.lisp:1.8 --- beirc/receivers.lisp:1.7 Tue Sep 27 22:53:41 2005 +++ beirc/receivers.lisp Thu Sep 29 16:51:25 2005 @@ -103,9 +103,9 @@ (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (if (or (find-receiver (irc:source message) frame) + (if (or (find-receiver target frame) (not (from-network-service-p (irc:source message) frame)) - (and (string= nominal-target target) + (and (eql nominal-target target) (not (global-notice-p message nominal-target)))) (intern-receiver target frame :channel target) (server-receiver frame)))))) @@ -171,6 +171,7 @@ irc:irc-rpl_whoischannels-message irc:irc-rpl_whoisserver-message irc:irc-rpl_whoisidentified-message + irc:irc-rpl_away-message irc:irc-err_nosuchnick-message)) (macrolet ((define-ignore-message-types (&rest mtypes) From afuchs at common-lisp.net Fri Sep 30 13:30:58 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Fri, 30 Sep 2005 15:30:58 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/presentations.lisp Message-ID: <20050930133058.92F6D88565@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv14091 Modified Files: application.lisp presentations.lisp Log Message: Query for a sarcastic kick message on /kick. Also, fix completion of incomplete nicknames Date: Fri Sep 30 15:30:56 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.17 beirc/application.lisp:1.18 --- beirc/application.lisp:1.17 Thu Sep 29 16:51:25 2005 +++ beirc/application.lisp Fri Sep 30 15:30:34 2005 @@ -346,8 +346,8 @@ (define-beirc-command (com-ban-hostmask :name t) ((who 'hostmask :prompt "hostmask")) (irc:ban (current-connection *application-frame*) (target) who)) -(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who")) - (irc:kick (current-connection *application-frame*) (target) who)) +(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who") (reason 'mumble :prompt "reason")) + (irc:kick (current-connection *application-frame*) (target) who reason)) (define-beirc-command (com-names :name t) () (irc:names (current-connection *application-frame*) (target))) @@ -440,7 +440,11 @@ :documentation "Kick this user" :pointer-documentation "Kick this user") (object) - (list object)) + (list object + ;; XXX: not the best way to do it. McCLIM should recognize + ;; that this is a partial command and query for the rest of + ;; the args itself. + (accept 'mumble :prompt " Reason"))) (define-presentation-to-command-translator nickname-to-ban-nick-translator (nickname com-ban-nick beirc Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.5 beirc/presentations.lisp:1.6 --- beirc/presentations.lisp:1.5 Wed Sep 28 21:33:28 2005 +++ beirc/presentations.lisp Fri Sep 30 15:30:36 2005 @@ -27,10 +27,11 @@ (defun nickname-completer (so-far mode) (multiple-value-bind (word prefix) (split-input-line so-far) - (labels ((prefixify (word) - (if (zerop (length prefix)) - (concatenate 'string word ": ") - (concatenate 'string prefix word " ")))) + (labels ((prefixify (word &optional (success t)) + (concatenate 'string prefix word + (cond ((not success) "") + ((zerop (length prefix)) ": ") + (t " "))))) (multiple-value-bind (string success object nmatches possibilities) (complete-from-possibilities word (let ((channel (and @@ -38,15 +39,16 @@ (irc:find-channel (current-connection *application-frame*) (current-channel))))) - (if (not (null channel)) - (hash-alist (irc:users channel)) - nil)) + (if (not (null channel)) + (hash-alist (irc:users channel)) + nil)) '() :action mode :value-key #'cdr) - (values (prefixify (if (null object) + (values (prefixify (if (not success) string - (irc:nickname object))) + (irc:nickname object)) + success) success object nmatches (mapcar (lambda (possibility) (cons (prefixify (car possibility)) (cdr possibility))) From afuchs at common-lisp.net Fri Sep 30 13:46:19 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Fri, 30 Sep 2005 15:46:19 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/receivers.lisp Message-ID: <20050930134619.2914F8854C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv16023 Modified Files: receivers.lisp Log Message: Re-do global notices. Again. This time, for sure! (At least we'll have a chance of understanding the logic now (-:) Date: Fri Sep 30 15:46:18 2005 Author: afuchs Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.8 beirc/receivers.lisp:1.9 --- beirc/receivers.lisp:1.8 Thu Sep 29 16:51:25 2005 +++ beirc/receivers.lisp Fri Sep 30 15:46:18 2005 @@ -85,14 +85,23 @@ unless the user has opened a query window to the source already.") +(defparameter *global-notice-targets* '("$*" "auth") + "NOTICE message targets that should be treated as network +service targets.") + +(defun nickname-comparator (frame) + (lambda (nick1 nick2) + (string= (irc:normalize-nickname (current-connection frame) nick1) + (irc:normalize-nickname (current-connection frame) nick2)))) + (defun from-network-service-p (source frame) (member source *network-service-sources* - :test (lambda (source1 source2) - (string= (irc:normalize-nickname (current-connection frame) source1) - (irc:normalize-nickname (current-connection frame) source2))))) + :test (nickname-comparator frame))) -(defun global-notice-p (message target) - (and (typep message 'irc:irc-notice-message) (string= target "$*"))) +(defun global-notice-p (message target frame) + (and (typep message 'irc:irc-notice-message) + (member target *global-notice-targets* + :test (nickname-comparator frame)))) (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) @@ -103,12 +112,14 @@ (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (if (or (find-receiver target frame) - (not (from-network-service-p (irc:source message) frame)) - (and (eql nominal-target target) - (not (global-notice-p message nominal-target)))) - (intern-receiver target frame :channel target) - (server-receiver frame)))))) + (cond ((find-receiver target frame) + (intern-receiver target 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)) + (t + (intern-receiver target frame :channel target))))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) (define-privmsg-receiver-lookup irc:irc-notice-message))