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

[beirc-cvs] CVS update: beirc/application.lisp beirc/beirc.asd beirc/presentations.lisp
by afuchs＠common-lisp.net 25 Sep '05

25 Sep '05

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 ,@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))

1 0

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

25 Sep '05

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)

1 0

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

25 Sep '05

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

1 0

[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
by afuchs＠common-lisp.net 25 Sep '05

25 Sep '05

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 ()

1 0

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

25 Sep '05

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

1 0

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

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-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+) - ,@preamble-column-body)) - (formatting-cell (,stream* :align-x :left - :min-width '(80 :character)) - ,@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 () + ,@preamble-column-body) + (lambda () + ,@message-body-column-body))) (defun strip-punctuation (word) (if (= (length word) 0)

1 0

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

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-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)

1 0

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

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-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

1 0

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

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-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))

1 0

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

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-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))))))))

1 0