beirc-cvs

beirc-cvs@common-lisp.net

168 discussions

[beirc-cvs] CVS beirc
by afuchs 09 Apr '06

09 Apr '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv6956 Modified Files: sound-player.lisp Log Message: Make sound-server functions work with sbcl: * add :wait nil to run-program invocation, * use the sb-ext package prefix where needed, * store the process structure instead of the PID in the *s-s-pid* variable and * kill & wait for the process correctly --- /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/07 15:43:15 1.2 +++ /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/09 09:32:42 1.3 @@ -33,9 +33,9 @@ (let ((p (sb-ext:run-program "/bin/sh" (list "-c" sound-player-cmd) - :input :stream :output nil :error nil))) - (setf sound-stream (process-input p) - pid (process-pid p))) + :input :stream :output nil :error nil :wait nil))) + (setf sound-stream (sb-ext:process-input p) + pid p)) #-(or allegro sbcl) (progn (cerror "Just reset *default-sound-player* to NIL and run without sounds." @@ -51,7 +51,9 @@ OS subprocess." (when *sound-server-pid* #+sbcl - (sb-posix:kill *sound-server-pid* sb-posix:sigkill) + (progn + (sb-ext:process-kill *sound-server-pid* sb-posix:sigkill) + (sb-ext:process-wait *sound-server-pid* t)) #+allegro (progn (close *sound-server-stream*)

1 0

[beirc-cvs] CVS beirc
by rgoldman 07 Apr '06

07 Apr '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv10401 Modified Files: sound-player.lisp Log Message: In the introduction of the SBCL run-program code, I introduced a syntax error. Fixed now. --- /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/07 01:42:56 1.1 +++ /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/07 15:43:15 1.2 @@ -24,6 +24,7 @@ (let (sound-stream pid) #+allegro (let (bogon) + (declare (ignore bogon)) (multiple-value-setq (sound-stream bogon pid) (excl:run-shell-command sound-player-cmd :wait nil :input :stream :output "/dev/null" :if-output-exists :append :error-output "/dev/null" :if-error-output-exists :append))) @@ -41,7 +42,6 @@ "Don't know how to start a beirc sound server for this lisp. Feel free to supply one.") (setf *default-sound-player* nil) (return-from start-sound-server nil)) - (declare (ignore bogon)) (setf *sound-server-pid* pid *sound-server-stream* sound-stream)) ))

1 0

[beirc-cvs] CVS beirc
by rgoldman 07 Apr '06

