From afuchs at common-lisp.net Sat Oct 1 18:18:51 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sat, 1 Oct 2005 20:18:51 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/presentations.lisp Message-ID: <20051001181851.10D438855D@common-lisp.net> 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))) From mretzlaff at common-lisp.net Sun Oct 2 04:01:33 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Sun, 2 Oct 2005 06:01:33 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051002040133.887678855D@common-lisp.net> 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) From mretzlaff at common-lisp.net Sun Oct 2 04:18:26 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Sun, 2 Oct 2005 06:18:26 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/receivers.lisp Message-ID: <20051002041826.85FBA8855D@common-lisp.net> 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) From afuchs at common-lisp.net Sun Oct 2 08:25:38 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 2 Oct 2005 10:25:38 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051002082538.BD8598853E@common-lisp.net> 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) From afuchs at common-lisp.net Sun Oct 2 08:30:42 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 2 Oct 2005 10:30:42 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/variables.lisp Message-ID: <20051002083042.79AD48853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv3317 Modified Files: application.lisp variables.lisp Log Message: Make the web browser program customizable. Date: Sun Oct 2 10:30:41 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.20 beirc/application.lisp:1.21 --- beirc/application.lisp:1.20 Sun Oct 2 10:25:37 2005 +++ beirc/application.lisp Sun Oct 2 10:30:41 2005 @@ -388,14 +388,10 @@ (irc:nick (current-connection *application-frame*) new-nick)) (define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url")) - #+ (and sbcl darwin) - (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil) - #+ (and openmcl darwin) - (ccl:run-program "/usr/bin/open" `(,url) :wait nil) - ;; XXX: daring assumption. perhaps this should use x-www-browser on - ;; debian/debian systems? - #+ (and sbcl linux) - (sb-ext:run-program "/usr/bin/x-www-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)) (define-presentation-to-command-translator nickname-to-ignore-translator (nickname com-ignore beirc Index: beirc/variables.lisp diff -u beirc/variables.lisp:1.3 beirc/variables.lisp:1.4 --- beirc/variables.lisp:1.3 Sun Sep 25 20:57:25 2005 +++ beirc/variables.lisp Sun Oct 2 10:30:41 2005 @@ -4,6 +4,9 @@ (defvar *default-fill-column* 80) (defvar *timestamp-column-orientation* :right) (defvar *default-nick* (format nil "Brucio-~d" (random 100))) +(defvar *default-web-browser* #+darwin "/usr/bin/open" + ;; assuming a debian system running X: + #+linux "/usr/bin/x-www-browser") (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") (user-homedir-pathname))) From afuchs at common-lisp.net Sun Oct 2 08:42:21 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 2 Oct 2005 10:42:21 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/variables.lisp Message-ID: <20051002084221.5A59E8853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv3895 Modified Files: application.lisp variables.lisp Log Message: Load the user init file when beirc is started, not when loaded. also add a com-reload command. Date: Sun Oct 2 10:42:20 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.21 beirc/application.lisp:1.22 --- beirc/application.lisp:1.21 Sun Oct 2 10:30:41 2005 +++ beirc/application.lisp Sun Oct 2 10:42:20 2005 @@ -190,10 +190,11 @@ (redisplay-frame-pane *application-frame* pane))) (defun redraw-all-receivers () - (maphash (lambda (name receiver) - (declare (ignore name)) - (redraw-receiver receiver)) - (receivers *application-frame*))) + (when (boundp '*application-frame*) + (maphash (lambda (name receiver) + (declare (ignore name)) + (redraw-receiver receiver)) + (receivers *application-frame*)))) (defmethod handle-event ((frame beirc) (event foo-event)) ;; Hack: @@ -225,6 +226,7 @@ (ticker-process (clim-sys:make-process (lambda () (ticker frame)) :name "Beirc Ticker"))) (setf *beirc-frame* frame) + (load-user-init-file) (run-frame-top-level frame) (unless (null (current-connection frame)) (irc:quit (current-connection frame) "Client Quit")) @@ -261,6 +263,13 @@ (clim-internals::event-queue-prepend (climi::frame-event-queue frame) (make-instance 'bar-event :sheet frame)) (sleep 1))) + +(defun load-user-init-file (&optional (pathname *beirc-user-init-file*)) + (load pathname) + (redraw-all-receivers)) + +(define-beirc-command (com-reload :name t) () + (load-user-init-file)) (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) (raise-receiver (intern-receiver nick *application-frame* :query nick))) Index: beirc/variables.lisp diff -u beirc/variables.lisp:1.4 beirc/variables.lisp:1.5 --- beirc/variables.lisp:1.4 Sun Oct 2 10:30:41 2005 +++ beirc/variables.lisp Sun Oct 2 10:42:20 2005 @@ -9,7 +9,4 @@ #+linux "/usr/bin/x-www-browser") (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") - (user-homedir-pathname))) - -(when (probe-file *beirc-user-init-file*) - (load *beirc-user-init-file*)) \ No newline at end of file + (user-homedir-pathname))) \ No newline at end of file From afuchs at common-lisp.net Sun Oct 2 08:59:24 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 2 Oct 2005 10:59:24 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/variables.lisp Message-ID: <20051002085924.10D878853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv4986 Modified Files: application.lisp variables.lisp Log Message: add variable *auto-join-channels*. On /connect or /reload, joins the channels corresponding to the server name. Date: Sun Oct 2 10:59:24 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.22 beirc/application.lisp:1.23 --- beirc/application.lisp:1.22 Sun Oct 2 10:42:20 2005 +++ beirc/application.lisp Sun Oct 2 10:59:23 2005 @@ -190,7 +190,8 @@ (redisplay-frame-pane *application-frame* pane))) (defun redraw-all-receivers () - (when (boundp '*application-frame*) + (when (and (boundp '*application-frame*) + (not (null *application-frame*))) (maphash (lambda (name receiver) (declare (ignore name)) (redraw-receiver receiver)) @@ -264,9 +265,19 @@ (make-instance 'bar-event :sheet frame)) (sleep 1))) +(defun join-missing-channels (frame) + (let* ((connection (current-connection frame)) + (server (irc:server-name connection))) + (loop for join-channel in (cdr (assoc server *auto-join-alist* :test #'equal)) + do (unless (gethash join-channel (receivers frame)) + (irc:join connection join-channel))))) + (defun load-user-init-file (&optional (pathname *beirc-user-init-file*)) - (load pathname) - (redraw-all-receivers)) + (when (probe-file *beirc-user-init-file*) + (let ((*package* #.*package*)) + (load pathname)) + (join-missing-channels *application-frame*) + (redraw-all-receivers))) (define-beirc-command (com-reload :name t) () (load-user-init-file)) @@ -545,6 +556,7 @@ (loop for receiver being the hash-values of (receivers frame) if (channelp (channel receiver)) do (irc:join connection (channel receiver))) + (join-missing-channels frame) (initialize-receiver-with-pane (server-receiver frame) frame (find-pane-named frame 'server) :add-pane-p nil) Index: beirc/variables.lisp diff -u beirc/variables.lisp:1.5 beirc/variables.lisp:1.6 --- beirc/variables.lisp:1.5 Sun Oct 2 10:42:20 2005 +++ beirc/variables.lisp Sun Oct 2 10:59:23 2005 @@ -7,6 +7,9 @@ (defvar *default-web-browser* #+darwin "/usr/bin/open" ;; assuming a debian system running X: #+linux "/usr/bin/x-www-browser") +(defvar *auto-join-alist* (("irc.freenode.net" . ("#beirc"))) + "An alist mapping irc server name to a list of channels to + automatically join on connect.") (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") (user-homedir-pathname))) From afuchs at common-lisp.net Sun Oct 2 09:14:17 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 2 Oct 2005 11:14:17 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051002091417.6DF158853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv6047 Modified Files: application.lisp Log Message: small bug fix to load-user-init-file: use pathname consistently; don't try to redraw an *a-f* that isn't there. Date: Sun Oct 2 11:14:17 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.23 beirc/application.lisp:1.24 --- beirc/application.lisp:1.23 Sun Oct 2 10:59:23 2005 +++ beirc/application.lisp Sun Oct 2 11:14:16 2005 @@ -272,12 +272,13 @@ do (unless (gethash join-channel (receivers frame)) (irc:join connection join-channel))))) -(defun load-user-init-file (&optional (pathname *beirc-user-init-file*)) - (when (probe-file *beirc-user-init-file*) +(defun load-user-init-file (&key (pathname *beirc-user-init-file*)) + (when (probe-file pathname) (let ((*package* #.*package*)) (load pathname)) - (join-missing-channels *application-frame*) - (redraw-all-receivers))) + (when *application-frame* + (join-missing-channels *application-frame*) + (redraw-all-receivers)))) (define-beirc-command (com-reload :name t) () (load-user-init-file)) From afuchs at common-lisp.net Sun Oct 2 09:30:21 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 2 Oct 2005 11:30:21 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/package.lisp beirc/variables.lisp Message-ID: <20051002093021.287608853E@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv7060 Modified Files: application.lisp package.lisp variables.lisp Log Message: add variable *nickserv-password-alist* and command /identify. export variable names. Date: Sun Oct 2 11:30:19 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.24 beirc/application.lisp:1.25 --- beirc/application.lisp:1.24 Sun Oct 2 11:14:16 2005 +++ beirc/application.lisp Sun Oct 2 11:30:19 2005 @@ -283,6 +283,17 @@ (define-beirc-command (com-reload :name t) () (load-user-init-file)) +(define-beirc-command (com-identify :name t) (&key + (password 'string :prompt "Password" + :default (cdr (assoc (irc:server-name (current-connection *application-frame*)) + *nickserv-password-alist* + :test #'equal))) + (who 'nickname :prompt "Target" :default "NickServ")) + (when (null password) + (accept 'string :prompt "Password")) + (irc:privmsg (current-connection *application-frame*) who + (format nil "IDENTIFY ~A" password))) + (define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who")) (raise-receiver (intern-receiver nick *application-frame* :query nick))) @@ -396,7 +407,7 @@ (current-channel))) (define-beirc-command (com-say :name t) ((what 'mumble)) - (unless (string= what "") + (unless (or (string= what "") (null (target))) (post-message *application-frame* (make-fake-irc-message 'irc:irc-privmsg-message :trailing-argument what Index: beirc/package.lisp diff -u beirc/package.lisp:1.3 beirc/package.lisp:1.4 --- beirc/package.lisp:1.3 Sun Sep 25 14:55:10 2005 +++ beirc/package.lisp Sun Oct 2 11:30:19 2005 @@ -1,4 +1,7 @@ (cl:defpackage :beirc (:use :clim :clim-lisp :clim-sys :tab-layout) (:export #:beirc - #:*hyperspec-base-url* #:*default-fill-column* #:*timestamp-column-orientation*)) + #:*beirc-user-init-file* + #:*hyperspec-base-url* #:*default-fill-column* #:*timestamp-column-orientation* + #:*default-nick* #:*nickserv-password-alist* #:*default-web-browser + #:*auto-join-alist*)) Index: beirc/variables.lisp diff -u beirc/variables.lisp:1.6 beirc/variables.lisp:1.7 --- beirc/variables.lisp:1.6 Sun Oct 2 10:59:23 2005 +++ beirc/variables.lisp Sun Oct 2 11:30:19 2005 @@ -7,9 +7,13 @@ (defvar *default-web-browser* #+darwin "/usr/bin/open" ;; assuming a debian system running X: #+linux "/usr/bin/x-www-browser") -(defvar *auto-join-alist* (("irc.freenode.net" . ("#beirc"))) +(defvar *auto-join-alist* '(("irc.freenode.net" . ("#beirc"))) "An alist mapping irc server name to a list of channels to automatically join on connect.") + +(defvar *nickserv-password-alist* '() + "Default password to send to the NickServ authentication bot") + (defvar *beirc-user-init-file* (merge-pathnames (make-pathname :name ".beirc.lisp") (user-homedir-pathname))) From mretzlaff at common-lisp.net Sun Oct 2 17:34:22 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Sun, 2 Oct 2005 19:34:22 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051002173422.3DBC3880E6@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv9481 Modified Files: application.lisp Log Message: Adds COM-WINDOW-NEXT and COM-WINDOW-PREVIOUS. The keystrokes do not yet work (and are uncommented). I hope this will be changed soon. (Also TAB-LAYOUT:ENABLED-PANE will perhaps be changed; an application that uses the tab-layout-pane should really not get in touch with objects of the class TAB-LAYOUT::TAB-PANE itself...) Date: Sun Oct 2 19:34:18 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.25 beirc/application.lisp:1.26 --- beirc/application.lisp:1.25 Sun Oct 2 11:30:19 2005 +++ beirc/application.lisp Sun Oct 2 19:34:15 2005 @@ -300,6 +300,28 @@ (define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver")) (raise-receiver receiver)) +(define-beirc-command (com-window-next :name t);; :keystroke (:right :meta)) + () + (let* ((current-pane (tab-layout::tab-pane-pane + (enabled-pane (find-pane-named *application-frame* 'query)))) + (list-of-panes (sheet-children (sheet-parent current-pane))) + (position (position current-pane list-of-panes))) + (when list-of-panes + (if (>= position (1- (length list-of-panes))) + (switch-to-pane (car list-of-panes) 'tab-layout-pane) + (switch-to-pane (nth (1+ position) list-of-panes) 'tab-layout-pane))))) + +(define-beirc-command (com-window-previous :name t);; :keystroke (:left :meta)) + () + (let* ((current-pane (tab-layout::tab-pane-pane + (enabled-pane (find-pane-named *application-frame* 'query)))) + (list-of-panes (sheet-children (sheet-parent current-pane))) + (position (position current-pane list-of-panes))) + (when list-of-panes + (if (<= position 0) + (switch-to-pane (car (last list-of-panes)) 'tab-layout-pane) + (switch-to-pane (nth (1- position) list-of-panes) 'tab-layout-pane))))) + (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) (when (eql receiver (server-receiver *application-frame*)) (error "Can't close the server tab for this application!")) From mretzlaff at common-lisp.net Sun Oct 2 21:39:08 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Sun, 2 Oct 2005 23:39:08 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051002213908.CF96A880E6@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv25833 Modified Files: application.lisp Log Message: Bugfix for JOIN-MISSING-CHANNELS: Try only to connect to the channels if the current *application-frame* is already connected to an IRC server. Drops the call to TIME in handle-event ((frame beirc) (event foo-event)). Date: Sun Oct 2 23:39:07 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.26 beirc/application.lisp:1.27 --- beirc/application.lisp:1.26 Sun Oct 2 19:34:15 2005 +++ beirc/application.lisp Sun Oct 2 23:39:07 2005 @@ -204,7 +204,7 @@ (pane (actual-application-pane (pane receiver)))) (let ((btmp (pane-scrolled-to-bottom-p pane))) (setf (pane-needs-redisplay pane) t) - (time (redisplay-frame-panes frame)) + (redisplay-frame-panes frame) (when btmp (scroll-pane-to-bottom pane))) (medium-force-output (sheet-medium pane)) ;### )) @@ -267,10 +267,11 @@ (defun join-missing-channels (frame) (let* ((connection (current-connection frame)) - (server (irc:server-name connection))) - (loop for join-channel in (cdr (assoc server *auto-join-alist* :test #'equal)) + (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)) - (irc:join connection join-channel))))) + (irc:join connection join-channel)))))) (defun load-user-init-file (&key (pathname *beirc-user-init-file*)) (when (probe-file pathname) From mretzlaff at common-lisp.net Sun Oct 2 21:57:19 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Sun, 2 Oct 2005 23:57:19 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051002215719.E2911880E6@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv26898 Modified Files: application.lisp Log Message: Changes the size of the interactor from 60 pixels to 68. This seems to be the minimum size dictated by the scrollbar. It solves the the "half input line"-problem (the easy way)... Date: Sun Oct 2 23:57:19 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.27 beirc/application.lisp:1.28 --- beirc/application.lisp:1.27 Sun Oct 2 23:39:07 2005 +++ beirc/application.lisp Sun Oct 2 23:57:19 2005 @@ -106,7 +106,7 @@ (vertically () (with-tab-layout ('receiver-pane :name 'query) ("*Server*" server 'receiver-pane)) - (60 io) + (68 io) (20 pointer-doc) (20 ;<-- Sigh! Bitrot! status-bar))))) From mretzlaff at common-lisp.net Sun Oct 2 22:40:55 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Mon, 3 Oct 2005 00:40:55 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051002224055.D71E8880E6@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv30389 Modified Files: application.lisp Log Message: NICKNAME-TO-IGNORE-TRANSLATOR, NICKNAME-TO-FOCUS-TRANSLATOR, and NICKNAME-TO-UNFOCUS-TRANSLATOR have now :TESTERs; so you can only FOCUS someone if he/she/it is not focused yet, and UNFOCUS only if the enitity is currently focused. There is also a NICKNAME-TO-UNIGNORE-TRANSLATOR now. Useful to UNIGNORE via the /names list. Date: Mon Oct 3 00:40:55 2005 Author: mretzlaff Index: beirc/application.lisp diff -u beirc/application.lisp:1.28 beirc/application.lisp:1.29 --- beirc/application.lisp:1.28 Sun Oct 2 23:57:19 2005 +++ beirc/application.lisp Mon Oct 3 00:40:54 2005 @@ -453,7 +453,23 @@ :gesture :menu :menu t :documentation "Ignore this user" - :pointer-documentation "Ignore this user") + :pointer-documentation "Ignore this user" + :tester ((object) + (not (find object (slot-value *application-frame* 'ignored-nicks) + :test 'string-equal)))) + + (object) + (list object)) + +(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" + :tester ((object) + (find object (slot-value *application-frame* 'ignored-nicks) + :test 'string-equal))) (object) (list object)) @@ -462,7 +478,10 @@ :gesture :menu :menu t :documentation "Focus this user" - :pointer-documentation "Focus this user") + :pointer-documentation "Focus this user" + :tester ((object) + (not (find object (current-focused-nicks) + :test 'string-equal)))) (object) (list object)) @@ -471,7 +490,10 @@ :gesture :menu :menu t :documentation "Unfocus this user" - :pointer-documentation "Unfocus this user") + :pointer-documentation "Unfocus this user" + :tester ((object) + (find object (current-focused-nicks) + :test 'string-equal))) (object) (list object)) @@ -562,10 +584,9 @@ (nickname hostmask beirc :tester ((object context-type) (declare (ignore object)) - (presentation-subtypep context-type 'hostmask))) + (presentation-subtypep context-type 'hostmask))) (object) (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object)))) - (define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel")) (raise-receiver (intern-receiver channel *application-frame* :channel channel)) From afuchs at common-lisp.net Sun Oct 2 23:47:53 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 3 Oct 2005 01:47:53 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/receivers.lisp beirc/variables.lisp Message-ID: <20051002234753.1E03E880E6@common-lisp.net> Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv2022 Modified Files: application.lisp message-display.lisp receivers.lisp variables.lisp Log Message: Add various hostmask and mode change related features: * every display method that shows a user at host combination now presents them as 'hostmask, with associated object *!*@ * add a mode message destructuring mechanism that knows about hostmasks, numbers and nicknames and presents them nicely. * add an unban hostmask command & hostmask-to-*-translator. Date: Mon Oct 3 01:47:51 2005 Author: afuchs Index: beirc/application.lisp diff -u beirc/application.lisp:1.29 beirc/application.lisp:1.30 --- beirc/application.lisp:1.29 Mon Oct 3 00:40:54 2005 +++ beirc/application.lisp Mon Oct 3 01:47:51 2005 @@ -401,6 +401,12 @@ (define-beirc-command (com-ban-hostmask :name t) ((who 'hostmask :prompt "hostmask")) (irc:ban (current-connection *application-frame*) (target) who)) +(define-beirc-command (com-unban-hostmask :name t) ((who 'hostmask :prompt "hostmask")) + (irc:unban (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-unban-nick :name t) ((who 'nickname :prompt "who")) + (irc:unban (current-connection *application-frame*) (target) (format nil "~A!*@*" 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)) @@ -525,6 +531,24 @@ :menu t :documentation "Ban this user's nickname" :pointer-documentation "Ban this user's nickname") + (object) + (list object)) + +(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") + (object) + (list object)) + +(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") (object) (list object)) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.21 beirc/message-display.lisp:1.22 --- beirc/message-display.lisp:1.21 Wed Sep 28 21:33:28 2005 +++ beirc/message-display.lisp Mon Oct 3 01:47:51 2005 @@ -195,7 +195,10 @@ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Nick change: ") (present (irc:source message) 'nickname) - (format t " (~A@~A) is now known as " (irc:user message) (irc:host message)) + (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 ") (present (irc:trailing-argument message) 'nickname))))) (defmethod print-message ((message irc:irc-rpl_whoisuser-message) receiver) @@ -205,7 +208,10 @@ (destructuring-bind (me nickname user host &rest args) (irc:arguments message) (declare (ignore me args)) (present nickname 'nickname) - (format t " is (~A@~A) (~A)" user host (irc:trailing-argument message))))))) + (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))))))) (defmethod print-message ((message irc:irc-rpl_whoischannels-message) receiver) (formatting-message (t message receiver) @@ -312,7 +318,10 @@ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) (format t "Join: ") (present (irc:source message) 'nickname) - (format t " (~A@~A)" (irc:user message) (irc:host message)))))) + (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))))))) (defmethod print-message ((message irc:irc-kick-message) receiver) (formatting-message (t message receiver) @@ -325,21 +334,59 @@ :start-length (+ 9 (length (second (irc:arguments message))) (length (irc:source message)))))))) +;;; XXX: uses unexported symbols from cl-irc, but I think their +;;; unexportedness is accidental. +(defun mode-symbol-to-char (target mode) + (irc::mode-desc-char + (irc::mode-description (current-connection *application-frame*) + target mode))) + +(defmethod print-mode-change (target op mode (user irc:user)) + (format t "~A~A:" op (mode-symbol-to-char target mode)) + (present (irc:nickname user) 'nickname)) + +(defmethod print-mode-change (target op (mode (eql :limit)) arg) + (format t "~A~A" op (mode-symbol-to-char target mode)) + (when (not (null arg)) + (write-char #\:) + (present arg 'number))) + +(macrolet ((define-mode-change-with-hostmask-printer (&rest modes) + `(progn + ,@(loop for mode in modes + collect `(defmethod print-mode-change (target op (mode (eql ,mode)) mask) + (format t "~A~A:" op (mode-symbol-to-char target mode)) + (present mask 'hostmask)))))) + (define-mode-change-with-hostmask-printer :ban :invite :except)) + +(defmethod print-mode-change (target op mode (arg (eql nil))) + (format t "~A~A" op (mode-symbol-to-char target mode))) + (defmethod print-message ((message irc:irc-mode-message) receiver) (case (length (irc:arguments message)) (1 (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (format-message* (format nil "~A set mode ~A ~A" (irc:source message) - (irc:trailing-argument message) - (first (irc:arguments message)))))))) - (3 (destructuring-bind (target modes args) (irc:arguments message) - (declare (ignore target)) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (format-message* (format nil "~A set mode ~A ~A" (irc:source message) + (irc:trailing-argument message) + (first (irc:arguments message)))))))) + (t + (destructuring-bind (target &rest args) (irc:arguments message) + (let* ((connection (current-connection *application-frame*)) + (target (or (irc:find-user connection target) + (irc:find-channel connection target))) + (mode-changes (irc:parse-mode-arguments connection target args + :server-p (irc:user connection)))) (formatting-message (t message receiver) - ((format t " ")) - ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) - (present (irc:source message) 'nickname) - (format-message* (format nil " set mode ~A ~A" modes args))))))))) + ((format t " ")) + ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small) + (present (irc:source message) 'nickname) + (write-string " changes channel mode: ") + (loop for (change . rest) on mode-changes + do (destructuring-bind (op mode &optional arg) change + (print-mode-change target op mode arg)) + if (not (null rest)) + do (write-string ", ")))))))))) ;;; the display function (& utilities) Index: beirc/receivers.lisp diff -u beirc/receivers.lisp:1.10 beirc/receivers.lisp:1.11 --- beirc/receivers.lisp:1.10 Sun Oct 2 06:18:24 2005 +++ beirc/receivers.lisp Mon Oct 3 01:47:51 2005 @@ -168,7 +168,7 @@ (defmethod receiver-for-message ((message irc:irc-mode-message) frame) (case (length (irc:arguments message)) (1 (server-receiver frame)) - (3 (destructuring-bind (channel modes args) (irc:arguments message) + (t (destructuring-bind (channel modes &rest args) (irc:arguments message) (declare (ignore modes args)) (intern-receiver channel frame :channel channel))))) Index: beirc/variables.lisp diff -u beirc/variables.lisp:1.7 beirc/variables.lisp:1.8 --- beirc/variables.lisp:1.7 Sun Oct 2 11:30:19 2005 +++ beirc/variables.lisp Mon Oct 3 01:47:51 2005 @@ -7,9 +7,12 @@ (defvar *default-web-browser* #+darwin "/usr/bin/open" ;; assuming a debian system running X: #+linux "/usr/bin/x-www-browser") + (defvar *auto-join-alist* '(("irc.freenode.net" . ("#beirc"))) "An alist mapping irc server name to a list of channels to - automatically join on connect.") + automatically join on connect. Each element should have this + format: + (\"server-name\" . (\"#channel-name\" \"#channel2\" \"#channel3\"))") (defvar *nickserv-password-alist* '() "Default password to send to the NickServ authentication bot") From afuchs at common-lisp.net Sun Oct 2 23:48:46 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 3 Oct 2005 01:48:46 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp Message-ID: <20051002234846.41AC3880E6@common-lisp.net> 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) From afuchs at common-lisp.net Sun Oct 2 23:52:33 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Mon, 3 Oct 2005 01:52:33 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp Message-ID: <20051002235233.7AF2E880E6@common-lisp.net> 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) From mretzlaff at common-lisp.net Wed Oct 5 03:39:15 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Wed, 5 Oct 2005 05:39:15 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051005033915.3F02E885C5@common-lisp.net> 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 From mretzlaff at common-lisp.net Wed Oct 5 13:08:33 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Wed, 5 Oct 2005 15:08:33 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/receivers.lisp Message-ID: <20051005130833.BD4508855F@common-lisp.net> 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 "#") + stream)) (define-presentation-type receiver-pane ()) From mretzlaff at common-lisp.net Wed Oct 5 13:21:36 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Wed, 5 Oct 2005 15:21:36 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051005132136.E54E98855F@common-lisp.net> 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 From mretzlaff at common-lisp.net Wed Oct 5 13:26:04 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Wed, 5 Oct 2005 15:26:04 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp Message-ID: <20051005132604.A52FF885B2@common-lisp.net> 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 From mretzlaff at common-lisp.net Thu Oct 6 23:35:21 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Fri, 7 Oct 2005 01:35:21 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/message-display.lisp Message-ID: <20051006233521.9E226885A2@common-lisp.net> 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) From mretzlaff at common-lisp.net Fri Oct 7 00:03:16 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Fri, 7 Oct 2005 02:03:16 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051007000316.DC5BD885A2@common-lisp.net> 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) ) - From mretzlaff at common-lisp.net Fri Oct 7 00:59:58 2005 From: mretzlaff at common-lisp.net (Max-Gerd Retzlaff) Date: Fri, 7 Oct 2005 02:59:58 +0200 (CEST) Subject: [beirc-cvs] CVS update: beirc/application.lisp Message-ID: <20051007005958.C7267885B0@common-lisp.net> 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)