beirc-cvs

beirc-cvs@common-lisp.net

168 discussions

[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

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

12 Apr '06

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

1 0

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

12 Apr '06

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.

1 0

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

12 Apr '06

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

1 0

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