07 Apr '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv2727 Modified Files: application.lisp beirc.asd post-message-hooks.lisp variables.lisp Added Files: sound-player.lisp Log Message: Revised treatment of sounds. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/04 18:37:28 1.74 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/07 01:42:56 1.75 @@ -104,6 +104,10 @@ (beirc-app-display frame pane (server-receiver *application-frame*))) :display-time nil :width 400 :height 600 + ;; added this, in the hopes that overwriting the :height argument + ;; would allow more freedom to resize the tab-pane + ;; (query). [2006/04/05:rpg] + :min-height 100 :incremental-redisplay t))) (:geometry :width 800 :height 600) (:top-level (clim:default-frame-top-level :prompt 'beirc-prompt)) @@ -311,6 +315,8 @@ (when (processes-supported-p) (clim-sys:destroy-process ticker-process)) (disconnect-all frame "Client Quit")))))) + ;; will start up a sound player, if you've configured one. [2006/04/06:rpg] + (start-sound-server) (cond (new-process (setf *gui-process* @@ -1047,3 +1053,6 @@ `(com-connect ,server)))) +(defmethod frame-exit :after ((frame beirc)) + "Shut off the sound server process, if necessary." + (stop-sound-server)) \ No newline at end of file --- /project/beirc/cvsroot/beirc/beirc.asd 2006/03/27 21:42:41 1.9 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/04/07 01:42:56 1.10 @@ -6,7 +6,7 @@ (cl:in-package :beirc.system) (defsystem :beirc - :depends-on (:mcclim :cl-irc :split-sequence :tab-layout :cl-ppcre) + :depends-on (:mcclim :cl-irc :split-sequence :tab-layout :cl-ppcre :cl-fad) :components ((:file "package") (:file "variables" :depends-on ("package")) (:file "events" :depends-on ("package")) @@ -16,4 +16,8 @@ (:file "application" :depends-on ("package" "variables" "presentations" "events" "receivers")) (:file "message-processing" :depends-on ("package" "variables" "receivers" "application")) (:file "post-message-hooks" :depends-on ("package")) + ;; we use the post-message-hook definer here. This is + ;; probably wrong, and the dependency should be + ;; removed. [2006/04/06:rpg] + (:file "sound-player" :depends-on ("post-message-hooks")) )) \ No newline at end of file --- /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/03/24 21:19:44 1.1 +++ /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/04/07 01:42:56 1.2 @@ -15,17 +15,3 @@ `(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))) --- /project/beirc/cvsroot/beirc/variables.lisp 2006/03/27 21:42:41 1.14 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/04/07 01:42:56 1.15 @@ -9,8 +9,12 @@ #+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.") + #+linux "/usr/bin/ogg123 -") + "An external program that can be used to produce sounds. +You should set this to be a program that will read from +its standard input and produce sounds. See the example +value, which is ogg123, configured to read its input from +stdin, instead of from a file.") (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 --- /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/07 01:42:56 NONE +++ /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/07 01:42:56 1.1 (in-package :beirc) ;;;--------------------------------------------------------------------------- ;;; This is a rudimentary approach to having a permanently-running ;;; sound server to which you can dump sounds. [2006/04/06:rpg] ;;;--------------------------------------------------------------------------- ;;;--------------------------------------------------------------------------- ;;; To dos: ;;; 1. figure out whether this is at all compatible with a ;;; single-threaded lisp, and if so, how to make it work out. ;;; 2. Add cmucl and sbcl sound player forms. SBCL added; needs to be checked. ;;;--------------------------------------------------------------------------- (defvar *sound-server-pid* NIL "What's the PID of the process to which you can dump sounds? Should probably be moved to a slot of the application.") (defvar *sound-server-stream* NIL "What's the stream into which you dump sound files?") (defun start-sound-server (&optional (sound-player-cmd *default-sound-player*)) (when sound-player-cmd (let (sound-stream pid) #+allegro (let (bogon) (multiple-value-setq (sound-stream bogon pid) (excl:run-shell-command sound-player-cmd :wait nil :input :stream :output "/dev/null" :if-output-exists :append :error-output "/dev/null" :if-error-output-exists :append))) ;; the following is close to completely untested... [2006/04/06:rpg] #+sbcl (let ((p (sb-ext:run-program "/bin/sh" (list "-c" sound-player-cmd) :input :stream :output nil :error nil))) (setf sound-stream (process-input p) pid (process-pid p))) #-(or allegro sbcl) (progn (cerror "Just reset *default-sound-player* to NIL and run without sounds." "Don't know how to start a beirc sound server for this lisp. Feel free to supply one.") (setf *default-sound-player* nil) (return-from start-sound-server nil)) (declare (ignore bogon)) (setf *sound-server-pid* pid *sound-server-stream* sound-stream)) )) (defun stop-sound-server () "As the name suggests, shut down the sound server, killing the OS subprocess." (when *sound-server-pid* #+sbcl (sb-posix:kill *sound-server-pid* sb-posix:sigkill) #+allegro (progn (close *sound-server-stream*) (system:reap-os-subprocess :pid *sound-server-pid*)) (setf *sound-server-pid* nil *sound-server-stream* nil)) (values)) (defun play-sound-file (filename &optional (stream *sound-server-stream*)) "Play a sound file by dumping it into a stream opened by a sound server program." (copy-to-stream filename stream)) ;;;--------------------------------------------------------------------------- ;;; Helper function ;;;--------------------------------------------------------------------------- (defun copy-to-stream (from-file to-stream) "Dump the contents of the file FROM-FILE into the stream TO-STREAM." (with-open-file (from from-file) (cl-fad:copy-stream from to-stream))) ;;;--------------------------------------------------------------------------- ;;; 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 *sound-server-stream* *sound-for-my-nick*) (play-sound-file *sound-for-my-nick* *sound-server-stream*)))

1 0

[beirc-cvs] CVS beirc
by afuchs 04 Apr '06

