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