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@host combination now presents them as 'hostmask, with associated object *!*@<host> * 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")