04 Apr '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv18901 Modified Files: application.lisp events.lisp message-processing.lisp receivers.lisp Log Message: Experimental single-thread support. Beware. Please test. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/03 17:32:37 1.73 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/04 18:37:28 1.74 @@ -86,6 +86,7 @@ :interactor :height 72) (pointer-doc :pointer-documentation) + (status-bar :application :display-function 'beirc-status-display @@ -111,7 +112,6 @@ (vertically () (with-tab-layout ('receiver-pane :name 'query) ("*Not Connected*" server 'receiver-pane)) - ;; (68 io) ;; no drop-shadow prompt (make-pane 'clim-extensions:box-adjuster-gadget) io (20 pointer-doc) @@ -189,7 +189,8 @@ (with-text-family (t :sans-serif) (multiple-value-bind (seconds minutes hours) (decode-universal-time (get-universal-time)) seconds - (format t "~2,'0D:~2,'0D ~A~:[~;(away)~] ~@[on ~A~]~@[ speaking to ~A~]~100T~D messages" + (format t "~:[~;~2,'0D:~2,'0D ~]~A~:[~;(away)~] ~@[on ~A~]~@[ speaking to ~A~]~100T~D messages" + (processes-supported-p) ; don't display time if threads are not supported hours minutes (current-nickname) (away-status *application-frame* (current-connection *application-frame*)) @@ -274,7 +275,7 @@ ;; 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)))) + (next-event (and (processes-supported-p) (event-peek (frame-top-level-sheet frame))))) (with-pane-kept-scrolled-to-bottom (pane) (update-drawing-options receiver) ;; delay redisplay until this is the last event in the queue @@ -295,18 +296,20 @@ ;;; -(defun beirc (&key (new-process t)) +(defun beirc (&key (new-process (processes-supported-p))) (let* ((syms '(*package* *trace-output*)) (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"))) + (ticker-process (when (processes-supported-p) + (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) + (when (processes-supported-p) + (clim-sys:destroy-process ticker-process)) (disconnect-all frame "Client Quit")))))) (cond (new-process @@ -330,7 +333,7 @@ (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))) + (append (messages receiver) (list message))) (unless (eql receiver (current-receiver frame)) (when interesting-message-p (incf (unseen-messages receiver))) @@ -347,8 +350,8 @@ (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)) + (queue-beirc-event frame + (make-instance 'foo-event :sheet frame :receiver receiver)) nil)) (defun post-message (frame message) @@ -899,14 +902,16 @@ (find-pane-named frame 'query))) (setf (server-receiver frame connection) server-receiver) (setf (ui-process *application-frame*) (current-process)) - (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")) + (if (processes-supported-p) + (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")) + (irc:start-background-message-handler connection)) (setf success t)) (unless success (disconnect connection frame "Client error."))))))) --- /project/beirc/cvsroot/beirc/events.lisp 2006/03/12 09:48:57 1.1 +++ /project/beirc/cvsroot/beirc/events.lisp 2006/04/04 18:37:28 1.2 @@ -19,4 +19,13 @@ (defclass new-sheet-event (clim:window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (closure :initarg :creator :reader sheet-creation-closure) - (receiver :initarg :receiver :reader receiver))) \ No newline at end of file + (receiver :initarg :receiver :reader receiver))) + +(defun processes-supported-p () + (processp (current-process))) + +(defun queue-beirc-event (frame event) + (if (processes-supported-p) + (queue-event (frame-top-level-sheet frame) + event) + (handle-event frame event))) \ No newline at end of file --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/27 13:46:47 1.6 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/04 18:37:28 1.7 @@ -73,9 +73,3 @@ 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/receivers.lisp 2006/04/02 20:43:20 1.24 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/04 18:37:29 1.25 @@ -103,7 +103,7 @@ (update-drawing-options receiver)))) (if (equal (current-process) (ui-process frame)) (funcall creator frame) - (queue-event (frame-top-level-sheet frame) (make-instance 'new-sheet-event :sheet frame :creator creator))) + (queue-beirc-event frame (make-instance 'new-sheet-event :sheet frame :creator creator))) (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver))))

1 0

[beirc-cvs] CVS beirc
by rgoldman 03 Apr '06

03 Apr '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv28964 Modified Files: application.lisp Log Message: Quotified URLs for Allegro in COM-BROWSE-URL, since they will be evaluated by the shell. question marks in URLs cause breakage. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/02 20:43:20 1.72 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/03 17:32:37 1.73 @@ -681,7 +681,7 @@ ;; function... Not sure how to do this. [2006/03/14:rpg] ;; actually, this is true for all of these invocations. doesn't ;; bite us in sbcl, though. [2006/03/15:asf] - #+allegro (excl:run-shell-command (format nil "~A ~A" *default-web-browser* url) :wait nil) + #+allegro (excl:run-shell-command (format nil "~A \'~A\'" *default-web-browser* url) :wait nil) #+sbcl (sb-ext:run-program *default-web-browser* `(,url) :wait nil) #+openmcl (ccl:run-program *default-web-browser* `(,url) :wait nil) #-(or sbcl openmcl allegro) (progn (format *debug-io* "Can't figure out how to browse to url ~A~%" url)

1 0

[beirc-cvs] CVS beirc
by afuchs 02 Apr '06

02 Apr '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv5557 Modified Files: message-display.lisp Log Message: Make offered commands look a bit nicer (and less like error messages) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/02 20:43:20 1.44 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/02 20:51:54 1.45 @@ -490,20 +490,21 @@ ;;; channel management messages (defun offer-close (receiver) - (format-message* "To close this tab, click ") - (present `(com-close (,receiver)) 'command)) + (with-output-as-presentation (t `(com-close (,receiver)) 'command) + (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small) + (format-message* "Click here to close this tab.")))) (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) - (irc:destructuring-arguments (me target &rest rest) message - (declare (ignore me rest)) + ((irc:destructuring-arguments (me target &rest rest) message + (declare (ignore me rest)) + (with-drawing-options (*standard-output* :ink +red3+ :text-size :small) (format-message* (format nil "No such nick or channel \"~A\". " - target)) - (when (string= (title receiver) - (irc:normalize-nickname (connection receiver) target)) - (offer-close receiver))))))) + target))) + (when (string= (title receiver) + (irc:normalize-nickname (connection receiver) target)) + (offer-close receiver)))))) (defmethod print-message ((message irc:irc-err_blocking_notid-message) receiver) (formatting-message (t message receiver) @@ -511,9 +512,10 @@ ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) (irc:destructuring-arguments (me &last msg) message (declare (ignore me)) - (format-message* (format nil "~A~%" msg)) - (format-message* "To identify, click") - (present `(com-identify) 'command)))))) + (format-message* msg) + (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small) + (with-output-as-presentation (t `(com-identify) 'command) + (format-message* "Click here to identify yourself.")))))))) (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) (irc:destructuring-arguments (&last body) message

1 0

[beirc-cvs] CVS beirc
by afuchs 02 Apr '06

02 Apr '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv4005 Modified Files: application.lisp message-display.lisp receivers.lisp Log Message: Display "not authorized" messages and offer a (fixed) clickable identify command. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/27 21:38:43 1.71 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/02 20:43:20 1.72 @@ -391,7 +391,7 @@ :test #'equal))) (who 'nickname :prompt "Target" :default "NickServ")) (when (null password) - (accept 'string :prompt "Password")) + (setf password (accept 'string :prompt "Password"))) (irc:privmsg (current-connection *application-frame*) who (format nil "IDENTIFY ~A" password))) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/03/27 21:46:31 1.43 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/02 20:43:20 1.44 @@ -490,8 +490,8 @@ ;;; channel management messages (defun offer-close (receiver) - (format-message* (format nil "To close this tab, click ")) - (present `(com-close ,receiver) 'command)) + (format-message* "To close this tab, click ") + (present `(com-close (,receiver)) 'command)) (defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver) (formatting-message (t message receiver) @@ -505,6 +505,16 @@ (irc:normalize-nickname (connection receiver) target)) (offer-close receiver))))))) +(defmethod print-message ((message irc:irc-err_blocking_notid-message) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+ :text-size :small) + (irc:destructuring-arguments (me &last msg) message + (declare (ignore me)) + (format-message* (format nil "~A~%" msg)) + (format-message* "To identify, click") + (present `(com-identify) 'command)))))) + (defmethod print-message ((message irc:irc-err_chanoprivsneeded-message) receiver) (irc:destructuring-arguments (&last body) message (formatting-message (t message receiver) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/03/16 00:01:46 1.23 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/02 20:43:20 1.24 @@ -229,7 +229,8 @@ irc:irc-rpl_whoisidentified-message irc:irc-rpl_whoisidle-message irc:irc-rpl_away-message - irc:irc-err_nosuchnick-message)) + irc:irc-err_nosuchnick-message + irc:irc-err_blocking_notid-message)) (macrolet ((define-ignore-message-types (&rest mtypes) `(progn

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

← Newer
1
2
3
4
5
6
7
...
17
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

beirc-cvs