March 2006 - beirc-cvs@common-lisp.net - mailman3.common-lisp.net

[beirc-cvs] CVS beirc
by afuchs 27 Mar '06

27 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv11414 Modified Files: message-display.lisp Log Message: use medium-ink instead of medium-foreground to find the ink color. --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:42:41 1.42 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:46:31 1.43 @@ -248,7 +248,7 @@ record)))) (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) - (let ((foreground-color (medium-foreground *standard-output*)) + (let ((foreground-color (medium-ink *standard-output*)) (background-color (medium-background *standard-output*)) (bold nil) (underline nil)

1 0

[beirc-cvs] CVS beirc
by afuchs 27 Mar '06

27 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv9934 Modified Files: beirc.asd message-display.lisp variables.lisp Log Message: Add Thomas Persson's color code interpretation patch. Also, add *filter-colors* --- /project/beirc/cvsroot/beirc/beirc.asd 2006/03/24 21:19:43 1.8 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/03/27 21:42:41 1.9 @@ -6,7 +6,7 @@ (cl:in-package :beirc.system) (defsystem :beirc - :depends-on (:mcclim :cl-irc :split-sequence :tab-layout) + :depends-on (:mcclim :cl-irc :split-sequence :tab-layout :cl-ppcre) :components ((:file "package") (:file "variables" :depends-on ("package")) (:file "events" :depends-on ("package")) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 13:46:47 1.41 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:42:41 1.42 @@ -7,6 +7,29 @@ (defvar *current-message*) +(defparameter *colors* `((0 . (:ink ,+white+)) + (1 . (:ink ,+black+)) + (2 . (:ink ,+blue+)) + (3 . (:ink ,+green+)) + (4 . (:ink ,+red+)) + (5 . (:ink ,+brown+)) + (6 . (:ink ,+purple+)) + (7 . (:ink ,+orange+)) + (8 . (:ink ,+yellow+)) + (9 . (:ink ,+light-green+)) + (10 . (:ink ,+dark-cyan+)) + (11 . (:ink ,+cyan+)) + (12 . (:ink ,+royal-blue+)) + (13 . (:ink ,+pink+)) + (14 . (:ink ,+grey+)) + (15 . (:ink ,+light-grey+)) + ("" . (normal)) + ("" . (underline)) + ("" . (inverse)) + ("" . (bold)))) + +(defparameter *color-scanner* (cl-ppcre:create-scanner "[0-9]{1,2}(,[0-9]{1,2}){0,1}||||")) + (define-presentation-type url () :inherit-from 'string) @@ -124,32 +147,138 @@ (string first-char))) (otherwise (values word "")))))) +(defun extract-color (string) + (multiple-value-bind (start end) + (cl-ppcre:scan *color-scanner* + string) + (if start + (let* ((message (subseq string end)) + (color-code (subseq string start end)) + (color-code (or (cl-ppcre:all-matches-as-strings "[0-9]{1,2}" + color-code) + (list (cl-ppcre:scan-to-strings "|||" + color-code)))) + (foreground (or (parse-integer (car color-code) + :junk-allowed t) + (car color-code))) + (background (when (cadr color-code) + (parse-integer (cadr color-code) + :junk-allowed t))) + (foreground (cdr (assoc foreground + *colors* + :test #'equal))) + (background (cdr (assoc background + *colors* + :test #'equal)))) + (values message + foreground + background + )) + string))) + +(defun split-before (delimiter string) + (let ((matches (cl-ppcre:all-matches delimiter string))) + (if matches + (loop for (a b c) on matches by #'cddr + collecting (subseq string a c) into strings + finally (return (if (zerop (car matches)) + strings + (cons (subseq string + 0 + (car matches)) + strings)))) + (list string)))) + +(defmacro do-colored-string ((string-var str) &body body) + `(dolist (part (split-before *color-scanner* ,str)) + (multiple-value-bind (message foreground background) + (extract-color part) + (cond (*filter-colors* nil) + ((equal (car foreground) + 'normal) + (setf foreground-color +black+ + background-color +white+)) + ((equal (car foreground) + :ink) + (setf foreground-color + (cadr foreground)) + (when background + (setf background-color (cadr background)))) + ((equal (car foreground) + 'bold) + (setf bold (if bold nil :bold))) + ((equal (car foreground) + 'underline) + (setf underline (not underline))) + ((equal (car foreground) + 'inverse) + (setf inverse (not inverse)))) + (with-drawing-options (t :text-face bold) + (let ((,string-var message)) + (if inverse + (with-irc-colors (background-color foreground-color underline) + ,@body) + (with-irc-colors (foreground-color background-color underline) + ,@body))))))) + +(defmacro with-irc-colors ((foreground background underlinep) &body body) + `(with-sheet-medium (medium *standard-output*) + (let ((record (with-new-output-record (t) + (with-drawing-options (t :ink ,foreground) + ,@body)))) + (with-bounding-rectangle* (left top right bottom) + record + (unless (equal left right) + (unless (equal ,background +white+) + (with-identity-transformation (medium) + (draw-rectangle* *standard-output* + left + top + right + bottom + :filled t + :ink ,background) + (replay-output-record record *standard-output*) + (setf (stream-cursor-position *standard-output*) + (values right top)))) + (when ,underlinep + (draw-line* *standard-output* left (- bottom 1) + (- right 1) (- bottom 1) + :ink ,foreground))) + record)))) + (defun format-message* (mumble &key (limit *default-fill-column*) (start-length 0)) - (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) - with column = start-length - do (incf column (length word)) - when (> column limit) - do (setf column (length word)) - (terpri) - do (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word) - (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) - (write-string stripped-preceding-punctuation) - (cond - ((or (search "http://" word%) (search "https://" word%)) - (present-url word%)) - ((or - (nick-equals-my-nick-p word% (irc:connection *current-message*)) - (and (current-connection *application-frame*) - (irc:find-user (current-connection *application-frame*) word%))) - (present word% 'nickname)) - ((channelp word%) (present word% 'channel)) - (t (write-string word%))) - (write-string stripped-punctuation))) - ;; TODO: more highlighting - unless (or (null rest) (>= column limit)) - do (write-char #\Space) - (incf column)) - (terpri)) + (let ((foreground-color (medium-foreground *standard-output*)) + (background-color (medium-background *standard-output*)) + (bold nil) + (underline nil) + (inverse nil)) + (let ((column start-length)) + (loop for (word . rest) on (split-sequence:split-sequence #\Space mumble) + do (do-colored-string (word word) + (incf column (length word)) + (when (> column limit) + (setf column (length word)) + (terpri)) + (multiple-value-bind (%word stripped-preceding-punctuation) (strip-preceding-punctuation word) + (multiple-value-bind (word% stripped-punctuation) (strip-punctuation %word) + (write-string stripped-preceding-punctuation) + (cond + ((or (search "http://" word%) (search "https://" word%)) + (present-url word%)) + ((or + (nick-equals-my-nick-p word% (irc:connection *current-message*)) + (and (current-connection *application-frame*) + (irc:find-user (current-connection *application-frame*) word%))) + (present word% 'nickname)) + ((channelp word%) (present word% 'channel)) + (t (write-string word%))) + (write-string stripped-punctuation)))) + do (unless (or (null rest) (>= column limit)) + (do-colored-string (s " ") + (write-string s) + (incf column)))) + (terpri)))) ;;; privmsg-like messages --- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 13:46:47 1.13 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 21:42:41 1.14 @@ -49,4 +49,8 @@ *auto-close-inactive-query-windows-p*).") (defvar *meme-log-bot-nick* "cmeme" - "The name of the meme channel log bot") \ No newline at end of file + "The name of the meme channel log bot") + +(defvar *filter-colors* nil + "If set to non-NIL, filter color, bold, inverse and underline +codes from IRC messages.") \ No newline at end of file

1 0

[beirc-cvs] CVS beirc
by afuchs 27 Mar '06

27 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv9898 Modified Files: application.lisp Log Message: Add an option to defun beirc to not start a new process. Required if you want to start beirc in a toplevel function --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 13:46:47 1.70 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 21:38:43 1.71 @@ -295,23 +295,27 @@ ;;; -(defun beirc () +(defun beirc (&key (new-process t)) (let* ((syms '(*package* *trace-output*)) - (vals (mapcar #'symbol-value syms))) - (setf *gui-process* - (clim-sys:make-process - (lambda () - (progv syms vals - (let* ((frame (make-application-frame 'beirc)) - (ticker-process (clim-sys:make-process (lambda () (ticker frame)) - :name "Beirc Ticker"))) - (setf *beirc-frame* frame) - (load-user-init-file) - (run-frame-top-level frame) - (clim-sys:destroy-process ticker-process) - (disconnect-all frame "Client Quit")))) - ;; added process name for easier debug... - :name "BEIRC GUI process")))) + (vals (mapcar #'symbol-value syms)) + (program (lambda () + (progv syms vals + (let* ((frame (make-application-frame 'beirc)) + (ticker-process (clim-sys:make-process (lambda () (ticker frame)) + :name "Beirc Ticker"))) + (setf *beirc-frame* frame) + (load-user-init-file) + (run-frame-top-level frame) + (clim-sys:destroy-process ticker-process) + (disconnect-all frame "Client Quit")))))) + (cond + (new-process + (setf *gui-process* + (clim-sys:make-process program + ;; added process name for easier debug... + :name "BEIRC GUI process"))) + (t (setf *gui-process* (clim-sys:current-process)) + (funcall program))))) (defun message-directed-to-me-p (message)

1 0

[beirc-cvs] CVS beirc
by afuchs 27 Mar '06

27 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv15257 Modified Files: application.lisp message-display.lisp message-processing.lisp variables.lisp Log Message: Fix ignore. Make timestamps mouse-sensitive. Fix updating-output. * Ignore and unignore would remove the messages, but not set the scroll state. Make them use the new with-pane-kept-scrolled-to-bottom macro. * Timestamps are now pointers to meme.b9.com on channels that have a user "cmeme" on them. The nickname of the log bot is configurable via *meme-log-bot-nick*. * Updating-output's new SXHASH function would ignore the non-booleans on the list. Ugh. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/24 21:19:43 1.69 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 13:46:47 1.70 @@ -254,21 +254,35 @@ (defmethod handle-event ((frame beirc) (event new-sheet-event)) (funcall (sheet-creation-closure event) frame)) +(defmacro with-pane-kept-scrolled-to-bottom ((pane-form) &body body) + "Ensure that the pane in PANE-FORM has the same scroll state +after BODY terminates as it had before: + +If the pane is scrolled to some position before the end, it is +kept there. If the pane is at the bottom of the pane, the +viewport is reset to the then-current bottom after BODY is +finished." + (let ((pane (gensym)) + (bottom-p (gensym))) + `(let* ((,pane ,pane-form) + (,bottom-p (pane-scrolled-to-bottom-p ,pane))) + (multiple-value-prog1 (progn ,@body) + (when ,bottom-p (scroll-pane-to-bottom ,pane)))))) + (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: ;; Figure out if we are scrolled to the bottom. (let* ((receiver (receiver event)) (pane (actual-application-pane (pane receiver))) (next-event (event-peek (frame-top-level-sheet frame)))) - (let ((btmp (pane-scrolled-to-bottom-p pane))) + (with-pane-kept-scrolled-to-bottom (pane) (update-drawing-options receiver) ;; delay redisplay until this is the last event in the queue ;; (for this event's receiver). (unless (and (typep next-event 'foo-event) (eql (receiver next-event) receiver)) (setf (pane-needs-redisplay pane) t) - (redisplay-frame-panes frame)) - (when btmp (scroll-pane-to-bottom pane))) + (redisplay-frame-panes frame))) (medium-force-output (sheet-medium pane)) ;### )) @@ -496,13 +510,17 @@ (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=) - (redraw-all-receivers)) + (with-pane-kept-scrolled-to-bottom ((actual-application-pane + (pane (current-receiver *application-frame*)))) + (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=)) - (redraw-all-receivers)) + (with-pane-kept-scrolled-to-bottom ((actual-application-pane + (pane (current-receiver *application-frame*)))) + (setf (slot-value *application-frame* 'ignored-nicks) + (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) @@ -950,7 +968,7 @@ x y) (declare (ignore object options)) (when (and ptype (presentation-subtypep ptype 'command) - (boundp '*current-input-stream*) *current-input-stream*) + (boundp 'climi::*current-input-stream*) climi::*current-input-stream*) (restart-case (signal 'invoked-command-by-clicking) (acknowledged ())))))))) (call-next-method)) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/24 21:07:20 1.40 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 13:46:47 1.41 @@ -38,28 +38,48 @@ (member (irc:source message) (slot-value *application-frame* 'ignored-nicks) :test #'string=)) +(defun +boolean (initial-value &rest booleans) + (loop for value = initial-value then (+ (ash value 1) + (if boolean 1 0)) + for boolean in booleans + finally (return value))) + (defun invoke-formatting-message (stream message receiver preamble-writer message-body-writer) (let* ((*current-message* message) (stream* (if (eql stream t) *standard-output* stream)) (width (- (floor (bounding-rectangle-width (sheet-parent stream*)) (clim:stream-string-width stream* "X")) 2))) - (labels ((output-timestamp-column (position) + (labels ((make-meme-url (message) + (format nil "http://meme.b9.com/cview.html?channel=~A&utime=~A#utime_requested" + (string-trim '(#\#) (channel receiver)) + (irc:received-time message))) + (format-timestamp (message) + (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))))) + (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))))))))) + (if (and *meme-log-bot-nick* + (irc:find-user (connection receiver) *meme-log-bot-nick*) + (member (title receiver) + (irc:channels (irc:find-user (connection receiver) *meme-log-bot-nick*)) + :test #'equal + :key #'irc:name)) + (with-output-as-presentation (stream* (make-meme-url message) 'url) + (format-timestamp message)) + (format-timestamp message))))))) (updating-output (stream* :cache-value - (sxhash (list message - (message-from-focused-nick-p message receiver) - (message-from-ignored-nick-p message receiver) - width - *max-preamble-length* - *timestamp-column-orientation* - *default-fill-column*)) + (+boolean (sxhash (list message + width + *max-preamble-length* + *default-fill-column*)) + (message-from-focused-nick-p message receiver) + (message-from-ignored-nick-p message receiver) + (eql *timestamp-column-orientation* :left)) :cache-test #'eql) (formatting-row (stream*) (output-timestamp-column :left) --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/16 20:32:05 1.5 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/27 13:46:47 1.6 @@ -69,8 +69,13 @@ (typep message 'irc:irc-rpl_noaway-message))) (define-beirc-hook autojoin-hoook ((message cl-irc:irc-rpl_welcome-message)) - "When you establish a connection, check the list of channels for autojoin + "When a connection is established, check the list of channels for autojoin and set them up accordingly." (declare (ignore message)) (join-missing-channels *application-frame*)) +(define-beirc-hook meme-whois-hook ((message irc:irc-rpl_welcome-message)) + "When a connection is established, look up the channels on +which the meme log bot is listening." + (when (not (null *meme-log-bot-nick*)) + (irc:whois (irc:connection message) *meme-log-bot-nick*))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/24 21:19:44 1.12 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 13:46:47 1.13 @@ -47,3 +47,6 @@ the command /Close Inactive Queries and the automatic query window closing mechanism (see *auto-close-inactive-query-windows-p*).") + +(defvar *meme-log-bot-nick* "cmeme" + "The name of the meme channel log bot") \ No newline at end of file

1 0

[beirc-cvs] CVS beirc
by rgoldman 24 Mar '06

24 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv15877 Modified Files: application.lisp beirc.asd variables.lisp Added Files: post-message-hooks.lisp Log Message: Added support for making noise on certain messages. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:50:21 1.68 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/24 21:19:43 1.69 @@ -309,25 +309,29 @@ (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) - (append (messages receiver) (list message))) - (unless (eql receiver (current-receiver frame)) - (when (interesting-message-p message) - (incf (unseen-messages receiver))) - (when (message-directed-to-me-p message) - (incf (messages-directed-to-me receiver))) - (incf (all-unseen-messages receiver))) - (when (and (slot-boundp receiver 'pane) (pane receiver)) - (let* ((pane (actual-application-pane (pane receiver))) - (current-insert-position (bounding-rectangle-height pane))) - (when (and (not (eql current-insert-position - (first (positions-mentioning-user receiver)))) - (message-directed-to-me-p message)) - (push current-insert-position - (positions-mentioning-user receiver))))) - (queue-event (frame-top-level-sheet frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) - nil) + (let ((message-to-me-p (message-directed-to-me-p message)) + (interesting-message-p (interesting-message-p message))) + (setf (messages receiver) + (append (messages receiver) (list message))) + (unless (eql receiver (current-receiver frame)) + (when interesting-message-p + (incf (unseen-messages receiver))) + (when message-to-me-p + (incf (messages-directed-to-me receiver))) + (incf (all-unseen-messages receiver))) + (when (and (slot-boundp receiver 'pane) (pane receiver)) + (let* ((pane (actual-application-pane (pane receiver))) + (current-insert-position (bounding-rectangle-height pane))) + (when (and (not (eql current-insert-position + (first (positions-mentioning-user receiver)))) + message-to-me-p) + (push current-insert-position + (positions-mentioning-user receiver))))) + (run-post-message-hooks message frame receiver :message-directed-to-me message-to-me-p + :message-interesting-p interesting-message-p) + (queue-event (frame-top-level-sheet frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil)) (defun post-message (frame message) (let ((receiver (receiver-for-message message frame))) --- /project/beirc/cvsroot/beirc/beirc.asd 2006/03/12 09:48:57 1.7 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/03/24 21:19:43 1.8 @@ -14,4 +14,6 @@ (:file "presentations" :depends-on ("package" "variables" "receivers")) (:file "message-display" :depends-on ("package" "variables" "presentations")) (:file "application" :depends-on ("package" "variables" "presentations" "events" "receivers")) - (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")))) \ No newline at end of file + (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")) + (:file "post-message-hooks" :depends-on ("package")) + )) \ No newline at end of file --- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/21 15:22:03 1.11 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/03/24 21:19:44 1.12 @@ -6,7 +6,15 @@ (defvar *default-nick* (format nil "Brucio-~d" (random 100))) (defvar *default-web-browser* #+darwin "/usr/bin/open" ;; assuming a debian system running X: - #+linux "/usr/bin/x-www-browser") + #+linux "/usr/bin/x-www-browser") +(defvar *default-sound-player* + (or nil + #+linux "/usr/bin/ogg123") + "An external program that can be used to produce sounds.") +(defvar *sound-for-my-nick* nil + "If the NOISEMAKER post-message-hook is enabled, and there +is a *default-sound-player* defined, this noise will be +played when your nick is mentioned.") (defvar *auto-join-alist* '(("irc.freenode.net" . ("#beirc"))) "An alist mapping irc server name to a list of channels to --- /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/03/24 21:19:44 NONE +++ /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/03/24 21:19:44 1.1 (in-package :beirc) (defvar *post-message-hooks* (make-hash-table) "Table of hooks to be run when a message is posted to a receiver.") (defun run-post-message-hooks (message frame receiver &rest args) (maphash #'(lambda (k v) (declare (ignore k)) (apply v message frame receiver args)) *post-message-hooks*) (values)) (defmacro define-post-message-hook (hook-name (message-var frame-var receiver-var &rest other-args) &body body) "Convenience macro for defining hooks that are run when a message is posted to a receiver." `(progn (defun ,hook-name (,message-var ,frame-var ,receiver-var ,@other-args &allow-other-keys) ,@body) (setf (gethash ',hook-name *post-message-hooks*) ',hook-name))) ;;;--------------------------------------------------------------------------- ;;; If you set *default-sound-player* and *sound-for-my-nick* this ;;; should work... It leaves a lot to be desired. This should ;;; probably turn into some kind of general noisemaking interface... ;;; But this should get us thinking. [2006/03/24:rpg] ;;;--------------------------------------------------------------------------- (define-post-message-hook noisemaker (msg frame receiver &key message-directed-to-me) (declare (ignore msg frame receiver)) (when (and message-directed-to-me *default-sound-player* *sound-for-my-nick*) #+allegro (excl:run-shell-command (format nil "~A ~A" *default-sound-player* *sound-for-my-nick*) :error-output "/dev/null" :if-error-output-exists :append :wait t)))

1 0

[beirc-cvs] CVS beirc
by afuchs 24 Mar '06

24 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv14343 Modified Files: message-display.lisp Log Message: Speed up updating output by storing an sxhashed value. Also, force re-draw of messages that are actually affected by nick focussing and ignore states. --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/12 09:48:57 1.39 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/24 21:07:20 1.40 @@ -53,14 +53,14 @@ (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* - *default-fill-column*) - :cache-test #'equal) + (sxhash (list message + (message-from-focused-nick-p message receiver) + (message-from-ignored-nick-p message receiver) + width + *max-preamble-length* + *timestamp-column-orientation* + *default-fill-column*)) + :cache-test #'eql) (formatting-row (stream*) (output-timestamp-column :left) (formatting-cell (stream* :align-x :right :min-width '(3 :character))

1 0

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

22 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv2592 Modified Files: presentations.lisp Log Message: Remove typo that prevented presentations.lisp from compiling. --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/21 22:45:03 1.12 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/22 00:31:14 1.13 @@ -69,12 +69,12 @@ ;; argument must be terminated by hitting RET twice. ugh. (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) (with-delimiter-gestures (nil :override t) - . (let ((*completion-gestures* '(#\Tab))) - (nth-value 2 - (complete-input *standard-input* 'nickname-completer - #+(or):possibility-printer #+(or) 'nickname-competion-printer - :allow-any-input t - :partial-completers '()))))) + (let ((*completion-gestures* '(#\Tab))) + (nth-value 2 + (complete-input *standard-input* 'nickname-completer + #+(or):possibility-printer #+(or) 'nickname-competion-printer + :allow-any-input t + :partial-completers '()))))) ;;; nicknames

1 0

[beirc-cvs] CVS beirc
by afuchs 21 Mar '06

21 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv22374 Modified Files: application.lisp Log Message: Make read-frame-command always clear the input window - especially for abort-gesture --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:45:03 1.67 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:50:21 1.68 @@ -952,47 +952,47 @@ (call-next-method)) (defmethod read-frame-command ((frame beirc) &key (stream *standard-input*)) - (multiple-value-prog1 - (clim:with-input-editing (stream) - (when (and (current-receiver frame) (incomplete-input (current-receiver frame))) - (replace-input stream (incomplete-input (current-receiver frame)) :rescan t)) - (with-input-context ('command) (object) - (with-command-table-keystrokes (*accelerator-gestures* (frame-command-table frame)) - (catch 'keystroke-command - (let ((force-restore-input-state nil)) - (labels ((reset-saved-input () - (when (current-receiver frame) - (setf (incomplete-input (current-receiver frame)) "")))) - (handler-bind ((accelerator-gesture - (lambda (gesture) - (save-input-line stream frame) - (throw 'keystroke-command (lookup-keystroke-command-item - (accelerator-gesture-event gesture) - (frame-command-table frame))))) - (abort-gesture - (lambda (gesture) - (declare (ignore gesture)) - (reset-saved-input) - (setf force-restore-input-state nil))) - (invoked-command-by-clicking - (lambda (cond) - (declare (ignore cond)) - (save-input-line stream frame) - (setf force-restore-input-state t) - (invoke-restart 'acknowledged)))) - (let ((c (clim:read-gesture :stream stream :peek-p t))) - (multiple-value-prog1 - (cond ((eql c #\/) - (clim:read-gesture :stream stream) - (accept 'command :stream stream :prompt nil)) - (t - (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream)))) - (if force-restore-input-state - (setf force-restore-input-state nil) - (reset-saved-input))))))))) - (command - (save-input-line stream frame) - object))) + (unwind-protect + (clim:with-input-editing (stream) + (when (and (current-receiver frame) (incomplete-input (current-receiver frame))) + (replace-input stream (incomplete-input (current-receiver frame)) :rescan t)) + (with-input-context ('command) (object) + (with-command-table-keystrokes (*accelerator-gestures* (frame-command-table frame)) + (catch 'keystroke-command + (let ((force-restore-input-state nil)) + (labels ((reset-saved-input () + (when (current-receiver frame) + (setf (incomplete-input (current-receiver frame)) "")))) + (handler-bind ((accelerator-gesture + (lambda (gesture) + (save-input-line stream frame) + (throw 'keystroke-command (lookup-keystroke-command-item + (accelerator-gesture-event gesture) + (frame-command-table frame))))) + (abort-gesture + (lambda (gesture) + (declare (ignore gesture)) + (reset-saved-input) + (setf force-restore-input-state nil))) + (invoked-command-by-clicking + (lambda (cond) + (declare (ignore cond)) + (save-input-line stream frame) + (setf force-restore-input-state t) + (invoke-restart 'acknowledged)))) + (let ((c (clim:read-gesture :stream stream :peek-p t))) + (multiple-value-prog1 + (cond ((eql c #\/) + (clim:read-gesture :stream stream) + (accept 'command :stream stream :prompt nil)) + (t + (list 'com-say (accept 'mumble :history 'mumble :prompt nil :stream stream)))) + (if force-restore-input-state + (setf force-restore-input-state nil) + (reset-saved-input))))))))) + (command + (save-input-line stream frame) + object))) (window-clear stream))) (defun irc-event-loop (frame connection)

1 0

[beirc-cvs] CVS beirc
by afuchs 21 Mar '06

21 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv21100 Modified Files: presentations.lisp application.lisp Log Message: Make com-close accept a list of receivers; default to the current one. Also, add an explanatory comment about multiple RET hitting to completion. --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/16 20:44:56 1.11 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/21 22:45:03 1.12 @@ -63,14 +63,18 @@ (declare (ignore string)) (present (irc:nickname object) 'nickname :stream stream)) + +;; FIXME: complete-input here and (accept 'command) in +;; read-frame-command means that every command that takes a 'mumble +;; argument must be terminated by hitting RET twice. ugh. (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) (with-delimiter-gestures (nil :override t) - (let ((*completion-gestures* '(#\Tab))) - (nth-value 2 - (complete-input *standard-input* 'nickname-completer - #+(or):possibility-printer #+(or) 'nickname-competion-printer - :allow-any-input t - :partial-completers '()))))) + . (let ((*completion-gestures* '(#\Tab))) + (nth-value 2 + (complete-input *standard-input* 'nickname-completer + #+(or):possibility-printer #+(or) 'nickname-competion-printer + :allow-any-input t + :partial-completers '()))))) ;;; nicknames --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 15:23:35 1.66 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 22:45:03 1.67 @@ -411,17 +411,18 @@ (define-window-switcher com-window-next (:next :control) 1 (constantly t)) (define-window-switcher com-window-previous (:prior :control) -1 (constantly t)))) -(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "tab")) - (let* ((connection (connection receiver)) - (channel (irc:find-channel connection (title receiver)))) - (cond - ((member receiver (server-receivers *application-frame*) :key #'cdr) - (disconnect connection *application-frame* "Client Quit") - (setf (slot-value *application-frame* 'server-receivers) - (delete receiver (server-receivers *application-frame*) :key #'cdr))) - (channel - (irc:part connection channel)))) - (remove-receiver receiver *application-frame*)) +(define-beirc-command (com-close :name t) ((receivers '(sequence receiver) :prompt "tab" :default (list (current-receiver *application-frame*)))) + (dolist (receiver receivers) + (let* ((connection (connection receiver)) + (channel (irc:find-channel connection (title receiver)))) + (cond + ((member receiver (server-receivers *application-frame*) :key #'cdr) + (disconnect connection *application-frame* "Client Quit") + (setf (slot-value *application-frame* 'server-receivers) + (delete receiver (server-receivers *application-frame*) :key #'cdr))) + (channel + (irc:part connection channel)))) + (remove-receiver receiver *application-frame*))) (macrolet ((define-scroller-command ((com-name keystroke) (top-var bot-var) next-pos-form &optional fallback-position) `(define-beirc-command (,com-name :name t :keystroke ,keystroke) ()

1 0

[beirc-cvs] CVS beirc
by rgoldman 21 Mar '06

21 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv26685 Modified Files: application.lisp Log Message: Added *auto-connect-list*, which initially defaults to NIL. As the name suggests, beirc will attempt to connect to these servers automagically on startup. Auto-connect is achieved by :after method on adopt-frame added in this file. Idea courtesy of CLIM Guided Tour article. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/17 17:44:22 1.65 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/21 15:23:35 1.66 @@ -582,12 +582,20 @@ (define-beirc-command (com-names :name t) () (irc:names (current-connection *application-frame*) (target))) -(define-beirc-command (com-away :name t) ((reason 'mumble :prompt "reason")) +(define-beirc-command (com-away :name t) ((reason 'mumble + :prompt (if (away-status *application-frame* (current-connection *application-frame*)) + "reason: to come back from away use /back instead of away" + "reason"))) (irc:away (current-connection *application-frame*) reason)) (define-beirc-command (com-back :name t) () (irc:away (current-connection *application-frame*) "")) +(defmethod command-enabled ((command-name (eql 'com-back)) frame) + "Turn off the back command when it's not appropriate -- i.e., when you are +not away." + (away-status frame (current-connection frame))) + (define-beirc-command (com-quit :name t) (&key (reason 'mumble :prompt "reason" :default "Client Quit")) (disconnect-all *application-frame* reason) (frame-exit *application-frame*)) @@ -997,3 +1005,13 @@ (defmethod allocate-space :after ((pane climi::viewport-pane) w h) (let ((pane (first (sheet-children pane)))) (redisplay-frame-pane (pane-frame pane) pane))) + +;;; proposed addition to auto-connect to servers in the +;;; *auto-connect-list* [2006/03/21:rpg] +(defmethod adopt-frame :after (frame-manager (frame beirc)) + (declare (ignore frame-manager)) + (loop for server in *auto-connect-list* + do (execute-frame-command frame + `(com-connect ,server)))) + +

1 0