February 2006 - beirc-cvs@common-lisp.net

[beirc-cvs] CVS beirc
by afuchs 25 Feb '06

25 Feb '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16258 Modified Files: application.lisp message-display.lisp presentations.lisp receivers.lisp Log Message: Multi-server support; also, make mode change printing more robust. There's a bug on /quit that I couldn't figure out; users are advised to use the terminate-thread restart for now (or help me find the bug (-:) Details: * /connect allows opening more than one connection now. * (current-connection frame) now returns the current connection of the currently selected receiver. * this means that every command operates on the current connection now. * (except /quit, which terminates all connections and closes the window) --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/23 19:43:29 1.40 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/25 15:22:22 1.41 @@ -70,12 +70,11 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) - ((connection :initform nil :reader current-connection) - (connection-process :initform nil :accessor connection-process) + ((connection-processes :initform nil :accessor connection-processes) (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) - (server-receiver :initform (make-paneless-receiver "*Server*") :reader server-receiver) + (server-receivers :initform nil :reader server-receivers) (tab-panes-to-receivers :initform (make-hash-table :test #'equal) :accessor tab-panes-to-receivers)) (:panes (io @@ -105,7 +104,7 @@ (default (vertically () (with-tab-layout ('receiver-pane :name 'query) - ("*Server*" server 'receiver-pane)) + ("*Not Connected*" server 'receiver-pane)) ;; (68 io) ;; no drop-shadow prompt (72 io) (20 pointer-doc) @@ -121,6 +120,26 @@ receiver nil))) +(defmethod current-connection ((frame beirc)) + (when (current-receiver frame) + (connection (current-receiver frame)))) + +(defmethod server-receiver ((frame beirc) + &optional (connection (current-connection *application-frame*))) + (cdr (assoc connection (server-receivers frame) :test #'connection=))) + +(defmethod (setf server-receiver) (newval (frame beirc) + &optional (connection (current-connection *application-frame*))) + (pushnew (cons connection newval) (slot-value frame 'server-receivers) + :key #'car :test #'connection=)) + +(defmethod connection-process ((frame beirc) connection) + (cdr (assoc connection (connection-processes frame) :test #'connection=))) + +(defmethod (setf connection-process) (newval (frame beirc) connection) + (pushnew (cons connection newval) (slot-value frame 'connection-processes) + :key #'car :test #'connection=)) + (defvar *gui-process* nil) (defvar *beirc-frame*) @@ -242,9 +261,8 @@ (setf *beirc-frame* frame) (load-user-init-file) (run-frame-top-level frame) - (unless (null (current-connection frame)) - (irc:quit (current-connection frame) "Client Quit")) - (clim-sys:destroy-process ticker-process)))))))) + (clim-sys:destroy-process ticker-process) + (disconnect-all frame "Client Quit")))))))) (defun message-directed-to-me-p (frame message) (irc:destructuring-arguments (&last body) message @@ -314,7 +332,8 @@ (format nil "IDENTIFY ~A" password))) (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) - (raise-receiver (intern-receiver nick *application-frame* :query nick))) + (raise-receiver (intern-receiver nick (current-connection *application-frame*) + *application-frame* :query nick))) (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) @@ -413,7 +432,7 @@ trailing-argument) (make-instance message-type :received-time (get-universal-time) - :connection :local + :connection (current-connection *application-frame*) :arguments `(,@arguments ,trailing-argument) :command command :HOST "localhost" @@ -467,13 +486,12 @@ (irc:away (current-connection *application-frame*) "")) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) - (when (current-connection *application-frame*) - (disconnect *application-frame* reason)) + (disconnect-all *application-frame* reason) (frame-exit *application-frame*)) (define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) - (disconnect *application-frame* reason))) + (disconnect (current-connection *application-frame*) *application-frame* reason))) (define-beirc-command (com-switch-timestamp-orientation :name t) () (setf *timestamp-column-orientation* (if (eql *timestamp-column-orientation* :left) @@ -505,15 +523,14 @@ (com-msg (target) what)) (define-beirc-command (com-me :name t) ((what 'mumble :prompt nil)) - (with-slots (connection) *application-frame* - (let ((m (make-fake-irc-message 'irc:ctcp-action-message + (let ((m (make-fake-irc-message 'irc:ctcp-action-message :trailing-argument (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) :arguments (list (target)) :command "PRIVMSG"))) ;### (post-message *application-frame* m) - (irc:privmsg connection (target) - (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))) + (irc:privmsg (current-connection *application-frame*) (target) + (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1))))) (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick")) (setf (slot-value *application-frame* 'nick) new-nick) ;This is _not_ the way to do it. @@ -697,9 +714,16 @@ (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) (define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) - (raise-receiver (intern-receiver channel *application-frame* :channel channel)) + (raise-receiver (intern-receiver channel (current-connection *application-frame*) + *application-frame* :channel channel)) (irc:join (current-connection *application-frame*) channel)) +(defun connection= (connection1 connection2) + ;; TODO: should compare by network, not by server name. + ;; TODO: also, there is no port that we could compare. + (and (equal (irc:nickname (irc:user connection1)) (irc:nickname (irc:user connection2))) + (equal (irc:server-name connection1) (irc:server-name connection2)))) + (define-beirc-command (com-connect :name t) ((server 'string :prompt "Server") &key @@ -707,54 +731,47 @@ (pass 'string :prompt "Password" :default nil) (port 'number :prompt "Port" :default irc::*default-irc-server-port*)) (let ((success nil)) - (cond ((current-connection *application-frame*) - (format *query-io* "You are already connected.~%")) - (t - (setf (slot-value *application-frame* 'connection) - (apply #'irc:connect - :nickname nick :server server :connection-type 'beirc-connection :port port - (if (null pass) - nil - `(:password ,pass)))) - (unwind-protect - (progn - (setf (irc:client-stream (current-connection *application-frame*)) - (make-broadcast-stream)) - (setf (slot-value *application-frame* 'nick) nick) - (let ((connection (current-connection *application-frame*))) - (let ((frame *application-frame*)) - (loop for receiver being the hash-values of (receivers frame) - if (channelp (channel receiver)) - do (irc:join connection (channel receiver))) - (join-missing-channels frame) - (initialize-receiver-with-pane (server-receiver frame) frame - (find-pane-named frame 'server) - :add-pane-p nil) - (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) - (setf (connection-process *application-frame*) - (clim-sys:make-process #'(lambda () - (restart-case - (irc-event-loop frame connection) - (disconnect () - :report "Disconnect from IRC" - (disconnect frame "Client Disconnect")))) - :name "IRC Message Muffling Loop")))) - (setf success t)) - (unless success - (disconnect *application-frame* "Client error."))))))) + (let* ((frame *application-frame*) + (connection (apply #'irc:connect + :nickname nick :server server :connection-type 'beirc-connection :port port + (if (null pass) + nil + `(:password ,pass)))) + (server-receiver (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame))) + (unwind-protect + (progn + (setf (irc:client-stream connection) (make-broadcast-stream)) + (setf (slot-value *application-frame* 'nick) nick) + (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server) + (find-pane-named frame 'query)) + (tab-layout:remove-pane (find-pane-named frame 'server) + (find-pane-named frame 'query))) + (setf (server-receiver frame connection) server-receiver) + (setf (connection-process *application-frame* connection) + (clim-sys:make-process #'(lambda () + (restart-case + (irc-event-loop frame connection) + (disconnect () + :report "Terminate this connection" + (disconnect connection frame "Client Disconnect")))) + :name "IRC Message Muffling Loop")) + (setf success t)) + (unless success + (disconnect connection frame "Client error.")))))) -(defun disconnect (frame reason) +(defun disconnect (connection frame reason) (raise-receiver (server-receiver frame)) - (irc:quit (current-connection frame) reason) - (when (and (connection-process frame) + (irc:quit connection reason) + (when (and (connection-process frame connection) (not (eql (clim-sys:current-process) - (connection-process frame)))) - (destroy-process (connection-process frame))) - (setf (slot-value frame 'connection) nil - (connection-process frame) nil + (connection-process frame connection)))) + (destroy-process (connection-process frame connection))) + (setf (connection-process frame connection) nil (slot-value frame 'nick) nil)) - +(defun disconnect-all (frame reason) + (loop for (conn . receiver) in (server-receivers frame) + do (disconnect (connection receiver) frame reason))) (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) (multiple-value-prog1 @@ -768,7 +785,7 @@ (clim:read-gesture :stream stream) (clim:accept 'clim:command :stream stream :prompt nil)) (t - (list 'com-say (accept 'mumble :prompt nil :stream stream)))) + (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream)))) (setf *last-input-line* nil))) (command (let ((buffer (stream-input-buffer stream))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/22 16:30:50 1.32 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/25 15:22:22 1.33 @@ -396,8 +396,8 @@ target mode))) (defmethod print-mode-change (target op mode (user irc:user)) - (format t "~A~A:" op (mode-symbol-to-char target mode)) - (present (irc:nickname user) 'nickname)) + (format t "~A~A:" op (mode-symbol-to-char target mode)) + (present (irc:nickname user) 'nickname)) (defmethod print-mode-change (target op (mode (eql :limit)) arg) (format t "~A~A" op (mode-symbol-to-char target mode)) @@ -405,12 +405,6 @@ (write-char #\:) (present arg 'number))) -(defmethod print-mode-change (target op (mode (eql :key)) arg) - (format t "~A~A" op (mode-symbol-to-char target mode)) - (when (not (null arg)) - (write-char #\:) - (present arg 'string))) - (macrolet ((define-mode-change-with-hostmask-printer (&rest modes) `(progn ,@(loop for mode in modes @@ -419,8 +413,8 @@ (present mask 'hostmask)))))) (define-mode-change-with-hostmask-printer :ban :invite :except)) -(defmethod print-mode-change (target op mode (arg (eql nil))) - (format t "~A~A" op (mode-symbol-to-char target mode))) +(defmethod print-mode-change (target op mode arg) + (format t "~A~A~:[~;:~A~]" op (mode-symbol-to-char target mode) arg arg)) (defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/01/27 17:18:04 1.8 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/02/25 15:22:22 1.9 @@ -88,7 +88,7 @@ (defun nick-equals-my-nick-p (nickname) (and (not (null *application-frame*)) - (not (null (slot-value *application-frame* 'connection))) + (not (null (current-connection *application-frame*))) (equal (irc:normalize-nickname (current-connection *application-frame*) (slot-value *application-frame* 'nick)) (irc:normalize-nickname (current-connection *application-frame*) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/22 16:30:50 1.16 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/25 15:22:22 1.17 @@ -6,6 +6,7 @@ (all-unseen-messages :accessor all-unseen-messages :initform 0) (messages-directed-to-me :accessor messages-directed-to-me :initform 0) (channel :reader channel :initform nil :initarg :channel) + (connection :accessor connection :initarg :connection) (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. (focused-nicks :accessor focused-nicks :initform nil) (title :reader title :initarg :title) @@ -59,17 +60,18 @@ (change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) -(defun find-receiver (name frame) - (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) +(defun find-receiver (name connection frame) + (gethash (list connection (irc:normalize-channel-name connection name)) (receivers frame))) -(defun intern-receiver (name frame &rest initargs) - (let* ((normalized-name (irc:normalize-channel-name (slot-value frame 'connection) name)) - (rec (find-receiver name frame))) +(defun intern-receiver (name connection frame &rest initargs) + (let* ((normalized-name (irc:normalize-channel-name connection name)) + (rec (find-receiver name connection frame))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-paneless-receiver normalized-name initargs))) + (let ((receiver (apply 'make-paneless-receiver normalized-name :connection connection + initargs))) (initialize-receiver-with-pane receiver frame (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) @@ -80,7 +82,7 @@ :display-time nil :min-width 600 :min-height 800 :incremental-redisplay t))) - (setf (gethash normalized-name (receivers frame)) receiver) + (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver))))) (defun remove-receiver (receiver frame) @@ -115,19 +117,19 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (let* ((mynick (irc:normalize-nickname (current-connection frame) (slot-value frame 'nick))) - (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) + (nominal-target (irc:normalize-channel-name (irc:connection message) (first (irc:arguments message)))) (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (cond ((find-receiver target frame) - (intern-receiver target frame :channel target)) + (cond ((find-receiver target (irc:connection message) frame) + (intern-receiver target (irc:connection message) frame :channel target)) ((or (global-notice-p message nominal-target frame) (and (from-network-service-p (irc:source message) frame) (equal nominal-target mynick))) - (server-receiver frame)) + (server-receiver frame (irc:connection message))) (t - (intern-receiver target frame :channel target))))))) + (intern-receiver target (irc:connection message) frame :channel target))))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) (define-privmsg-receiver-lookup irc:irc-notice-message)) @@ -136,7 +138,7 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (remove nil (mapcar (lambda (channel) - (find-receiver (irc:name channel) frame)) + (find-receiver (irc:name channel) (irc:connection message) frame)) (let ((user (irc:find-user (current-connection frame) (irc:source message)))) (when user @@ -160,7 +162,7 @@ (let ((target ,(if (numberp nth) `(nth ,nth (irc:arguments message)) `(first (last (irc:arguments message)))))) - (intern-receiver target frame :channel target)))))))) + (intern-receiver target (irc:connection message) frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message) (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message @@ -172,17 +174,17 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) (if (and - (null (find-receiver target frame)) + (null (find-receiver target (irc:connection message) frame)) (string= (irc:source message) (slot-value frame 'nick))) - (server-receiver frame) ; don't re-open previously closed channels. - (intern-receiver target frame :channel target)))) + (server-receiver frame (irc:connection message)) ; don't re-open previously closed channels. + (intern-receiver target (irc:connection message) frame :channel target)))) (defmethod receiver-for-message ((message irc:irc-mode-message) frame) (case (length (irc:arguments message)) - (1 (server-receiver frame)) + (1 (server-receiver frame (irc:connection message))) (t (destructuring-bind (channel modes &rest args) (irc:arguments message) (declare (ignore modes args)) - (intern-receiver channel frame :channel channel))))) + (intern-receiver channel (irc:connection message) frame :channel channel))))) (macrolet ((define-current-receiver-message-types (&rest mtypes) `(progn @@ -226,7 +228,7 @@ (defmethod receiver-for-message ((message irc:irc-message) frame) #+or ; comment out to debug on uncaught messages. (break) - (server-receiver frame)) + (server-receiver frame (irc:connection message))) ;; TODO: more receiver-for-message methods.

1 0

[beirc-cvs] CVS beirc
by afuchs 23 Feb '06

23 Feb '06

Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv21256 Modified Files: application.lisp Log Message: rework command reading. user input will no long be erased when invoking a presentation to command translator. (i.e. clicking on a URL will preserve the content of the input buffer). This works only for non-command reading, though. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/22 16:30:50 1.39 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/23 19:43:29 1.40 @@ -125,6 +125,8 @@ (defvar *beirc-frame*) +(defvar *last-input-line* nil) + (defun beirc-status-display (*application-frame* *standard-output*) (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) @@ -233,7 +235,8 @@ (clim-sys:make-process (lambda () (progv syms vals - (let* ((frame (make-application-frame 'beirc)) + (let* ((*last-input-line* nil) + (frame (make-application-frame 'beirc)) (ticker-process (clim-sys:make-process (lambda () (ticker frame)) :name "Beirc Ticker"))) (setf *beirc-frame* frame) @@ -751,25 +754,32 @@ (connection-process frame) nil (slot-value frame 'nick) nil)) + + (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) - (multiple-value-prog1 - (clim:with-input-editing (stream) - (let ((c (clim:read-gesture :stream stream :peek-p t))) - (cond ((eql c #\/) - (clim:read-gesture :stream stream) - (clim:accept 'clim:command :stream stream :prompt nil)) - (t - (list 'com-say (accept 'mumble :prompt nil :stream stream)))))) + (multiple-value-prog1 + (clim:with-input-editing (stream) + (when *last-input-line* + (replace-input stream *last-input-line* :rescan t)) + (with-input-context ('command) (object) + (let ((c (clim:read-gesture :stream stream :peek-p t))) + (multiple-value-prog1 + (cond ((eql c #\/) + (clim:read-gesture :stream stream) + (clim:accept 'clim:command :stream stream :prompt nil)) + (t + (list 'com-say (accept 'mumble :prompt nil :stream stream)))) + (setf *last-input-line* nil))) + (command + (let ((buffer (stream-input-buffer stream))) + (when (every 'characterp buffer) + (setf *last-input-line* + (with-output-to-string (s) + (loop for char across buffer + do (write-char char s)))))) + object))) (window-clear stream))) -(defmethod read-frame-command :around ((frame beirc) - &key (stream *standard-input*)) - (with-input-context ('command) (object) - (call-next-method) - (command - (window-clear stream) - object))) - (defun restart-beirc () (clim-sys:destroy-process *gui-process*) (setf *beirc-frame* nil)

1 0

[beirc-cvs] CVS beirc
by afuchs 22 Feb '06

22 Feb '06

Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv14752 Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: remove calls to deprecated function irc:trailing-argument and replace them (where useful) with the irc:destructuring-arguments binding form. also, fix the (change-space-requirements ) reader error that annoyed Paolo Amoroso. Sorry for that. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/16 23:46:57 1.38 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/22 16:30:50 1.39 @@ -244,9 +244,9 @@ (clim-sys:destroy-process ticker-process)))))))) (defun message-directed-to-me-p (frame message) - (let ((my-nick (slot-value frame 'nick)) - (text (or (irc:trailing-argument message) ""))) - (search my-nick text))) + (irc:destructuring-arguments (&last body) message + (let ((my-nick (slot-value frame 'nick))) + (search my-nick (or body ""))))) (defun interesting-message-p (message) (typep message '(or irc:irc-privmsg-message irc:irc-notice-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) @@ -411,8 +411,7 @@ (make-instance message-type :received-time (get-universal-time) :connection :local - :trailing-argument trailing-argument - :arguments arguments + :arguments `(,@arguments ,trailing-argument) :command command :HOST "localhost" :USER "localuser" @@ -788,15 +787,15 @@ nil) ;### put the server you initially connected to here. (defmethod trailing-argument* (message) - (irc:trailing-argument message)) + (car (last (irc:arguments message)))) (defmethod trailing-argument* ((message cl-irc:ctcp-action-message)) (or (ignore-errors ;### - (let ((p1 (position #\space (irc:trailing-argument message)))) - (subseq (irc:trailing-argument message) + (let ((p1 (position #\space (car (last (irc:arguments message)))))) + (subseq (car (last (irc:arguments message))) (1+ p1) - (1- (length (irc:trailing-argument message)))))) + (1- (length (car (last (irc:arguments message)))))))) "#Garbage parsing message#")) (defmethod process-message (*application-frame* (message cl-irc:ctcp-action-message)) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/16 23:46:57 1.31 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/22 16:30:50 1.32 @@ -1,5 +1,8 @@ (in-package :beirc) +(declaim (optimize (debug 2) (speed 0) + (space 0))) + (defvar *max-preamble-length* 0) (define-presentation-type url () @@ -29,6 +32,7 @@ (member (irc:source message) (focused-nicks receiver) :test #'string=)) (defun message-from-ignored-nick-p (message receiver) + (declare (ignore receiver)) (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) :test #'string=)) @@ -136,11 +140,12 @@ (with-text-face (*standard-output* (if (message-from-focused-nick-p message receiver) :bold :roman)) - (formatting-message (t message receiver) - ((write-string start-string *standard-output*) - (present (irc:source message) 'unhighlighted-nickname) - (write-string end-string *standard-output*)) - ((format-message* (irc:trailing-argument message)))))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((write-string start-string *standard-output*) + (present (irc:source message) 'unhighlighted-nickname) + (write-string end-string *standard-output*)) + ((format-message* body)))))))) (defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) (print-privmsg-like-message message receiver "<" ">")) @@ -149,13 +154,13 @@ (print-privmsg-like-message message receiver "-" "-")) (defmethod print-message ((message irc:ctcp-action-message) receiver) - (let ((source (cl-irc:source message)) - (matter (trailing-argument* message))) + (let ((source (cl-irc:source message))) (formatting-message (t message receiver) - ((format t "*")) - ((present source 'unhighlighted-nickname) - (format t " ") - (format-message* matter :start-length (+ 2 (length source))))))) + ((format t "*")) + ((present source 'unhighlighted-nickname) + (format t " ") + (format-message* (trailing-argument* message) + :start-length (+ 2 (length source))))))) (defmethod print-message ((message irc:ctcp-version-message) receiver) (let ((source (cl-irc:source message))) @@ -173,14 +178,13 @@ ,@(loop for (message-type . message-name) in message-specs collect `(defmethod print-message ((message ,message-type) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* - (format nil "~@[~A: ~]~{~A ~}~A" - ,message-name - (cdr (irc:arguments message)) - (irc:trailing-argument message))))))))))) + (irc:destructuring-arguments (_ &rest arguments &last body) message + (declare (ignore _)) + (formatting-message (t message receiver) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* + (format nil "~@[~A: ~]~{~A ~}~A" ,message-name (butlast arguments) body))))))))))) (define-server-message-printer ((irc:irc-rpl_motd-message . "MODT") (irc:irc-rpl_motdstart-message . "MOTD") (irc:irc-rpl_isupport-message) @@ -204,37 +208,25 @@ (irc:irc-rpl_noaway-message) (irc:irc-rpl_unaway-message)))) -(defmethod print-message ((message irc:irc-rpl_isupport-message) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "MOTD: ~A" (irc:trailing-argument message)))))) - -(defmethod print-message ((message irc:irc-rpl_motd-message) receiver) - (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "MOTD: ~A" (irc:trailing-argument message)))))) - (defmethod print-message (message receiver) - (formatting-message (t message receiver) - ((format t "!!! ~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "~A ~A :~A" (irc:command message) - (irc:arguments message) - (irc:trailing-argument message)))))) + (irc:destructuring-arguments (&whole args &last body) message + (formatting-message (t message receiver) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "~A ~A :~A" (irc:command message) (butlast args) body)))))) ;;; user-related messages (defmethod print-message ((message irc:irc-quit-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Quit: ") - (present (irc:source message) 'nickname) - (format t ": ") - (format-message* (irc:trailing-argument message) - :start-length (+ 8 (length (irc:source message)))))))) + (irc:destructuring-arguments (&optional body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Quit: ") + (present (irc:source message) 'nickname) + (unless (null body) + (format t ": ") + (format-message* body :start-length (+ 8 (length (irc:source message)))))))))) (defun present-as-hostmask (user host) (write-char #\() @@ -243,61 +235,66 @@ (write-char #\))) (defmethod print-message ((message irc:irc-nick-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Nick change: ") - (present (irc:source message) 'nickname) - (write-string " ") - (present-as-hostmask (irc:user message) (irc:host message)) - (write-string " is now known as ") - (present (irc:trailing-argument message) 'nickname))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Nick change: ") + (present (irc:source message) 'nickname) + (write-string " ") + (present-as-hostmask (irc:user message) (irc:host message)) + (write-string " is now known as ") + (present body 'nickname)))))) (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver) (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me nickname user host &rest args) (irc:arguments message) - (declare (ignore me args)) + (irc:destructuring-arguments (me nickname user host &last ircname) message + (declare (ignore me)) (present nickname 'nickname) (format t " is ") (present-as-hostmask user host) - (format t " (~A)" (irc:trailing-argument message))))))) + (format t " (~A)" ircname)))))) (defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is in ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname &last body) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is in ~A" body) :start-length (length nickname))))))) (defmethod print-message ((message irc:irc-rpl_whoisserver-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is on ~A: ~A" - (third (irc:arguments message)) - (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname server &last server-callout) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is on ~A: ~A" server server-callout) + :start-length (length nickname))))))) (defmethod print-message ((message irc:irc-rpl_away-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is away: ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname &last away-msg) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (format-message* (format nil " is away: ~A" away-msg) + :start-length (length (second (irc:arguments message))))))))) (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (write-char #\Space) - (format-message* (irc:trailing-argument message) - :start-length (length (second (irc:arguments message)))))))) + (irc:destructuring-arguments (me nickname body) message + (declare (ignore me)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present nickname 'nickname) + (write-char #\Space) + (format-message* body :start-length (length (second (irc:arguments message))))))))) ;;; channel management messages @@ -305,20 +302,22 @@ (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (let* ((target (second (irc:arguments message))) - (close-p (string= (title receiver) - (irc:normalize-nickname (current-connection *application-frame*) - target)))) - (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" - target close-p)) - (when close-p - (present `(com-close ,receiver) 'command))))))) + (irc:destructuring-arguments (me target &rest rest) message + (declare (ignore me rest)) + (let* ((close-p (string= (title receiver) + (irc:normalize-nickname (current-connection *application-frame*) + target)))) + (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" + target close-p)) + (when close-p + (present `(com-close ,receiver) 'command)))))))) (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message))))))) + (irc:destructuring-arguments (&last body) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (format-message* (format nil "Not permitted: ~A" body))))))) (defun print-topic (receiver message sender channel topic) (formatting-message (t message receiver) @@ -331,38 +330,41 @@ (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) (defmethod print-message ((message irc:irc-topic-message) receiver) - (print-topic receiver message (irc:source message) - (first (irc:arguments message)) (irc:trailing-argument message))) + (irc:destructuring-arguments (channel &last topic) message + (print-topic receiver message (irc:source message) channel topic))) (defmethod print-message ((message irc:irc-rpl_topic-message) receiver) - (print-topic receiver message nil - (second (irc:arguments message)) (irc:trailing-argument message))) + (irc:destructuring-arguments (channel &last topic) message + (print-topic receiver message nil channel topic))) (defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver) (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me channel who time) (irc:arguments message) + (irc:destructuring-arguments (me channel who time) message (declare (ignore me time ; TODO: no date display for now. )) (format-message* (format nil "~A topic set by ~A" channel who))))))) (defmethod print-message ((message irc:irc-rpl_namreply-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~A Names: ~A" (third (irc:arguments message)) - (irc:trailing-argument message))))))) + (irc:destructuring-arguments (me privacy channel &last nicks) message + (declare (ignore me privacy)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A Names: ~A" channel nicks))))))) (defmethod print-message ((message irc:irc-part-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Part: ") - (present (irc:source message) 'nickname) - (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) - (irc:trailing-argument message))))))) + (irc:destructuring-arguments (channel &optional part-msg) message + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Part: ") + (present (irc:source message) 'nickname) + (format t " left ~A" channel) + (unless (null part-msg) + (format-message* (format nil ": ~A" part-msg)))))))) (defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver) @@ -374,15 +376,17 @@ (present-as-hostmask (irc:user message) (irc:host message)))))) (defmethod print-message ((message irc:irc-kick-message) receiver) - (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (write-string " kicked ") - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil ": ~A" (irc:trailing-argument message)) - :start-length (+ 9 (length (second (irc:arguments message))) - (length (irc:source message)))))))) + (irc:destructuring-arguments (channel victim &optional kick-msg) message + (declare (ignore channel)) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " kicked ") + (present victim 'nickname) + (unless (null kick-msg) + (format-message* (format nil ": ~A" kick-msg) + :start-length (+ 9 (length victim) (length (irc:source message)))))))))) ;;; XXX: uses unexported symbols from cl-irc, but I think their ;;; unexportedness is accidental. @@ -422,12 +426,12 @@ (case (length (irc:arguments message)) (1 (formatting-message (t message receiver) ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~A set mode ~A ~A" (irc:source message) - (irc:trailing-argument message) - (first (irc:arguments message)))))))) + ((irc:destructuring-arguments (channel 1c-mode) message + (with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A set mode ~A ~A" (irc:source message) + channel 1c-mode))))))) (t - (destructuring-bind (target &rest args) (irc:arguments message) + (irc:destructuring-arguments (target &rest args) message (let* ((connection (current-connection *application-frame*)) (target (or (irc:find-user connection target) (irc:find-channel connection target))) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/16 23:46:57 1.15 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/22 16:30:50 1.16 @@ -55,7 +55,8 @@ (setf (slot-value receiver 'tab-pane) (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane)) (add-pane (tab-pane receiver) (find-pane-named frame 'query)) - ;; resize the pane to fit the tab container change-space-requirements pane))) + ;; resize the pane to fit the tab container + (change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) (defun find-receiver (name frame) @@ -146,7 +147,7 @@ (macrolet ((define-nth-arg-message-receiver-lookup (&rest clauses) "Defines receiver-for-message methods that return the receiver associated with the nth arg of the - irc message or the trailing arg if NTH in the + irc message or the last arg if NTH in the clauses is nil. Each clause must have this format: @@ -158,7 +159,7 @@ `(defmethod receiver-for-message ((message ,message-type) frame) (let ((target ,(if (numberp nth) `(nth ,nth (irc:arguments message)) - `(irc:trailing-argument message)))) + `(first (last (irc:arguments message)))))) (intern-receiver target frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message)

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Feb '06

16 Feb '06

Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv18918 Modified Files: application.lisp message-display.lisp receivers.lisp variables.lisp Log Message: query auto-closing; improve urls highlighting; resize new queries correctly. * Query auto-closing code: if *auto-close-inactive-query-windows-p* is set to T (nil is the default), beirc will automatically close windows that were inactive for more than *max-query-inactive-time* seconds (and all messages in the window were seen). * Highlight https:// urls; that should speak for itself (: * change the presentation of rewritten clhs URLs. instead of file://, we show clhs://; the link target is still the right one, of course. * add a change-space-requirements call that resizes new query panes to fit the size of the tab pane container. --- /project/beirc/cvsroot/beirc/application.lisp 2006/02/05 21:50:51 1.37 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/16 23:46:57 1.38 @@ -220,6 +220,8 @@ (defmethod handle-event ((frame beirc) (event bar-event)) (let ((pane (get-frame-pane frame 'status-bar))) (redisplay-frame-pane frame pane) + (when *auto-close-inactive-query-windows-p* + (com-close-inactive-queries)) (medium-force-output (sheet-medium pane)))) ;;; @@ -256,7 +258,8 @@ (when (interesting-message-p message) (incf (unseen-messages receiver))) (when (message-directed-to-me-p frame message) - (incf (messages-directed-to-me receiver)))) + (incf (messages-directed-to-me receiver))) + (incf (all-unseen-messages receiver))) (update-drawing-options receiver) (clim-internals::event-queue-prepend (climi::frame-event-queue frame) @@ -344,6 +347,22 @@ (irc:part connection channel))) (remove-receiver receiver *application-frame*)) +(define-beirc-command (com-close-inactive-queries :name t) () + (let ((receivers-to-close nil)) + (maphash (lambda (name receiver) + (declare (ignore name)) + (when (and (not (eql receiver (server-receiver *application-frame*))) + (not (eql receiver (current-receiver *application-frame*))) + (= 0 + (unseen-messages receiver) (all-unseen-messages receiver) + (messages-directed-to-me receiver)) + (null (irc:find-channel (current-connection *application-frame*) (title receiver))) + (> (- (get-universal-time) (last-visited receiver)) *max-query-inactive-time*)) + (push receiver receivers-to-close))) + (receivers *application-frame*)) + (loop for receiver in receivers-to-close + do (remove-receiver receiver *application-frame*)))) + (define-beirc-command (com-part :name t) () (irc:part (current-connection *application-frame*) (title (current-receiver *application-frame*)))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/10 20:48:23 1.30 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/16 23:46:57 1.31 @@ -6,13 +6,14 @@ :inherit-from 'string) (defun present-url (url) - (let ((start (search "http://www.lispworks.com/reference/HyperSpec/" url))) + (let* ((clhs-base "http://www.lispworks.com/reference/HyperSpec/") + (start (search clhs-base url))) (cond (start - (write-string (subseq url 0 start)) - (present (concatenate 'string - *hyperspec-base-url* - (subseq url (+ 45 start))) - 'url)) + (let* ((clhs-page (subseq url (+ start (length clhs-base)))) + (new-url (concatenate 'string *hyperspec-base-url* clhs-page))) + (write-string (subseq url 0 start)) + (with-output-as-presentation (t new-url 'url) + (format t "clhs://~A" clhs-page)))) ((> (length url) *default-fill-column*) (let ((new-url (concatenate 'string @@ -107,7 +108,7 @@ (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) (write-string stripped-preceding-punctuation) (cond - ((search "http://" word%) + ((or (search "http://" word%) (search "https://" word%)) (present-url word%)) ((or (nick-equals-my-nick-p word%) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/05 21:50:51 1.14 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/16 23:46:57 1.15 @@ -3,11 +3,13 @@ (defclass receiver () ((messages :accessor messages :initform nil) (unseen-messages :accessor unseen-messages :initform 0) + (all-unseen-messages :accessor all-unseen-messages :initform 0) (messages-directed-to-me :accessor messages-directed-to-me :initform 0) (channel :reader channel :initform nil :initarg :channel) (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. (focused-nicks :accessor focused-nicks :initform nil) (title :reader title :initarg :title) + (last-visited :accessor last-visited :initform 0) (pane :reader pane) (tab-pane :accessor tab-pane))) @@ -52,7 +54,8 @@ (progn (setf (slot-value receiver 'tab-pane) (make-tab-pane-from-list (title receiver) (pane receiver) 'receiver-pane)) - (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) + (add-pane (tab-pane receiver) (find-pane-named frame 'query)) + ;; resize the pane to fit the tab container change-space-requirements pane))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) (defun find-receiver (name frame) @@ -74,7 +77,7 @@ (lambda (frame pane) (beirc-app-display frame pane receiver)) :display-time nil - :width 600 :height 800 + :min-width 600 :min-height 800 :incremental-redisplay t))) (setf (gethash normalized-name (receivers frame)) receiver) receiver))))) @@ -255,10 +258,14 @@ (find-in-tab-panes-list pane my-tab-layout-pane)))) (unless (null receiver) (setf (unseen-messages receiver) 0) + (setf (all-unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) + (setf (last-visited receiver) (get-universal-time)) (update-drawing-options receiver)))))) (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) + (setf (all-unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) + (setf (last-visited receiver) (get-universal-time)) (switch-to-pane (pane receiver) 'tab-layout-pane)) --- /project/beirc/cvsroot/beirc/variables.lisp 2005/10/02 23:47:51 1.8 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/02/16 23:46:57 1.9 @@ -19,4 +19,17 @@ (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") - (user-homedir-pathname))) \ No newline at end of file + (user-homedir-pathname))) + +(defvar *auto-close-inactive-query-windows-p* nil + "Indicates whether beirc automatically closes query windows +that were inactive for longer than *max-query-inactive-time* +seconds. If set to NIL, beirc doesn't automaticaly close query +windows. Closing inactive query windows is still available via +/Close Inactive Queries.") + +(defvar *max-query-inactive-time* 600 + "Longest time an inactive query window will be kept around by +the command /Close Inactive Queries and the automatic query +window closing mechanism (see +*auto-close-inactive-query-windows-p*).") \ No newline at end of file

1 0

[beirc-cvs] CVS beirc
by afuchs 10 Feb '06

10 Feb '06

Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv14444 Modified Files: message-display.lisp Log Message: add a printer for the :key channel mode (+k) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/06 21:21:02 1.29 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/10 20:48:23 1.30 @@ -400,6 +400,12 @@ (write-char #\:) (present arg 'number))) +(defmethod print-mode-change (target op (mode (eql :key)) arg) + (format t "~A~A" op (mode-symbol-to-char target mode)) + (when (not (null arg)) + (write-char #\:) + (present arg 'string))) + (macrolet ((define-mode-change-with-hostmask-printer (&rest modes) `(progn ,@(loop for mode in modes

1 0

[beirc-cvs] CVS beirc
by afuchs 06 Feb '06

06 Feb '06

Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv6629 Modified Files: message-display.lisp Log Message: fix indentation of formatting-message --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/05 21:50:51 1.28 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/06 21:21:02 1.29 @@ -74,6 +74,8 @@ (lambda () ,@message-body-column-body))) +;;; for optimal indentation, use (put 'formatting-message 'common-lisp-indent-function 1) + (defun strip-punctuation (word) (if (= (length word) 0) (values word "") @@ -134,10 +136,10 @@ (*standard-output* (if (message-from-focused-nick-p message receiver) :bold :roman)) (formatting-message (t message receiver) - ((write-string start-string *standard-output*) - (present (irc:source message) 'unhighlighted-nickname) - (write-string end-string *standard-output*)) - ((format-message* (irc:trailing-argument message)))))))) + ((write-string start-string *standard-output*) + (present (irc:source message) 'unhighlighted-nickname) + (write-string end-string *standard-output*)) + ((format-message* (irc:trailing-argument message)))))))) (defmethod print-message ((message irc:IRC-PRIVMSG-MESSAGE) receiver) (print-privmsg-like-message message receiver "<" ">")) @@ -149,19 +151,19 @@ (let ((source (cl-irc:source message)) (matter (trailing-argument* message))) (formatting-message (t message receiver) - ((format t "*")) - ((present source 'unhighlighted-nickname) - (format t " ") - (format-message* matter :start-length (+ 2 (length source))))))) + ((format t "*")) + ((present source 'unhighlighted-nickname) + (format t " ") + (format-message* matter :start-length (+ 2 (length source))))))) (defmethod print-message ((message irc:ctcp-version-message) receiver) (let ((source (cl-irc:source message))) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present source 'unhighlighted-nickname) - (format t " ") - (format-message* "asked for your IRC client version" :start-length (+ 2 (length source)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present source 'unhighlighted-nickname) + (format t " ") + (format-message* "asked for your IRC client version" :start-length (+ 2 (length source)))))))) ;;; server messages @@ -171,13 +173,13 @@ collect `(defmethod print-message ((message ,message-type) receiver) (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* - (format nil "~@[~A: ~]~{~A ~}~A" - ,message-name - (cdr (irc:arguments message)) - (irc:trailing-argument message))))))))))) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* + (format nil "~@[~A: ~]~{~A ~}~A" + ,message-name + (cdr (irc:arguments message)) + (irc:trailing-argument message))))))))))) (define-server-message-printer ((irc:irc-rpl_motd-message . "MODT") (irc:irc-rpl_motdstart-message . "MOTD") (irc:irc-rpl_isupport-message) @@ -203,35 +205,35 @@ (defmethod print-message ((message irc:irc-rpl_isupport-message) receiver) (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "MOTD: ~A" (irc:trailing-argument message)))))) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "MOTD: ~A" (irc:trailing-argument message)))))) (defmethod print-message ((message irc:irc-rpl_motd-message) receiver) (formatting-message (t message receiver) - ((format t "~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "MOTD: ~A" (irc:trailing-argument message)))))) + ((format t "~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "MOTD: ~A" (irc:trailing-argument message)))))) (defmethod print-message (message receiver) (formatting-message (t message receiver) - ((format t "!!! ~A" (irc:source message))) - ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "~A ~A :~A" (irc:command message) - (irc:arguments message) - (irc:trailing-argument message)))))) + ((format t "!!! ~A" (irc:source message))) + ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) + (format t "~A ~A :~A" (irc:command message) + (irc:arguments message) + (irc:trailing-argument message)))))) ;;; user-related messages (defmethod print-message ((message irc:irc-quit-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Quit: ") - (present (irc:source message) 'nickname) - (format t ": ") - (format-message* (irc:trailing-argument message) - :start-length (+ 8 (length (irc:source message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Quit: ") + (present (irc:source message) 'nickname) + (format t ": ") + (format-message* (irc:trailing-argument message) + :start-length (+ 8 (length (irc:source message)))))))) (defun present-as-hostmask (user host) (write-char #\() @@ -241,91 +243,91 @@ (defmethod print-message ((message irc:irc-nick-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Nick change: ") - (present (irc:source message) 'nickname) - (write-string " ") - (present-as-hostmask (irc:user message) (irc:host message)) - (write-string " is now known as ") - (present (irc:trailing-argument message) 'nickname))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Nick change: ") + (present (irc:source message) 'nickname) + (write-string " ") + (present-as-hostmask (irc:user message) (irc:host message)) + (write-string " is now known as ") + (present (irc:trailing-argument message) 'nickname))))) (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me nickname user host &rest args) (irc:arguments message) - (declare (ignore me args)) - (present nickname 'nickname) - (format t " is ") - (present-as-hostmask user host) - (format t " (~A)" (irc:trailing-argument message))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (destructuring-bind (me nickname user host &rest args) (irc:arguments message) + (declare (ignore me args)) + (present nickname 'nickname) + (format t " is ") + (present-as-hostmask user host) + (format t " (~A)" (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is in ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil " is in ~A" (irc:trailing-argument message)) + :start-length (length (second (irc:arguments message)))))))) (defmethod print-message ((message irc:irc-rpl_whoisserver-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is on ~A: ~A" - (third (irc:arguments message)) - (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil " is on ~A: ~A" + (third (irc:arguments message)) + (irc:trailing-argument message)) + :start-length (length (second (irc:arguments message)))))))) (defmethod print-message ((message irc:irc-rpl_away-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil " is away: ~A" (irc:trailing-argument message)) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil " is away: ~A" (irc:trailing-argument message)) + :start-length (length (second (irc:arguments message)))))))) (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (second (irc:arguments message)) 'nickname) - (write-char #\Space) - (format-message* (irc:trailing-argument message) - :start-length (length (second (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (second (irc:arguments message)) 'nickname) + (write-char #\Space) + (format-message* (irc:trailing-argument message) + :start-length (length (second (irc:arguments message)))))))) ;;; channel management messages (defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (let* ((target (second (irc:arguments message))) - (close-p (string= (title receiver) - (irc:normalize-nickname (current-connection *application-frame*) - target)))) - (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" - target close-p)) - (when close-p - (present `(com-close ,receiver) 'command))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (let* ((target (second (irc:arguments message))) + (close-p (string= (title receiver) + (irc:normalize-nickname (current-connection *application-frame*) + target)))) + (format-message* (format nil "No such nick or channel \"~A\". ~@[To close this tab, click ~]" + target close-p)) + (when close-p + (present `(com-close ,receiver) 'command))))))) (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) - (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (format-message* (format nil "Not permitted: ~A" (irc:trailing-argument message))))))) (defun print-topic (receiver message sender channel topic) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (if (null sender) - (format-message* (format nil "Topic for ~A: ~A" channel topic)) - (progn - (present sender 'nickname) - (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (if (null sender) + (format-message* (format nil "Topic for ~A: ~A" channel topic)) + (progn + (present sender 'nickname) + (format-message* (format nil " set the topic for ~A to ~A" channel topic)))))))) (defmethod print-message ((message irc:irc-topic-message) receiver) (print-topic receiver message (irc:source message) @@ -337,49 +339,49 @@ (defmethod print-message ((message irc:irc-rpl_topicwhotime-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (destructuring-bind (me channel who time) (irc:arguments message) - (declare (ignore me - time ; TODO: no date display for now. - )) - (format-message* (format nil "~A topic set by ~A" channel who))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (destructuring-bind (me channel who time) (irc:arguments message) + (declare (ignore me + time ; TODO: no date display for now. + )) + (format-message* (format nil "~A topic set by ~A" channel who))))))) (defmethod print-message ((message irc:irc-rpl_namreply-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~A Names: ~A" (third (irc:arguments message)) - (irc:trailing-argument message))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A Names: ~A" (third (irc:arguments message)) + (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-part-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Part: ") - (present (irc:source message) 'nickname) - (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) - (irc:trailing-argument message))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Part: ") + (present (irc:source message) 'nickname) + (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) + (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format t "Join: ") - (present (irc:source message) 'nickname) - (write-char #\Space) - (present-as-hostmask (irc:user message) (irc:host message)))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format t "Join: ") + (present (irc:source message) 'nickname) + (write-char #\Space) + (present-as-hostmask (irc:user message) (irc:host message)))))) (defmethod print-message ((message irc:irc-kick-message) receiver) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (write-string " kicked ") - (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil ": ~A" (irc:trailing-argument message)) - :start-length (+ 9 (length (second (irc:arguments message))) - (length (irc:source message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " kicked ") + (present (second (irc:arguments message)) 'nickname) + (format-message* (format nil ": ~A" (irc:trailing-argument message)) + :start-length (+ 9 (length (second (irc:arguments message))) + (length (irc:source message)))))))) ;;; XXX: uses unexported symbols from cl-irc, but I think their ;;; unexportedness is accidental. @@ -412,11 +414,11 @@ (defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) (1 (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~A set mode ~A ~A" (irc:source message) - (irc:trailing-argument message) - (first (irc:arguments message)))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A set mode ~A ~A" (irc:source message) + (irc:trailing-argument message) + (first (irc:arguments message)))))))) (t (destructuring-bind (target &rest args) (irc:arguments message) (let* ((connection (current-connection *application-frame*)) @@ -425,15 +427,15 @@ (mode-changes (irc:parse-mode-arguments connection target args :server-p (irc:user connection)))) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (write-string " changes channel mode: ") - (loop for (change . rest) on mode-changes - do (destructuring-bind (op mode &optional arg) change - (print-mode-change target op mode arg)) - if (not (null rest)) - do (write-string ", ")))))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " changes channel mode: ") + (loop for (change . rest) on mode-changes + do (destructuring-bind (op mode &optional arg) change + (print-mode-change target op mode arg)) + if (not (null rest)) [27 lines skipped]

1 0

[beirc-cvs] CVS beirc
by afuchs 05 Feb '06

05 Feb '06

Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv18126 Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: Add ban/invite/exceptlist display functionality. --- /project/beirc/cvsroot/beirc/application.lisp 2006/01/30 18:56:00 1.36 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/02/05 21:50:51 1.37 @@ -247,7 +247,7 @@ (search my-nick text))) (defun interesting-message-p (message) - (typep message '(or irc:irc-privmsg-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) + (typep message '(or irc:irc-privmsg-message irc:irc-notice-message irc:irc-topic-message irc:irc-kick-message irc:ctcp-action-message))) (defun post-message-to-receiver (frame message receiver) (setf (messages receiver) @@ -418,6 +418,9 @@ (define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who")) (irc:deop (current-connection *application-frame*) (target) who)) +(define-beirc-command (com-show-ban-list :name t) () + (irc:ban (current-connection *application-frame*) (target) "")) + (define-beirc-command (com-ban-nick :name t) ((who 'nickname :prompt "who")) (irc:ban (current-connection *application-frame*) (target) (format nil "~A!*@*" who))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/01/27 22:39:09 1.27 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/02/05 21:50:51 1.28 @@ -435,6 +435,25 @@ if (not (null rest)) do (write-string ", ")))))))))) +(macrolet ((define-*list-printer (&rest message-types) + `(progn + ,@(loop for (message-type prefix) in message-types + collect + `(defmethod print-message ((message ,message-type) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (write-string ,prefix) + (present (nth 2 (irc:arguments message)) 'hostmask) + (when (find #\! (nth 3 (irc:arguments message))) + (write-string " by ") + (present (first (split-sequence:split-sequence #\! (nth 3 (irc:arguments message)))) + 'nickname)))))))))) + (define-*list-printer + (irc:irc-rpl_banlist-message "BANNED: ") + (irc:irc-rpl_invitelist-message "INVITED: ") + (irc:irc-rpl_exceptlist-message "UNBANNED: "))) + ;;; the display function (& utilities) (defgeneric preamble-length (message) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/01/27 22:40:32 1.13 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/02/05 21:50:51 1.14 @@ -159,7 +159,9 @@ (intern-receiver target frame :channel target)))))))) (define-nth-arg-message-receiver-lookup (0 irc:irc-topic-message irc:irc-kick-message) - (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message irc:irc-err_chanoprivsneeded-message) + (1 irc:irc-rpl_topic-message irc:irc-rpl_topicwhotime-message + irc:irc-err_chanoprivsneeded-message irc:irc-rpl_banlist-message + irc:irc-rpl_invitelist-message irc:irc-rpl_exceptlist-message) (2 irc:irc-rpl_namreply-message) (nil irc:irc-join-message)))

1 0