beirc-cvs

beirc-cvs@common-lisp.net

168 discussions

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv16566 Modified Files: application.lisp Log Message: Add box-adjuster-gadget between io and the query buffers. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:33:36 1.62 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:56:52 1.63 @@ -83,7 +83,8 @@ (presence :initform (make-hash-table :test #'equal) :reader presence)) (:panes (io - :interactor) + :interactor + :height 72) (pointer-doc :pointer-documentation) (status-bar :application @@ -111,7 +112,8 @@ (with-tab-layout ('receiver-pane :name 'query) ("*Not Connected*" server 'receiver-pane)) ;; (68 io) ;; no drop-shadow prompt - (72 io) + (make-pane 'clim-extensions:box-adjuster-gadget) + io (20 pointer-doc) (20 ;<-- Sigh! Bitrot! status-bar)))))

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv14194 Modified Files: presentations.lisp Log Message: Fix completion in accept method for receivers for multiple server connections. --- /project/beirc/cvsroot/beirc/presentations.lisp 2006/02/25 19:55:56 1.10 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/03/16 20:44:56 1.11 @@ -107,7 +107,9 @@ (define-presentation-method accept ((type receiver) *standard-input* (view textual-view) &key) (completing-from-suggestions (*standard-input* :partial-completers '(#\Space)) - (maphash #'suggest (receivers *application-frame*)))) + (maphash (lambda (key receiver) + (suggest (second key) receiver)) + (receivers *application-frame*)))) ;;; channels

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv13411 Modified Files: application.lisp Log Message: I forgot to mention: the "previous/next page" bindings are derived from a function by Thomas Persson. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:32:05 1.61 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:33:36 1.62 @@ -438,6 +438,7 @@ if (<= prev (bounding-rectangle-min-y (pane-viewport-region pane)) this) do (return this)) bottom) + (define-scroller-command (com-previous-page (:prior)) (top bottom) (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) (pane-min-y (rectangle-min-y (pane-viewport-region pane)))

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv13300 Modified Files: application.lisp message-processing.lisp Log Message: Fixes by Robert P. Goldman: rename "receiver" to "tab", choose a different nickname on connect. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:22:57 1.60 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:32:05 1.61 @@ -116,11 +116,12 @@ (20 ;<-- Sigh! Bitrot! status-bar))))) -(defun receiver-from-tab-pane (tab-pane) - (gethash tab-pane (tab-panes-to-receivers *application-frame*))) +;;; addition of optional argument allows debugging from outside the frame process. [2006/03/16:rpg] +(defun receiver-from-tab-pane (tab-pane &optional (frame *application-frame*)) + (gethash tab-pane (tab-panes-to-receivers frame))) (defmethod current-receiver ((frame beirc)) - (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query))))) + (let ((receiver (receiver-from-tab-pane (enabled-pane (find-pane-named frame 'query)) frame))) (if (typep receiver 'receiver) receiver nil))) @@ -283,7 +284,10 @@ (load-user-init-file) (run-frame-top-level frame) (clim-sys:destroy-process ticker-process) - (disconnect-all frame "Client Quit")))))))) + (disconnect-all frame "Client Quit")))) + ;; added process name for easier debug... + :name "BEIRC GUI process")))) + (defun message-directed-to-me-p (message) (irc:destructuring-arguments (&last body) message @@ -396,7 +400,7 @@ (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-close :name t) ((receiver 'receiver :prompt "receiver")) +(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "tab")) (let* ((connection (connection receiver)) (channel (irc:find-channel connection (title receiver)))) (cond --- /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/06 10:21:28 1.4 +++ /project/beirc/cvsroot/beirc/message-processing.lisp 2006/03/16 20:32:05 1.5 @@ -67,3 +67,10 @@ "Set/Unset away status." (setf (away-status *application-frame* (irc:connection message)) (typep message 'irc:irc-rpl_noaway-message))) + +(define-beirc-hook autojoin-hoook ((message cl-irc:irc-rpl_welcome-message)) + "When you establish a connection, check the list of channels for autojoin +and set them up accordingly." + (declare (ignore message)) + (join-missing-channels *application-frame*)) +

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv10954 Modified Files: application.lisp Log Message: Do nothing if connecting to a server/nick that we're already connected to. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:29:10 1.59 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 20:22:57 1.60 @@ -133,6 +133,14 @@ &optional (connection (current-connection *application-frame*))) (cdr (assoc connection (server-receivers frame) :test #'connection=))) +(defmethod server-receiver-from-args ((frame beirc) server-name port nickname) + (loop for (connection . receiver) in (server-receivers frame) + if (and (equal (irc:nickname (irc:user connection)) nickname) + (equal (irc:server-name connection) server-name) + ;; TODO: no port. + ) + do (return receiver))) + (defmethod (setf server-receiver) (newval (frame beirc) &optional (connection (current-connection *application-frame*))) (pushnew (cons connection newval) (slot-value frame 'server-receivers) @@ -817,33 +825,34 @@ (pass 'string :prompt "Password" :default nil) (port 'number :prompt "Port" :default irc::*default-irc-server-port*)) (let ((success nil)) - (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))) - (unwind-protect - (progn - (setf (irc:client-stream connection) (make-broadcast-stream)) - (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server) - (find-pane-named frame 'query)) - (tab-layout:remove-pane (find-pane-named frame 'server) - (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")) - (setf success t)) - (unless success - (disconnect connection frame "Client error.")))))) + (or (server-receiver-from-args *application-frame* server port nick) + (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))) + (unwind-protect + (progn + (setf (irc:client-stream connection) (make-broadcast-stream)) + (when (tab-layout:find-in-tab-panes-list (find-pane-named frame 'server) + (find-pane-named frame 'query)) + (tab-layout:remove-pane (find-pane-named frame 'server) + (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")) + (setf success t)) + (unless success + (disconnect connection frame "Client error."))))))) (defun disconnect (connection frame reason) (let ((*application-frame* frame))

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv2721 Modified Files: application.lisp Log Message: Use explicit :gesture nil on menu-only presentation translators. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:18:38 1.58 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:29:10 1.59 @@ -626,6 +626,7 @@ (define-presentation-to-command-translator nickname-to-ignore-translator (nickname com-ignore beirc :menu t + :gesture nil :documentation "Ignore this user" :pointer-documentation "Ignore this user" :tester ((object) @@ -638,6 +639,7 @@ (define-presentation-to-command-translator nickname-to-unignore-translator (nickname com-unignore beirc :menu t + :gesture nil :documentation "Unignore this user" :pointer-documentation "Unignore this user" :tester ((object) @@ -649,6 +651,7 @@ (define-presentation-to-command-translator nickname-to-focus-translator (nickname com-focus beirc :menu t + :gesture nil :documentation "Focus this user" :pointer-documentation "Focus this user" :tester ((object) @@ -660,6 +663,7 @@ (define-presentation-to-command-translator nickname-to-unfocus-translator (nickname com-unfocus beirc :menu t + :gesture nil :documentation "Unfocus this user" :pointer-documentation "Unfocus this user" :tester ((object) @@ -671,6 +675,7 @@ (define-presentation-to-command-translator nickname-to-query-translator (nickname com-query beirc :menu t + :gesture nil :documentation "Query this user" :pointer-documentation "Query this user") (object) @@ -679,6 +684,7 @@ (define-presentation-to-command-translator nickname-to-kick-translator (nickname com-kick beirc :menu t + :gesture nil :documentation "Kick this user" :pointer-documentation "Kick this user") (object) @@ -691,6 +697,7 @@ (define-presentation-to-command-translator nickname-to-ban-nick-translator (nickname com-ban-nick beirc :menu t + :gesture nil :documentation "Ban this user's nickname" :pointer-documentation "Ban this user's nickname") (object) @@ -699,6 +706,7 @@ (define-presentation-to-command-translator hostmask-to-ban-translator (hostmask com-ban-hostmask beirc :menu t + :gesture nil :documentation "Ban this hostmask" :pointer-documentation "Ban this hostmask") (object) @@ -707,6 +715,7 @@ (define-presentation-to-command-translator hostmask-to-unban-translator (hostmask com-unban-hostmask beirc :menu t + :gesture nil :documentation "Unban this hostmask" :pointer-documentation "Unban this hostmask") (object) @@ -715,6 +724,7 @@ (define-presentation-to-command-translator nickname-to-ban-hostmask-translator (nickname com-ban-hostmask beirc :menu t + :gesture nil :documentation "Ban this user's hostmask" :pointer-documentation "Ban this user's hostmask") (object)

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv2267 Modified Files: application.lisp Log Message: Increase :priority of the translators we want to use on gestures. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:11:19 1.57 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:18:38 1.58 @@ -725,7 +725,8 @@ :gesture :select :menu t :documentation "Perform WHOIS query on user" - :pointer-documentation "Perform WHOIS query on user") + :pointer-documentation "Perform WHOIS query on user" + :priority 10) (object) (list object)) @@ -734,7 +735,8 @@ :gesture :describe :menu t :documentation "Join this channel" - :pointer-documentation "Join this channel") + :pointer-documentation "Join this channel" + :priority 10) (object) (list object))

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv778 Modified Files: application.lisp Log Message: remove :gesture :menu to make the right-click presentation menu work again. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 09:39:08 1.56 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 19:11:19 1.57 @@ -625,7 +625,6 @@ (define-presentation-to-command-translator nickname-to-ignore-translator (nickname com-ignore beirc - :gesture :menu :menu t :documentation "Ignore this user" :pointer-documentation "Ignore this user" @@ -638,7 +637,6 @@ (define-presentation-to-command-translator nickname-to-unignore-translator (nickname com-unignore beirc - :gesture :menu :menu t :documentation "Unignore this user" :pointer-documentation "Unignore this user" @@ -650,7 +648,6 @@ (define-presentation-to-command-translator nickname-to-focus-translator (nickname com-focus beirc - :gesture :menu :menu t :documentation "Focus this user" :pointer-documentation "Focus this user" @@ -662,7 +659,6 @@ (define-presentation-to-command-translator nickname-to-unfocus-translator (nickname com-unfocus beirc - :gesture :menu :menu t :documentation "Unfocus this user" :pointer-documentation "Unfocus this user" @@ -674,7 +670,6 @@ (define-presentation-to-command-translator nickname-to-query-translator (nickname com-query beirc - :gesture :menu :menu t :documentation "Query this user" :pointer-documentation "Query this user") @@ -683,7 +678,6 @@ (define-presentation-to-command-translator nickname-to-kick-translator (nickname com-kick beirc - :gesture :menu :menu t :documentation "Kick this user" :pointer-documentation "Kick this user") @@ -696,7 +690,6 @@ (define-presentation-to-command-translator nickname-to-ban-nick-translator (nickname com-ban-nick beirc - :gesture :menu :menu t :documentation "Ban this user's nickname" :pointer-documentation "Ban this user's nickname") @@ -705,7 +698,6 @@ (define-presentation-to-command-translator hostmask-to-ban-translator (hostmask com-ban-hostmask beirc - :gesture :menu :menu t :documentation "Ban this hostmask" :pointer-documentation "Ban this hostmask") @@ -714,7 +706,6 @@ (define-presentation-to-command-translator hostmask-to-unban-translator (hostmask com-unban-hostmask beirc - :gesture :menu :menu t :documentation "Unban this hostmask" :pointer-documentation "Unban this hostmask") @@ -723,7 +714,6 @@ (define-presentation-to-command-translator nickname-to-ban-hostmask-translator (nickname com-ban-hostmask beirc - :gesture :menu :menu t :documentation "Ban this user's hostmask" :pointer-documentation "Ban this user's hostmask")

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv19171 Modified Files: application.lisp Log Message: Add /{Next,Previous} Page and /Top and /Bottom commands: * bound to PgDown, PgUp, Ctrl-Home and Ctrl-End. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:12:05 1.55 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 09:39:08 1.56 @@ -400,29 +400,46 @@ (irc:part connection channel)))) (remove-receiver receiver *application-frame*)) -(macrolet ((define-highlighted-message-jumper (com-name keystroke next-pos-form fallback-position) +(macrolet ((define-scroller-command ((com-name keystroke) (top-var bot-var) next-pos-form &optional fallback-position) `(define-beirc-command (,com-name :name t :keystroke ,keystroke) () (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) - (next-y-position ,next-pos-form) - (bottom (max 0 (- (bounding-rectangle-height pane) - (bounding-rectangle-height (sheet-parent pane))))) - (top 0)) - (scroll-extent pane 0 (if next-y-position - (min next-y-position bottom) - (progn - (beep) - (funcall ,fallback-position bottom top)))))))) - (define-highlighted-message-jumper com-previous-highlighted-message (:prior :shift) + (,bot-var (max 0 (- (bounding-rectangle-height pane) + (bounding-rectangle-height (sheet-parent pane))))) + (,top-var 0) + (next-y-position ,next-pos-form)) + (declare (ignorable ,top-var ,bot-var)) + (scroll-extent pane 0 ,(if fallback-position + `(if next-y-position + (max 0 (min next-y-position bottom)) + (progn + (beep) + ,fallback-position)) + `(max 0 (min next-y-position bottom)))))))) + (define-scroller-command (com-previous-highlighted-message (:prior :shift)) (top bottom) (find-if (lambda (position) (< position (bounding-rectangle-min-y (pane-viewport-region pane)))) (positions-mentioning-user (current-receiver *application-frame*))) - (lambda (bottom top) (declare (ignore bottom)) top)) - (define-highlighted-message-jumper com-next-highlighted-message (:next :shift) + top) + (define-scroller-command (com-next-highlighted-message (:next :shift)) (top bottom) (loop for (this prev . rest) on (positions-mentioning-user (current-receiver *application-frame*)) until (null prev) if (<= prev (bounding-rectangle-min-y (pane-viewport-region pane)) this) do (return this)) - (lambda (bottom top) (declare (ignore top)) bottom))) + bottom) + (define-scroller-command (com-previous-page (:prior)) (top bottom) + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (pane-min-y (rectangle-min-y (pane-viewport-region pane))) + (scroll-by (* (rectangle-height (pane-viewport-region pane)) 19/20))) + (- pane-min-y scroll-by))) + (define-scroller-command (com-next-page (:next)) (top bottom) + (let* ((pane (actual-application-pane (pane (current-receiver *application-frame*)))) + (pane-min-y (rectangle-min-y (pane-viewport-region pane))) + (scroll-by (* (rectangle-height (pane-viewport-region pane)) 19/20))) + (+ pane-min-y scroll-by))) + (define-scroller-command (com-top (:home :control)) (top bottom) + top) + (define-scroller-command (com-bottom (:end :control)) (top bottom) + bottom)) (define-beirc-command (com-remove-inactive-queries :name t) () (let ((receivers-to-close nil))

1 0

[beirc-cvs] CVS beirc
by afuchs 16 Mar '06

16 Mar '06

Update of /project/beirc/cvsroot/beirc In directory clnet:/tmp/cvs-serv17394 Modified Files: application.lisp Log Message: Fix com-browse-url for ACL compatibility. Patch by Richard P. Goldman. --- /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:01:46 1.54 +++ /project/beirc/cvsroot/beirc/application.lisp 2006/03/16 00:12:05 1.55 @@ -593,8 +593,17 @@ (define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url")) (handler-case + ;; this is probably not ENTIRELY The Right Thing for Allegro. I + ;; think for Allegro it would be handy to keep the process-id + ;; around so that we can call the reap-os-subprocesses + ;; 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) #+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) + (beep)) #+sbcl (simple-error (e) (format t "~a" e)))) (define-presentation-to-command-translator nickname-to-ignore-translator

1 0

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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

beirc-cvs