beirc-cvs

beirc-cvs@common-lisp.net

168 discussions

[beirc-cvs] CVS update: beirc/application.lisp
by afuchs＠common-lisp.net 02 Oct '05

02 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv2852 Modified Files: application.lisp Log Message: add "auto-join on reconnect" feature to com-connect; also, disconnect if there was an error during connecting. Date: Sun Oct 2 10:25:37 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.19 beirc/application.lisp:1.20 --- beirc/application.lisp:1.19 Sun Oct 2 06:01:25 2005 +++ beirc/application.lisp Sun Oct 2 10:25:37 2005 @@ -524,28 +524,38 @@ ((server 'string :prompt "Server") &key (nick 'string :prompt "Nick name" :default *default-nick*)) - (cond ((current-connection *application-frame*) - (format *query-io* "You are already connected.~%")) - (t - (setf (slot-value *application-frame* 'connection) - (irc:connect :nickname nick :server server :connection-type 'beirc-connection)) - (setf (irc:client-stream (current-connection *application-frame*)) - (make-broadcast-stream)) - (setf (slot-value *application-frame* 'nick) nick) - (let ((connection (current-connection *application-frame*))) - (let ((frame *application-frame*)) - (initialize-receiver-with-pane (server-receiver frame) frame - (find-pane-named frame 'server) - :add-pane-p nil) - (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) - (setf (connection-process *application-frame*) - (clim-sys:make-process #'(lambda () - (restart-case - (irc-event-loop frame connection) - (disconnect () - :report "Disconnect from IRC" - (disconnect frame "Client Disconnect")))) - :name "IRC Message Muffling Loop"))))))) + (let ((success nil)) + (cond ((current-connection *application-frame*) + (format *query-io* "You are already connected.~%")) + (t + (setf (slot-value *application-frame* 'connection) + (irc:connect :nickname nick :server server :connection-type 'beirc-connection)) + (unwind-protect + (progn + (setf (irc:client-stream (current-connection *application-frame*)) + (make-broadcast-stream)) + (setf (slot-value *application-frame* 'nick) nick) + (let ((connection (current-connection *application-frame*))) + (let ((frame *application-frame*)) + (loop for receiver being the hash-values of (receivers frame) + if (channelp (channel receiver)) + do (irc:join connection (channel receiver))) + (initialize-receiver-with-pane (server-receiver frame) frame + (find-pane-named frame 'server) + :add-pane-p nil) + (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) + (setf (connection-process *application-frame*) + (clim-sys:make-process #'(lambda () + (restart-case + (irc-event-loop frame connection) + (disconnect () + :report "Disconnect from IRC" + (disconnect frame "Client Disconnect")))) + :name "IRC Message Muffling Loop")))) + (setf success t)) + (unless success + (disconnect *application-frame* "Client error."))))))) + (defun disconnect (frame reason) (raise-receiver (server-receiver frame)) (irc:quit (current-connection frame) reason)

1 0

[beirc-cvs] CVS update: beirc/receivers.lisp
by mretzlaff＠common-lisp.net 02 Oct '05

02 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv17920 Modified Files: receivers.lisp Log Message: Modifies the switch-to-pane :AFTER method of beirc so that it doesn't make the tab-layout unusable for other programs in the same image. It tests first whether the tab-layout-pane is actually the pane of the current beirc *application-frame*. It's a bit unpleasant that this method will be called for *all* tab-layout-panes in the same image, perhaps there will be a way to hook such things into the tab-layout-pane by means of the WITH-TAB-LAYOUT form. (This patch is actually 8 days old, see http://paste.lisp.org/display/11924 .) Date: Sun Oct 2 06:18:25 2005 Author: mretzlaff Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.9 beirc/receivers.lisp:1.10 --- beirc/receivers.lisp:1.9 Fri Sep 30 15:46:18 2005 +++ beirc/receivers.lisp Sun Oct 2 06:18:24 2005 @@ -239,12 +239,16 @@ (t +black+))))) (defmethod switch-to-pane :after ((pane sheet) (parent (eql 'tab-layout-pane))) - (let ((receiver (receiver-from-tab-pane - (find-in-tab-panes-list pane 'tab-layout-pane)))) - (unless (null receiver) - (setf (unseen-messages receiver) 0) - (setf (messages-directed-to-me receiver) 0) - (update-drawing-options receiver)))) + (let ((my-tab-layout-pane (find-pane-named *application-frame* 'query))) + (when (eq (sheet-parent (sheet-parent pane)) ;; Is this the desired tab-layout? + my-tab-layout-pane) + + (let ((receiver (receiver-from-tab-pane + (find-in-tab-panes-list pane my-tab-layout-pane)))) + (unless (null receiver) + (setf (unseen-messages receiver) 0) + (setf (messages-directed-to-me receiver) 0) + (update-drawing-options receiver)))))) (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0)

1 0

[beirc-cvs] CVS update: beirc/application.lisp
by mretzlaff＠common-lisp.net 02 Oct '05

02 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv16500 Modified Files: application.lisp Log Message: Adds a receiver-pane-to-channel-translator presentation translator. (Useful for rejoining channels for which tab-panes are already existing.) Date: Sun Oct 2 06:01:32 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.18 beirc/application.lisp:1.19 --- beirc/application.lisp:1.18 Fri Sep 30 15:30:34 2005 +++ beirc/application.lisp Sun Oct 2 06:01:25 2005 @@ -497,6 +497,16 @@ (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane))) +(define-presentation-translator receiver-pane-to-channel-translator + (receiver-pane channel beirc + :documentation ((object stream) + (format stream "Channel: ~A" + (channel (receiver-from-tab-pane + (find-in-tab-panes-list object 'tab-layout-pane)))))) + (object) + (channel (receiver-from-tab-pane + (find-in-tab-panes-list object 'tab-layout-pane)))) + (define-presentation-translator nickname-to-hostmask-translator (nickname hostmask beirc :tester ((object context-type)

1 0

[beirc-cvs] CVS update: beirc/presentations.lisp
by afuchs＠common-lisp.net 01 Oct '05

01 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv9128 Modified Files: presentations.lisp Log Message: add a few more checks for channel-name-ness, inspired by rfcs 2811 and 2813 Date: Sat Oct 1 20:18:50 2005 Author: afuchs Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.6 beirc/presentations.lisp:1.7 --- beirc/presentations.lisp:1.6 Fri Sep 30 15:30:36 2005 +++ beirc/presentations.lisp Sat Oct 1 20:18:50 2005 @@ -116,7 +116,18 @@ (defun channelp (channel) (and (stringp channel) (> (length channel) 2) - (not (null (member (char channel 0) '(#\# #\+ #\! #\&)))))) + (< (length channel) 50) + (member (char channel 0) '(#\# #\+ #\! #\&)) + (not (find-if (lambda (c) + (member c `(#\Space + #\, ,(code-char 7) + ;; XXX: #\: is used to separate the + ;; channel name from the channel + ;; mask, and so isn't a part of the + ;; channel name. see rfc2811 for + ;; details. + #\:))) + channel)))) (define-presentation-method accept ((type channel) *standard-input* (view textual-view) &key) (let ((channel (accept 'string :view view :prompt nil)))

1 0

[beirc-cvs] CVS update: beirc/receivers.lisp
by afuchs＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv16023 Modified Files: receivers.lisp Log Message: Re-do global notices. Again. This time, for sure! (At least we'll have a chance of understanding the logic now (-:) Date: Fri Sep 30 15:46:18 2005 Author: afuchs Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.8 beirc/receivers.lisp:1.9 --- beirc/receivers.lisp:1.8 Thu Sep 29 16:51:25 2005 +++ beirc/receivers.lisp Fri Sep 30 15:46:18 2005 @@ -85,14 +85,23 @@ unless the user has opened a query window to the source already.") +(defparameter *global-notice-targets* '("$*" "auth") + "NOTICE message targets that should be treated as network +service targets.") + +(defun nickname-comparator (frame) + (lambda (nick1 nick2) + (string= (irc:normalize-nickname (current-connection frame) nick1) + (irc:normalize-nickname (current-connection frame) nick2)))) + (defun from-network-service-p (source frame) (member source *network-service-sources* - :test (lambda (source1 source2) - (string= (irc:normalize-nickname (current-connection frame) source1) - (irc:normalize-nickname (current-connection frame) source2))))) + :test (nickname-comparator frame))) -(defun global-notice-p (message target) - (and (typep message 'irc:irc-notice-message) (string= target "$*"))) +(defun global-notice-p (message target frame) + (and (typep message 'irc:irc-notice-message) + (member target *global-notice-targets* + :test (nickname-comparator frame)))) (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) @@ -103,12 +112,14 @@ (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (if (or (find-receiver target frame) - (not (from-network-service-p (irc:source message) frame)) - (and (eql nominal-target target) - (not (global-notice-p message nominal-target)))) - (intern-receiver target frame :channel target) - (server-receiver frame)))))) + (cond ((find-receiver target frame) + (intern-receiver target frame :channel target)) + ((or (global-notice-p message nominal-target frame) + (and (from-network-service-p (irc:source message) frame) + (equal nominal-target mynick))) + (server-receiver frame)) + (t + (intern-receiver target frame :channel target))))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) (define-privmsg-receiver-lookup irc:irc-notice-message))

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/presentations.lisp
by afuchs＠common-lisp.net 30 Sep '05

30 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv14091 Modified Files: application.lisp presentations.lisp Log Message: Query for a sarcastic kick message on /kick. Also, fix completion of incomplete nicknames Date: Fri Sep 30 15:30:56 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.17 beirc/application.lisp:1.18 --- beirc/application.lisp:1.17 Thu Sep 29 16:51:25 2005 +++ beirc/application.lisp Fri Sep 30 15:30:34 2005 @@ -346,8 +346,8 @@ (define-beirc-command (com-ban-hostmask :name t) ((who 'hostmask :prompt "hostmask")) (irc:ban (current-connection *application-frame*) (target) who)) -(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who")) - (irc:kick (current-connection *application-frame*) (target) who)) +(define-beirc-command (com-kick :name t) ((who 'nickname :prompt "who") (reason 'mumble :prompt "reason")) + (irc:kick (current-connection *application-frame*) (target) who reason)) (define-beirc-command (com-names :name t) () (irc:names (current-connection *application-frame*) (target))) @@ -440,7 +440,11 @@ :documentation "Kick this user" :pointer-documentation "Kick this user") (object) - (list object)) + (list object + ;; XXX: not the best way to do it. McCLIM should recognize + ;; that this is a partial command and query for the rest of + ;; the args itself. + (accept 'mumble :prompt " Reason"))) (define-presentation-to-command-translator nickname-to-ban-nick-translator (nickname com-ban-nick beirc Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.5 beirc/presentations.lisp:1.6 --- beirc/presentations.lisp:1.5 Wed Sep 28 21:33:28 2005 +++ beirc/presentations.lisp Fri Sep 30 15:30:36 2005 @@ -27,10 +27,11 @@ (defun nickname-completer (so-far mode) (multiple-value-bind (word prefix) (split-input-line so-far) - (labels ((prefixify (word) - (if (zerop (length prefix)) - (concatenate 'string word ": ") - (concatenate 'string prefix word " ")))) + (labels ((prefixify (word &optional (success t)) + (concatenate 'string prefix word + (cond ((not success) "") + ((zerop (length prefix)) ": ") + (t " "))))) (multiple-value-bind (string success object nmatches possibilities) (complete-from-possibilities word (let ((channel (and @@ -38,15 +39,16 @@ (irc:find-channel (current-connection *application-frame*) (current-channel))))) - (if (not (null channel)) - (hash-alist (irc:users channel)) - nil)) + (if (not (null channel)) + (hash-alist (irc:users channel)) + nil)) '() :action mode :value-key #'cdr) - (values (prefixify (if (null object) + (values (prefixify (if (not success) string - (irc:nickname object))) + (irc:nickname object)) + success) success object nmatches (mapcar (lambda (possibility) (cons (prefixify (car possibility)) (cdr possibility)))

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/receivers.lisp
by afuchs＠common-lisp.net 29 Sep '05

29 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv16324 Modified Files: application.lisp receivers.lisp Log Message: change (EQL input-context 'hostmask) to (presenation-subtypep i-c 'h);. Date: Thu Sep 29 16:51:25 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.16 beirc/application.lisp:1.17 --- beirc/application.lisp:1.16 Wed Sep 28 21:40:07 2005 +++ beirc/application.lisp Thu Sep 29 16:51:25 2005 @@ -497,7 +497,7 @@ (nickname hostmask beirc :tester ((object context-type) (declare (ignore object)) - (eql context-type 'hostmask))) + (presentation-subtypep context-type 'hostmask))) (object) (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.7 beirc/receivers.lisp:1.8 --- beirc/receivers.lisp:1.7 Tue Sep 27 22:53:41 2005 +++ beirc/receivers.lisp Thu Sep 29 16:51:25 2005 @@ -103,9 +103,9 @@ (target (if (equal nominal-target mynick) (irc:source message) nominal-target))) - (if (or (find-receiver (irc:source message) frame) + (if (or (find-receiver target frame) (not (from-network-service-p (irc:source message) frame)) - (and (string= nominal-target target) + (and (eql nominal-target target) (not (global-notice-p message nominal-target)))) (intern-receiver target frame :channel target) (server-receiver frame)))))) @@ -171,6 +171,7 @@ irc:irc-rpl_whoischannels-message irc:irc-rpl_whoisserver-message irc:irc-rpl_whoisidentified-message + irc:irc-rpl_away-message irc:irc-err_nosuchnick-message)) (macrolet ((define-ignore-message-types (&rest mtypes)

1 0

[beirc-cvs] CVS update: beirc/application.lisp
by afuchs＠common-lisp.net 28 Sep '05

28 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv766 Modified Files: application.lisp Log Message: Fix the hostname translator: add a tester to it that returns true only for the 'hostmask input-context. Date: Wed Sep 28 21:40:08 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.15 beirc/application.lisp:1.16 --- beirc/application.lisp:1.15 Wed Sep 28 21:33:28 2005 +++ beirc/application.lisp Wed Sep 28 21:40:07 2005 @@ -493,9 +493,11 @@ (receiver-from-tab-pane (find-in-tab-panes-list object 'tab-layout-pane))) -#+(or) ; XXX: for some reason, this translator is activated when accepting NICKNAME. (define-presentation-translator nickname-to-hostmask-translator - (nickname hostmask beirc) + (nickname hostmask beirc + :tester ((object context-type) + (declare (ignore object)) + (eql context-type 'hostmask))) (object) (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))

1 0

[beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/presentations.lisp
by afuchs＠common-lisp.net 28 Sep '05

28 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv711 Modified Files: application.lisp message-display.lisp presentations.lisp Log Message: Fix accepting 'mumble when entering /command args; some style issues; fix accepting 'nickname when in non-channel buffers. Date: Wed Sep 28 21:33:28 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.14 beirc/application.lisp:1.15 --- beirc/application.lisp:1.14 Tue Sep 27 22:53:41 2005 +++ beirc/application.lisp Wed Sep 28 21:33:28 2005 @@ -547,8 +547,7 @@ (let ((c (clim:read-gesture :stream stream :peek-p t))) (cond ((eql c #\/) (clim:read-gesture :stream stream) - (clim:accept 'clim:command :stream stream - :prompt nil)) + (clim:accept 'clim:command :stream stream :prompt nil)) (t (list 'com-say (accept 'mumble :prompt nil :stream stream)))))) (window-clear stream))) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.20 beirc/message-display.lisp:1.21 --- beirc/message-display.lisp:1.20 Mon Sep 26 12:52:05 2005 +++ beirc/message-display.lisp Wed Sep 28 21:33:28 2005 @@ -230,7 +230,7 @@ ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (present (second (irc:arguments message)) 'nickname) - (format-message* (format nil "is away: ~A" (irc:trailing-argument message)) + (format-message* (format nil " is away: ~A" (irc:trailing-argument message)) :start-length (length (second (irc:arguments message)))))))) (defmethod print-message ((message irc:irc-rpl_whoisidentified-message) receiver) Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.4 beirc/presentations.lisp:1.5 --- beirc/presentations.lisp:1.4 Tue Sep 27 22:58:41 2005 +++ beirc/presentations.lisp Wed Sep 28 21:33:28 2005 @@ -33,19 +33,20 @@ (concatenate 'string prefix word " ")))) (multiple-value-bind (string success object nmatches possibilities) (complete-from-possibilities word - (if (not (null (current-channel))) - (hash-alist - (irc:users - (irc:find-channel - (current-connection *application-frame*) - (current-channel)))) - nil) + (let ((channel (and + (current-channel) + (irc:find-channel + (current-connection *application-frame*) + (current-channel))))) + (if (not (null channel)) + (hash-alist (irc:users channel)) + nil)) '() :action mode :value-key #'cdr) - (values (if (null object) - (prefixify string) - (prefixify (irc:nickname object))) + (values (prefixify (if (null object) + string + (irc:nickname object))) success object nmatches (mapcar (lambda (possibility) (cons (prefixify (car possibility)) (cdr possibility))) @@ -59,18 +60,22 @@ (present (irc:nickname object) 'nickname :stream stream)) (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) - (let ((*completion-gestures* '(#\Tab))) + (with-delimiter-gestures (nil :override t) + (let ((*completion-gestures* '(#\Tab))) (nth-value 2 (complete-input *standard-input* 'nickname-completer #+(or):possibility-printer #+(or) 'nickname-competion-printer - :allow-any-input t)))) + :allow-any-input t + :partial-completers '()))))) ;;; nicknames (define-presentation-method accept ((type nickname) *standard-input* (view textual-view) &key) (with-slots (connection nick) *application-frame* - (let ((users (unless (null (current-channel)) - (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel)))))))) + (let ((users (let ((channel (and (not (null (current-channel))) + (irc:find-channel connection (current-channel))))) + (if (not (null channel)) + (mapcar #'car (hash-alist (irc:users (irc:find-channel connection (current-channel))))))))) (accept `(or (member ,@users) string) :prompt nil)))) (define-presentation-method accept ((type ignored-nickname) *standard-input* (view textual-view) &key)

1 0

[beirc-cvs] CVS update: beirc/presentations.lisp
by afuchs＠common-lisp.net 27 Sep '05

27 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv2916 Modified Files: presentations.lisp Log Message: fix case in completion results. This means that completion is now case-insensitive and always completes to the correct case. Date: Tue Sep 27 22:58:42 2005 Author: afuchs Index: beirc/presentations.lisp diff -u beirc/presentations.lisp:1.3 beirc/presentations.lisp:1.4 --- beirc/presentations.lisp:1.3 Tue Sep 27 22:53:41 2005 +++ beirc/presentations.lisp Tue Sep 27 22:58:41 2005 @@ -43,7 +43,9 @@ '() :action mode :value-key #'cdr) - (values (prefixify string) + (values (if (null object) + (prefixify string) + (prefixify (irc:nickname object))) success object nmatches (mapcar (lambda (possibility) (cons (prefixify (car possibility)) (cdr possibility))) @@ -54,7 +56,7 @@ #+(or) (defun nickname-completion-printer (string object stream) (declare (ignore string)) - (present (irc:name object) 'nickname :stream stream)) + (present (irc:nickname object) 'nickname :stream stream)) (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) (let ((*completion-gestures* '(#\Tab)))

1 0

← Newer
1
...
9
10
11
12
13
14
15
16
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