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

[beirc-cvs] CVS beirc
by afuchs 27 Jan '06

27 Jan '06

Update of /project/beirc/cvsroot/beirc In directory common-lisp:/tmp/cvs-serv10831 Modified Files: presentations.lisp Log Message: Finally! RET no longer tries to complete the line! (Careful reading of the clim spec really paid off (-:) --- /project/beirc/cvsroot/beirc/presentations.lisp 2005/10/01 18:18:50 1.7 +++ /project/beirc/cvsroot/beirc/presentations.lisp 2006/01/27 17:18:04 1.8 @@ -32,27 +32,29 @@ (cond ((not success) "") ((zerop (length prefix)) ": ") (t " "))))) - (multiple-value-bind (string success object nmatches possibilities) - (complete-from-possibilities word - (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 (prefixify (if (not success) - string - (irc:nickname object)) - success) - success object nmatches (mapcar (lambda (possibility) - (cons (prefixify (car possibility)) - (cdr possibility))) - possibilities)))))) + (if (eql mode :complete) ; the user entered an activation gesture. don't complete. + (values so-far nil nil 0 nil) + (multiple-value-bind (string success object nmatches possibilities) + (complete-from-possibilities word + (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 (prefixify (if (not success) + string + (irc:nickname object)) + success) + success object nmatches (mapcar (lambda (possibility) + (cons (prefixify (car possibility)) + (cdr possibility))) + possibilities))))))) ;; FIXME/FIXMCCLIM: :possibility-printer is ignored in current ;; McCLIM's COMPLETE-INPUT implementation. @@ -64,11 +66,11 @@ (define-presentation-method accept ((type mumble) *standard-input* (view textual-view) &key) (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 - :partial-completers '()))))) + (nth-value 2 + (complete-input *standard-input* 'nickname-completer + #+(or):possibility-printer #+(or) 'nickname-competion-printer + :allow-any-input t + :partial-completers '()))))) ;;; nicknames

1 0

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

07 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv21581 Modified Files: application.lisp Log Message: Adds COM-LOAD to load lisp files from within beirc. For example to load a CL-IRC hook like http://bl0rg.net/~mgr/flux/bl0rg-hook.lisp (or slightly more useful things). Date: Fri Oct 7 02:59:58 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.33 beirc/application.lisp:1.34 --- beirc/application.lisp:1.33 Fri Oct 7 02:03:15 2005 +++ beirc/application.lisp Fri Oct 7 02:59:58 2005 @@ -371,6 +371,17 @@ (when (eql status :external) (apply symbol (current-connection *application-frame*) (coerce args 'list))))) +(define-beirc-command (com-load :name t) + ((pathname 'pathname :prompt "pathname") + &key + (remove-type-if-is-lisp-p 'boolean :default t)) + (when (probe-file pathname) + (load (if (and remove-type-if-is-lisp-p + (string-equal (pathname-type pathname) + "lisp")) + (make-pathname :type nil :defaults pathname) + pathname)))) + (defun make-fake-irc-message (message-type &key command arguments (source (slot-value *application-frame* 'nick)) trailing-argument)

1 0

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

07 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv18334 Modified Files: application.lisp Log Message: SEND-PRIVATE-MESSAGE is changed to do the same as the code in COM-SAY (that is, the test (unless (or (string= what "") (null target)) has been added). Therfore also: The whole body of COM-SAY is now (com-msg (target) what). The presentation-type of the parameter TARGET of COM-MSG has been changed from 'nickname to '(OR nickname channel). (Minor code reorganisation: SEND-PRIVATE-MESSAGE, COM-MSG, and COM-ME are moved from the end of the application.lisp to the place where COM-SAY is defined.) Date: Fri Oct 7 02:03:16 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.32 beirc/application.lisp:1.33 --- beirc/application.lisp:1.32 Wed Oct 5 15:21:36 2005 +++ beirc/application.lisp Fri Oct 7 02:03:15 2005 @@ -443,14 +443,35 @@ (or (current-query) (current-channel))) -(define-beirc-command (com-say :name t) ((what 'mumble)) - (unless (or (string= what "") (null (target))) +(defun send-private-message (target what) + (unless (or (string= what "") + (null target)) (post-message *application-frame* (make-fake-irc-message 'irc:irc-privmsg-message :trailing-argument what - :arguments (list (target)) + :arguments (list target) :command "PRIVMSG")) - (irc:privmsg (current-connection *application-frame*) (target) what))) + (irc:privmsg (current-connection *application-frame*) target what))) + +(define-beirc-command (com-msg :name t) + ((target '(OR nickname channel) :prompt "who") + (what 'mumble :prompt "what")) + (send-private-message target what)) + +(define-beirc-command (com-say :name t) + ((what 'mumble)) + (com-msg (target) what)) + +(define-beirc-command (com-me :name t) ((what 'mumble :prompt nil)) + (with-slots (connection) *application-frame* + (let ((m (make-fake-irc-message 'irc:ctcp-action-message + :trailing-argument + (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) + :arguments (list (target)) + :command "PRIVMSG"))) ;### + (post-message *application-frame* m) + (irc:privmsg connection (target) + (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))) (define-beirc-command (com-nick :name t) ((new-nick 'string :prompt "new nick")) (setf (slot-value *application-frame* 'nick) new-nick) ;This is _not_ the way to do it. @@ -774,30 +795,3 @@ (defmethod allocate-space :after ((pane climi::viewport-pane) w h) (let ((pane (first (sheet-children pane)))) (redisplay-frame-pane (pane-frame pane) pane))) - -;;;;;; - -(define-beirc-command (com-me :name t) ((what 'mumble :prompt nil)) - (with-slots (connection) *application-frame* - (let ((m (make-fake-irc-message 'irc:ctcp-action-message - :trailing-argument - (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)) - :arguments (list (target)) - :command "PRIVMSG"))) ;### - (post-message *application-frame* m) - (irc:privmsg connection (target) - (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1)))))) - -(defun send-private-message (target what) - (post-message *application-frame* - (make-fake-irc-message 'irc:irc-privmsg-message - :trailing-argument what - :arguments (list target) - :command "PRIVMSG")) - (irc:privmsg (current-connection *application-frame*) target what)) - -(define-beirc-command (com-msg :name t) - ((target 'nickname :prompt "who") (what 'mumble :prompt "what")) - (warn "~S ~S" target what) - (send-private-message target what) ) -

1 0

[beirc-cvs] CVS update: beirc/message-display.lisp
by mretzlaff＠common-lisp.net 06 Oct '05

06 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv16261 Modified Files: message-display.lisp Log Message: The nickname in method print-message ((message irc:irc-part-message) receiver) will now be presented as such (by calling FORMAT-MESSAGE*). Date: Fri Oct 7 01:35:20 2005 Author: mretzlaff Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.25 beirc/message-display.lisp:1.26 --- beirc/message-display.lisp:1.25 Wed Oct 5 15:26:04 2005 +++ beirc/message-display.lisp Fri Oct 7 01:35:20 2005 @@ -175,7 +175,9 @@ (formatting-message (t message receiver) ((format t "!!! ~A" (irc:source message))) ((with-drawing-options (*standard-output* :ink +red+ :text-size :small) - (format t "~A ~A :~A" (irc:command message) (irc:arguments message) (irc:trailing-argument message)))))) + (format t "~A ~A :~A" (irc:command message) + (irc:arguments message) + (irc:trailing-argument message)))))) ;;; user-related messages @@ -306,7 +308,7 @@ ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format-message* (format nil "~A Names: ~A" (third (irc:arguments message)) - (irc:trailing-argument message))))))) + (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-part-message) receiver) (formatting-message (t message receiver) @@ -314,7 +316,8 @@ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Part: ") (present (irc:source message) 'nickname) - (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) + (format-message* (format nil " left ~A: ~A" (first (irc:arguments message)) + (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-join-message) receiver) (formatting-message (t message receiver)

1 0

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

05 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv1717 Modified Files: message-display.lisp Log Message: Changes the :MIN-WIDTH of the nickname column from '(16 :character) to '(3 :character) in order to waste less space. Seems to work like a charm (though I haven't had a look at FORMATTING-CELL or FORMATTING-ROW)... Date: Wed Oct 5 15:26:04 2005 Author: mretzlaff Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.24 beirc/message-display.lisp:1.25 --- beirc/message-display.lisp:1.24 Mon Oct 3 01:52:32 2005 +++ beirc/message-display.lisp Wed Oct 5 15:26:04 2005 @@ -55,7 +55,7 @@ :cache-test #'equal) (formatting-row (stream*) (output-timestamp-column :left) - (formatting-cell (stream* :align-x :right :min-width '(16 :character)) + (formatting-cell (stream* :align-x :right :min-width '(3 :character)) (with-drawing-options (stream* :ink +dark-red+) (funcall preamble-writer))) (formatting-cell (stream* :align-x :left

1 0

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

05 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv1689 Modified Files: application.lisp Log Message: Beirc's prompt is now surrounded by a :DROP-SHADOW box (and the "text-modish" " => " will not be printed anymore). Date: Wed Oct 5 15:21:36 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.31 beirc/application.lisp:1.32 --- beirc/application.lisp:1.31 Wed Oct 5 05:39:14 2005 +++ beirc/application.lisp Wed Oct 5 15:21:36 2005 @@ -106,7 +106,8 @@ (vertically () (with-tab-layout ('receiver-pane :name 'query) ("*Server*" server 'receiver-pane)) - (68 io) + ;; (68 io) ;; no drop-shadow prompt + (72 io) (20 pointer-doc) (20 ;<-- Sigh! Bitrot! status-bar))))) @@ -136,13 +137,16 @@ (length (current-messages)))))) (defun beirc-prompt (*standard-output* *application-frame*) - (write-string "Beirc" *standard-output*) - (let ((receiver (current-receiver *application-frame*))) - (when receiver - (write-string " " *standard-output*) - (with-output-as-presentation (*standard-output* receiver 'receiver) - (write-string (title receiver) *standard-output*)))) - (write-string " => " *standard-output*)) + (stream-increment-cursor-position *standard-output* 3 4) + (surrounding-output-with-border (*standard-output* :shape :drop-shadow :move-cursor nil) + (write-string "Beirc" *standard-output*) + (let ((receiver (current-receiver *application-frame*))) + (when receiver + (write-string " " *standard-output*) + (with-output-as-presentation (*standard-output* receiver 'receiver) + (write-string (title receiver) *standard-output*))))) + (stream-increment-cursor-position *standard-output* 10 0) + #+nil (write-string " => " *standard-output*)) ;; (defun format-message (prefix mumble) ;; (write-line

