From afuchs at common-lisp.net Sun Apr 2 20:43:20 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 2 Apr 2006 16:43:20 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060402204320.B6B2E16005@common-lisp.net> 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 From afuchs at common-lisp.net Sun Apr 2 20:51:54 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 2 Apr 2006 16:51:54 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060402205154.5B58926081@common-lisp.net> 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 From rgoldman at common-lisp.net Mon Apr 3 17:32:37 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Mon, 3 Apr 2006 13:32:37 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060403173237.C331534040@common-lisp.net> 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) From afuchs at common-lisp.net Tue Apr 4 18:37:29 2006 From: afuchs at common-lisp.net (afuchs) Date: Tue, 4 Apr 2006 14:37:29 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060404183729.3912513023@common-lisp.net> 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)))) From rgoldman at common-lisp.net Fri Apr 7 01:42:56 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Thu, 6 Apr 2006 21:42:56 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060407014256.8B8DE12034@common-lisp.net> 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 , at other-args &allow-other-keys) , at 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*))) From rgoldman at common-lisp.net Fri Apr 7 15:43:15 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Fri, 7 Apr 2006 11:43:15 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060407154315.525CC3401E@common-lisp.net> 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)) )) From afuchs at common-lisp.net Sun Apr 9 09:32:42 2006 From: afuchs at common-lisp.net (afuchs) Date: Sun, 9 Apr 2006 05:32:42 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060409093242.5D547431B6@common-lisp.net> 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*) From rgoldman at common-lisp.net Tue Apr 11 22:28:58 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Tue, 11 Apr 2006 18:28:58 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060411222858.83F3F6F23D@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv12718 Modified Files: receivers.lisp Log Message: Reduced minimum dimensions of receiver-pane to give more freedom to resize things. --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/04 18:37:29 1.25 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/11 22:28:58 1.26 @@ -98,7 +98,7 @@ (lambda (frame pane) (beirc-app-display frame pane receiver)) :display-time nil - :min-width 600 :min-height 800 + :min-width 400 :min-height 600 :incremental-redisplay t))) (update-drawing-options receiver)))) (if (equal (current-process) (ui-process frame)) From afuchs at common-lisp.net Wed Apr 12 18:27:16 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 12 Apr 2006 14:27:16 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060412182716.84BD13106C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv25758 Modified Files: application.lisp message-display.lisp message-processing.lisp receivers.lisp Log Message: Add "reconnect" support. * notices when connections are dropped * offers to reconnect when the connection is dropped. * connection setup now believes in reconnecting. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/07 01:42:56 1.75 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/12 18:27:16 1.76 @@ -374,9 +374,8 @@ (make-instance 'bar-event :sheet frame)) (sleep 1))) -(defun join-missing-channels (frame) - (let* ((connection (current-connection frame)) - (server (when connection (irc:server-name connection)))) +(defun join-missing-channels (frame &optional (connection (current-connection frame))) + (let* ((server (when connection (irc:server-name connection)))) (when server (loop for join-channel in (cdr (assoc server *auto-join-alist* :test #'equal)) do (unless (gethash join-channel (receivers frame)) @@ -890,15 +889,20 @@ (nick 'string :prompt "Nick name" :default *default-nick*) (pass 'string :prompt "Password" :default nil) (port 'number :prompt "Port" :default irc::*default-irc-server-port*)) - (let ((success nil)) - (or (server-receiver-from-args *application-frame* server port nick) + (let ((success nil) + (maybe-server-receiver (server-receiver-from-args *application-frame* server port nick))) + (or (and maybe-server-receiver (connection-open-p maybe-server-receiver)) (let* ((frame *application-frame*) (connection (apply #'irc:connect :nickname nick :server server :connection-type 'beirc-connection :port port (if (null pass) nil `(:password ,pass)))) - (server-receiver (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame))) + (server-receiver (if maybe-server-receiver + (prog1 maybe-server-receiver + (reinit-receiver-for-new-connection maybe-server-receiver + connection)) + (intern-receiver (format nil "~A on ~A:~A" nick server port) connection frame)))) (unwind-protect (progn (setf (irc:client-stream connection) (make-broadcast-stream)) @@ -1030,13 +1034,17 @@ (command (save-input-line stream frame) object))) - (window-clear stream))) + (window-clear stream))) (defun irc-event-loop (frame connection) - (unwind-protect - (let ((*application-frame* frame)) - (irc:read-message-loop connection)) - (irc:remove-all-hooks connection))) + (let ((*application-frame* frame)) + (unwind-protect (irc:read-message-loop connection) + (setf (connection-open-p (server-receiver frame connection)) nil) + (irc:remove-all-hooks connection) + (irc:irc-message-event connection + (make-fake-irc-message 'irc-connection-closed-message + :command "Connnection closed" + :source (irc:server-name connection)))))) ;;; Hack: --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/02 20:51:54 1.45 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/12 18:27:16 1.46 @@ -494,6 +494,14 @@ (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small) (format-message* "Click here to close this tab.")))) +(defun offer-reconnect (receiver) + (let* ((conn (connection receiver)) + (server (irc:server-name conn)) + (nickname (irc:nickname (irc:user conn)))) + (with-output-as-presentation (t `(com-connect ,server :nick ,nickname) 'command) + (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small) + (format-message* (format nil "Click here to reconnect to ~A as ~A" server nickname)))))) + (defmethod print-message ((message irc:irc-err_nosuchnick-message) receiver) (formatting-message (t message receiver) ((format t " ")) @@ -672,6 +680,13 @@ (irc:irc-rpl_invitelist-message "INVITED: ") (irc:irc-rpl_exceptlist-message "UNBANNED: "))) +(defmethod print-message ((message irc-connection-closed-message) receiver) + (formatting-message (t message receiver) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +red3+) + (format-message* "Connection to server closed.") + (offer-reconnect receiver))))) + ;;; the display function (& utilities) (defgeneric preamble-length (message) --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/04 18:37:28 1.7 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/12 18:27:16 1.8 @@ -71,5 +71,4 @@ (define-beirc-hook autojoin-hoook ((message cl-irc:irc-rpl_welcome-message)) "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*)) + (join-missing-channels *application-frame* (irc:connection message))) --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/11 22:28:58 1.26 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/12 18:27:16 1.27 @@ -9,7 +9,8 @@ (messages-directed-to-me :accessor messages-directed-to-me :initform 0) (channel :reader channel :initform nil :initarg :channel) (connection :accessor connection :initarg :connection) - (query :reader query :initform nil :initarg :query) ;; <- XXX: remove this. + (connection-open-p :accessor connection-open-p :initform t) ; used only on server receivers. + (query :reader query :initform nil :initarg :query) (focused-nicks :accessor focused-nicks :initform nil) (title :reader title :initarg :title) (last-visited :accessor last-visited :initform 0) @@ -18,6 +19,8 @@ (pane :reader pane) (tab-pane :accessor tab-pane))) +(defclass irc-connection-closed-message (irc:irc-message) ()) + (defun slot-value-or-something (object &key (slot 'name) (something "without name")) (if (slot-boundp object slot) (slot-value object slot) @@ -107,6 +110,23 @@ (setf (gethash (list connection normalized-name) (receivers frame)) receiver) receiver)))) +(defun reinit-receiver-for-new-connection (server-receiver connection &optional (frame *application-frame*)) + (let ((old-connection (connection server-receiver))) + (maphash (lambda (key receiver) + (destructuring-bind (rec-connection name) key + (when (eql old-connection rec-connection) + (remhash key (receivers frame)) + (setf (gethash (list connection name) (receivers frame)) receiver) + (setf (connection receiver) connection) + (dolist (message (messages receiver)) + ;; KLUDGE: reset the connection of messages so + ;; that channel/user finding queries don't fail + ;; horribly + (setf (irc:connection message) connection))) + (write-char #\Newline *debug-io*))) + (receivers frame)))) + + (defun remove-receiver (receiver frame) (tab-layout:remove-pane (tab-pane receiver) (find-pane-named frame 'query)) @@ -256,7 +276,6 @@ cl-irc:irc-rpl_endofexceptlist-message cl-irc:irc-ping-message)) - ;;; default receiver. (defmethod receiver-for-message ((message irc:irc-message) frame) #+or ; comment out to debug on uncaught messages. From afuchs at common-lisp.net Wed Apr 12 18:42:30 2006 From: afuchs at common-lisp.net (afuchs) Date: Wed, 12 Apr 2006 14:42:30 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060412184230.D582BA0EF@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv27592 Modified Files: receivers.lisp Log Message: oops. remove #\Newline writing to debug-io. --- /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/12 18:27:16 1.27 +++ /project/beirc/cvsroot/beirc/receivers.lisp 2006/04/12 18:42:30 1.28 @@ -122,8 +122,7 @@ ;; KLUDGE: reset the connection of messages so ;; that channel/user finding queries don't fail ;; horribly - (setf (irc:connection message) connection))) - (write-char #\Newline *debug-io*))) + (setf (irc:connection message) connection))))) (receivers frame)))) From rgoldman at common-lisp.net Wed Apr 19 02:52:43 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Tue, 18 Apr 2006 22:52:43 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060419025243.7887218002@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv27717 Modified Files: message-processing.lisp Log Message: Added ignore declaration to preprocess-message method to make compiler shut up. --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/12 18:27:16 1.8 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/04/19 02:52:43 1.9 @@ -51,6 +51,7 @@ (rename-query-receiver receiver (car (last (irc:arguments message)))))))) (defmethod preprocess-message (connection message) + (declare (ignore connection message)) nil) ;;; Traditional cl-irc message hooks From rgoldman at common-lisp.net Wed Apr 19 02:53:49 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Tue, 18 Apr 2006 22:53:49 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060419025349.6C46518003@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv27759 Modified Files: application.lisp message-display.lisp Log Message: Added command-enabled method for COM-AWAY and added MEME-URL presentation type. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/12 18:27:16 1.76 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/19 02:53:48 1.77 @@ -343,21 +343,24 @@ (unless (eql receiver (current-receiver frame)) (when interesting-message-p (incf (unseen-messages receiver))) + ;; why is this only done when the receiver is not the current + ;; one? [2006/04/17:rpg] (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) + (when (and message-to-me-p + (not (eql current-insert-position + (first (positions-mentioning-user receiver))))) (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-beirc-event frame (make-instance 'foo-event :sheet frame :receiver receiver)) + ;; is this effectively the same as (values)? [2006/04/17:rpg] nil)) (defun post-message (frame message) @@ -631,6 +634,10 @@ not away." (away-status frame (current-connection frame))) +(defmethod command-enabled ((command-name (eql 'com-away)) frame) + "Turn off the away command when you are already away." + (not (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*)) @@ -826,8 +833,20 @@ (define-presentation-to-command-translator url-to-browse-url-translator (url com-browse-url beirc) (presentation) + (list (presentation-object presentation))) + +;;; this translator refines the previous one, just giving a more +;;; precise pointer documentation. If I were smarter about +;;; presentation types, I bet I could fold this into the previous +;;; translator. [2006/04/18:rpg] +(define-presentation-to-command-translator meme-url-to-browse-url-translator + (meme-url com-browse-url beirc :pointer-documentation "Browse meme log" + ;; override url-to-browse-url-translator + :priority 1) + (presentation) (list (presentation-object presentation))) + (define-presentation-translator receiver-pane-to-receiver-translator (receiver-pane receiver beirc :documentation ((object stream) --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/12 18:27:16 1.46 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/19 02:53:48 1.47 @@ -33,6 +33,10 @@ (define-presentation-type url () :inherit-from 'string) +(define-presentation-type meme-url () + :inherit-from 'url) + + (defun present-url (url) (let* ((clhs-base "http://www.lispworks.com/reference/HyperSpec/") (start (search clhs-base url))) @@ -91,7 +95,7 @@ (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) + (with-output-as-presentation (stream* (make-meme-url message) 'meme-url) (format-timestamp message)) (format-timestamp message))))))) (updating-output (stream* From rgoldman at common-lisp.net Wed Apr 19 21:21:41 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Wed, 19 Apr 2006 17:21:41 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060419212141.31E265B006@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv8324 Modified Files: sound-player.lisp Log Message: Removed the post-message-hook definition, making this file essentially standalone. Simplifies dependencies. --- /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/09 09:32:42 1.3 +++ /project/beirc/cvsroot/beirc/sound-player.lisp 2006/04/19 21:21:41 1.4 @@ -76,15 +76,3 @@ (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*))) From rgoldman at common-lisp.net Wed Apr 19 21:22:08 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Wed, 19 Apr 2006 17:22:08 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060419212208.CE08F5B008@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv8352 Modified Files: post-message-hooks.lisp Log Message: Added the noisemaker post-message-hook definition, moved from sound-player. --- /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/04/07 01:42:56 1.2 +++ /project/beirc/cvsroot/beirc/post-message-hooks.lisp 2006/04/19 21:22:08 1.3 @@ -15,3 +15,15 @@ `(progn (defun ,hook-name (,message-var ,frame-var ,receiver-var , at other-args &allow-other-keys) , at 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 + *sound-server-stream* + *sound-for-my-nick*) + (play-sound-file *sound-for-my-nick* *sound-server-stream*))) From rgoldman at common-lisp.net Wed Apr 19 21:22:47 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Wed, 19 Apr 2006 17:22:47 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060419212247.892215B008@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv8397 Modified Files: beirc.asd Log Message: Tidied up the dependencies, making sound-player load more rationally. --- /project/beirc/cvsroot/beirc/beirc.asd 2006/04/07 01:42:56 1.10 +++ /project/beirc/cvsroot/beirc/beirc.asd 2006/04/19 21:22:47 1.11 @@ -15,9 +15,9 @@ (: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")) - (:file "post-message-hooks" :depends-on ("package")) + (:file "post-message-hooks" :depends-on ("package" "sound-player")) ;; 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")) + (:file "sound-player" :depends-on ("package" "variables")) )) \ No newline at end of file From rgoldman at common-lisp.net Thu Apr 20 02:23:56 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Wed, 19 Apr 2006 22:23:56 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060420022356.75C431A060@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv14546 Modified Files: application.lisp Log Message: Added documentation and pointer-documentation to url-to-browse-url-translator. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/19 02:53:48 1.77 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 02:23:56 1.78 @@ -831,7 +831,8 @@ (list object)) (define-presentation-to-command-translator url-to-browse-url-translator - (url com-browse-url beirc) + (url com-browse-url beirc :pointer-documentation "Browse URL" + :documentation "Browse URL") (presentation) (list (presentation-object presentation))) From afuchs at common-lisp.net Thu Apr 20 06:39:27 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 20 Apr 2006 02:39:27 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060420063927.284F44610C@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv18310 Modified Files: application.lisp presentations.lisp Log Message: Catch bad input on the interactor and present it in a way that allows re-editing. Works in mcclim only, sorry. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 02:23:56 1.78 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 06:39:27 1.79 @@ -444,6 +444,11 @@ (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-insert-input :name t) ((input 'bad-input)) + (setf (incomplete-input (current-receiver *application-frame*)) + (concatenate 'string (incomplete-input (current-receiver *application-frame*)) + input))) + (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)) @@ -703,6 +708,16 @@ (beep)) #+sbcl (simple-error (e) (format t "~a" e)))) +(define-presentation-to-command-translator incomplete-input-to-input-translator + (bad-input com-insert-input beirc + :menu nil + :gesture :select + :documentation "Append this to the input line" + :pointer-documentation "Append this to the input line" + :priority 10) + (object) + (list object)) + (define-presentation-to-command-translator nickname-to-ignore-translator (nickname com-ignore beirc :menu t @@ -969,7 +984,8 @@ (with-output-to-string (s) (loop for elt across buffer if (characterp elt) - do (write-char elt s))))))) + do (write-char elt s)))) + (incomplete-input (current-receiver frame))))) (define-condition invoked-command-by-clicking () () @@ -1013,48 +1029,69 @@ (call-next-method)) (defmethod read-frame-command ((frame beirc) &key (stream *standard-input*)) - (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))) + (let ((bad-input nil)) + (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 #\/) + (handler-case + (progn + (clim:read-gesture :stream stream) + (accept 'command :stream stream :prompt nil)) + (simple-completion-error (c) + #+mcclim + (let ((preliminary-line (save-input-line stream frame))) + (setf (incomplete-input (current-receiver frame)) + (subseq preliminary-line 0 + (search (climi::completion-error-input-so-far c) + preliminary-line)) + bad-input (subseq preliminary-line + (search (climi::completion-error-input-so-far c) + preliminary-line)) + force-restore-input-state t)) + (beep) + 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) + (when bad-input + (format stream "Bad input \"") + (with-drawing-options (stream :ink +red3+) + (present bad-input 'bad-input :stream stream)) + (format stream "\"."))))) (defun irc-event-loop (frame connection) (let ((*application-frame* frame)) --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/22 00:31:14 1.13 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/04/20 06:39:27 1.14 @@ -8,6 +8,8 @@ (define-presentation-type channel () :inherit-from 'string) (define-presentation-type hostmask () :inherit-from 'string) +(define-presentation-type bad-input () :inherit-from 'string) + (defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) res) From rgoldman at common-lisp.net Fri Apr 21 16:58:58 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Fri, 21 Apr 2006 12:58:58 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060421165858.DA68E7D020@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv596 Modified Files: application.lisp Log Message: Keep cl-irc:no-such-reply errors from crashing BEIRC. Unfortunately, this is only a partial patch; it doesn't work for lisps without processing. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/20 06:39:27 1.79 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/21 16:58:58 1.80 @@ -1094,14 +1094,17 @@ (format stream "\"."))))) (defun irc-event-loop (frame connection) - (let ((*application-frame* frame)) - (unwind-protect (irc:read-message-loop connection) - (setf (connection-open-p (server-receiver frame connection)) nil) - (irc:remove-all-hooks connection) - (irc:irc-message-event connection - (make-fake-irc-message 'irc-connection-closed-message - :command "Connnection closed" - :source (irc:server-name connection)))))) + ;; keep unrecognized responses from crashing BEIRC [2006/04/21:rpg] + (handler-bind ((cl-irc:no-such-reply #'(lambda (c) + (continue c)))) + (let ((*application-frame* frame)) + (unwind-protect (irc:read-message-loop connection) + (setf (connection-open-p (server-receiver frame connection)) nil) + (irc:remove-all-hooks connection) + (irc:irc-message-event connection + (make-fake-irc-message 'irc-connection-closed-message + :command "Connnection closed" + :source (irc:server-name connection))))))) ;;; Hack: From rgoldman at common-lisp.net Wed Apr 26 18:22:54 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Wed, 26 Apr 2006 14:22:54 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060426182254.038BA12034@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16201 Modified Files: application.lisp variables.lisp Log Message: Added *default-realname* variable and made com-connect set realname. --- /project/beirc/cvsroot/beirc/application.lisp 2006/04/21 16:58:58 1.80 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/04/26 18:22:54 1.81 @@ -922,6 +922,7 @@ ((server 'string :prompt "Server") &key (nick 'string :prompt "Nick name" :default *default-nick*) + (realname 'string :prompt "Real name (phrase)" :default *default-realname*) (pass 'string :prompt "Password" :default nil) (port 'number :prompt "Port" :default irc::*default-irc-server-port*)) (let ((success nil) @@ -930,6 +931,11 @@ (let* ((frame *application-frame*) (connection (apply #'irc:connect :nickname nick :server server :connection-type 'beirc-connection :port port + ;; this works because the default in + ;; cl-irc is NIL, so we don't have + ;; to handle this specially as with + ;; password. + :realname realname (if (null pass) nil `(:password ,pass)))) --- /project/beirc/cvsroot/beirc/variables.lisp 2006/04/07 01:42:56 1.15 +++ /project/beirc/cvsroot/beirc/variables.lisp 2006/04/26 18:22:54 1.16 @@ -4,6 +4,8 @@ (defvar *default-fill-column* 80) (defvar *timestamp-column-orientation* :right) (defvar *default-nick* (format nil "Brucio-~d" (random 100))) +(defvar *default-realname* NIL + "Either a string or NIL.") (defvar *default-web-browser* #+darwin "/usr/bin/open" ;; assuming a debian system running X: #+linux "/usr/bin/x-www-browser") From rgoldman at common-lisp.net Wed Apr 26 18:23:16 2006 From: rgoldman at common-lisp.net (rgoldman) Date: Wed, 26 Apr 2006 14:23:16 -0400 (EDT) Subject: [beirc-cvs] CVS beirc Message-ID: <20060426182316.F2EBF1203E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16234 Modified Files: message-display.lisp Log Message: Changed offer-reconnect to honor realname setting. --- /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/19 02:53:48 1.47 +++ /project/beirc/cvsroot/beirc/message-display.lisp 2006/04/26 18:23:16 1.48 @@ -501,8 +501,9 @@ (defun offer-reconnect (receiver) (let* ((conn (connection receiver)) (server (irc:server-name conn)) - (nickname (irc:nickname (irc:user conn)))) - (with-output-as-presentation (t `(com-connect ,server :nick ,nickname) 'command) + (nickname (irc:nickname (irc:user conn))) + (realname (irc:realname (irc:user conn)))) + (with-output-as-presentation (t `(com-connect ,server :nick ,nickname :realname ,realname) 'command) (with-drawing-options (*standard-output* :ink +grey12+ :text-size :small) (format-message* (format nil "Click here to reconnect to ~A as ~A" server nickname))))))