[beirc-cvs] CVS update: beirc/application.lisp beirc/message-display.lisp beirc/receivers.lisp beirc/variables.lisp
Andreas Fuchs
afuchs at common-lisp.net
Sun Oct 2 23:47:53 UTC 2005
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 *!*@<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")
More information about the Beirc-cvs
mailing list