1 0

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

05 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv635 Modified Files: receivers.lisp Log Message: The method PRINT-OBJECT ((receiver receiver) stream) is changed: As we have the needed accept-methods for the presentation-type RECEIVER, we can just write the receiver's title (if it is available). Date: Wed Oct 5 15:08:30 2005 Author: mretzlaff Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.11 beirc/receivers.lisp:1.12 --- beirc/receivers.lisp:1.11 Mon Oct 3 01:47:51 2005 +++ beirc/receivers.lisp Wed Oct 5 15:08:29 2005 @@ -16,10 +16,14 @@ (slot-value object slot) something)) +;;; (defmethod print-object ((receiver receiver) stream) +;;; (print-unreadable-object (receiver stream :type t) +;;; (write-string (slot-value-or-something receiver :slot 'title :something "without title") +;;; stream))) +;;; We have the needed accept-methods for the presentation-type receiver, so we can just write: (defmethod print-object ((receiver receiver) stream) - (print-unreadable-object (receiver stream :type t) - (write-string (slot-value-or-something receiver :slot 'title :something "without title") - stream))) + (write-string (slot-value-or-something receiver :slot 'title :something "#<RECEIVER without title>") + stream)) (define-presentation-type receiver-pane ())

1 0

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

05 Oct '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv24914 Modified Files: application.lisp Log Message: Beirc's prompt is changed: After the the word "Beirc" now the current receiver's title is shown, and it will be presented as the current receiver (with the presentation-type RECEIVER). The presentation-translator RECEIVER-TO-CHANNEL-TRANSLATOR is added (with :tester and :documentation). A :tester is added to RECEIVER-PANE-TO-CHANNEL-TRANSLATOR. (Sadly, CLIM's presentation-translators seem not to be transitive, otherwise we could get rid of this presentation-translator.) Date: Wed Oct 5 05:39:14 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.30 beirc/application.lisp:1.31 --- beirc/application.lisp:1.30 Mon Oct 3 01:47:51 2005 +++ beirc/application.lisp Wed Oct 5 05:39:14 2005 @@ -136,9 +136,13 @@ (length (current-messages)))))) (defun beirc-prompt (*standard-output* *application-frame*) - (format *standard-output* "Beirc ~A => " - (or (current-query) - (current-channel)))) + (write-string "Beirc" *standard-output*) + (let ((receiver (current-receiver *application-frame*))) + (when receiver + (write-string " " *standard-output*) + (with-output-as-presentation (*standard-output* receiver 'receiver) + (write-string (title receiver) *standard-output*)))) + (write-string " => " *standard-output*)) ;; (defun format-message (prefix mumble) ;; (write-line @@ -599,10 +603,23 @@ :documentation ((object stream) (format stream "Channel: ~A" (channel (receiver-from-tab-pane - (find-in-tab-panes-list object 'tab-layout-pane)))))) + (find-in-tab-panes-list object 'tab-layout-pane))))) + :tester ((object) + (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 receiver-to-channel-translator + (receiver channel beirc + :documentation ((object stream) + (format stream "Channel: ~A" + (channel object))) + :tester ((object) + (channel object))) + (object) + (channel object)) (define-presentation-translator nickname-to-hostmask-translator (nickname hostmask beirc

1 0

[beirc-cvs] CVS update: beirc/message-display.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-serv3034 Modified Files: message-display.lisp Log Message: while I'm at it, refactor hostmask presenting into present-as-hostmask. Date: Mon Oct 3 01:52:32 2005 Author: afuchs Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.23 beirc/message-display.lisp:1.24 --- beirc/message-display.lisp:1.23 Mon Oct 3 01:48:45 2005 +++ beirc/message-display.lisp Mon Oct 3 01:52:32 2005 @@ -189,16 +189,21 @@ (format-message* (irc:trailing-argument message) :start-length (+ 8 (length (irc:source message)))))))) +(defun present-as-hostmask (user host) + (write-char #\() + (with-output-as-presentation (t (format nil "*!*@~A" host) 'hostmask) + (format t "~A@~A" user host)) + (write-char #\))) + (defmethod print-message ((message irc:irc-nick-message) receiver) (formatting-message (t message receiver) ((format t " ")) ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Nick change: ") (present (irc:source message) 'nickname) - (write-string " (") - (with-output-as-presentation (t (format nil "*!*@~A" (irc:host message)) 'hostmask) - (format t "~A@~A" (irc:user message) (irc:host message))) - (write-string ") is now known as ") + (write-string " ") + (present-as-hostmask (irc:user message) (irc:host message)) + (write-string " is now known as ") (present (irc:trailing-argument message) 'nickname))))) (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver) @@ -208,10 +213,9 @@ (destructuring-bind (me nickname user host &rest args) (irc:arguments message) (declare (ignore me args)) (present nickname 'nickname) - (format t " is (") - (with-output-as-presentation (t (format nil "*!*@~A" host) 'hostmask) - (format t "~A@~A" user host)) - (format t ") (~A)" (irc:trailing-argument message))))))) + (format t " is ") + (present-as-hostmask user host) + (format t " (~A)" (irc:trailing-argument message))))))) (defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver) (formatting-message (t message receiver) @@ -319,9 +323,7 @@ (format t "Join: ") (present (irc:source message) 'nickname) (write-char #\Space) - (with-output-as-presentation (t (format nil "*!*@~A" (irc:host message)) - 'hostmask) - (format t "(~A@~A)" (irc:user message) (irc:host message))))))) + (present-as-hostmask (irc:user message) (irc:host message)))))) (defmethod print-message ((message irc:irc-kick-message) receiver) (formatting-message (t message receiver)

1 0

[beirc-cvs] CVS update: beirc/message-display.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-serv3010 Modified Files: message-display.lisp Log Message: add a missing closing paren in a string. it's late (-: Date: Mon Oct 3 01:48:45 2005 Author: afuchs Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.22 beirc/message-display.lisp:1.23 --- beirc/message-display.lisp:1.22 Mon Oct 3 01:47:51 2005 +++ beirc/message-display.lisp Mon Oct 3 01:48:45 2005 @@ -198,7 +198,7 @@ (write-string " (") (with-output-as-presentation (t (format nil "*!*@~A" (irc:host message)) 'hostmask) (format t "~A@~A" (irc:user message) (irc:host message))) - (write-string " is now known as ") + (write-string ") is now known as ") (present (irc:trailing-argument message) 'nickname))))) (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver)

1 0