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

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

26 Apr '06

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

1 0

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

26 Apr '06

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

1 0

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

21 Apr '06

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:

1 0

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

20 Apr '06

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)

1 0

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

20 Apr '06

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

1 0

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

19 Apr '06

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

1 0

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

19 Apr '06

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 ,@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 + *sound-server-stream* + *sound-for-my-nick*) + (play-sound-file *sound-for-my-nick* *sound-server-stream*)))

1 0

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

19 Apr '06

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

1 0

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

19 Apr '06

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*

1 0

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

19 Apr '06

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

1 0