[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Andreas Fuchs
afuchs at common-lisp.net
Sat Sep 24 19:03:16 UTC 2005
Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv18453
Modified Files:
beirc.lisp message-display.lisp
Log Message:
implement kicking & banning; reorder and group print-message methods
Date: Sat Sep 24 21:03:15 2005
Author: afuchs
Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.26 beirc/beirc.lisp:1.27
--- beirc/beirc.lisp:1.26 Sat Sep 24 20:14:28 2005
+++ beirc/beirc.lisp Sat Sep 24 21:03:14 2005
@@ -163,18 +163,29 @@
(define-global-message-receiver-lookup irc:irc-quit-message)
(define-global-message-receiver-lookup irc:irc-nick-message))
-(defmethod receiver-for-message ((message irc:irc-topic-message) frame)
- (intern-receiver (first (irc:arguments message)) frame :channel (first (irc:arguments message))))
+(macrolet ((define-nth-arg-message-receiver-lookup (&rest clauses)
+ "Defines receiver-for-message methods that return
+ the receiver associated with the nth arg of the
+ irc message or the trailing arg if NTH in the
+ clauses is nil.
-(defmethod receiver-for-message ((message irc:irc-rpl_topic-message) frame)
- (intern-receiver (second (irc:arguments message)) frame :channel (second (irc:arguments message))))
-
-(defmethod receiver-for-message ((message irc:irc-rpl_namreply-message) frame)
- (intern-receiver (third (irc:arguments message)) frame :channel (third (irc:arguments message))))
-
-(defmethod receiver-for-message ((message irc:irc-join-message) frame)
- (let ((target (irc:trailing-argument message)))
- (intern-receiver target frame :channel target)))
+ Each clause must have this format:
+ (nth message-type ...)"
+ `(progn
+ ,@(loop for (nth . messages) in clauses
+ do (print messages)
+ nconc (loop for message-type in messages
+ collect
+ `(defmethod receiver-for-message ((message ,message-type) frame)
+ (let ((target ,(if (numberp nth)
+ `(nth ,nth (irc:arguments message))
+ `(irc:trailing-argument message))))
+ (intern-receiver target frame :channel target))))))))
+ (define-nth-arg-message-receiver-lookup
+ (0 irc:irc-topic-message irc:irc-kick-message)
+ (1 irc:irc-rpl_topic-message)
+ (2 irc:irc-rpl_namreply-message)
+ (nil irc:irc-join-message)))
(defmethod receiver-for-message ((message irc:irc-part-message) frame)
(let ((target (first (irc:arguments message))))
@@ -440,6 +451,8 @@
(define-presentation-type nickname ())
(define-presentation-type unhighlighted-nickname () :inherit-from 'nickname)
(define-presentation-type ignored-nickname () :inherit-from 'nickname)
+(define-presentation-type channel () :inherit-from 'string)
+(define-presentation-type hostmask () :inherit-from 'string)
(defun hash-alist (hashtable &aux res)
(maphash (lambda (k v) (push (cons k v) res)) hashtable)
@@ -465,6 +478,11 @@
(receiver-from-tab-pane
(find-in-tab-panes-list object 'tab-layout-pane)))
+(define-presentation-translator nickname-to-hostmask-translator
+ (nickname hostmask beirc)
+ (object)
+ (format nil "*!*@~A" (irc:hostname (irc:find-user (current-connection *application-frame*) object))))
+
(defun nick-equals-my-nick-p (nickname)
(and (not (null *application-frame*))
(not (null (slot-value *application-frame* 'connection)))
@@ -483,8 +501,6 @@
(write-string o)))
(write-string o)))
-(define-presentation-type channel () :inherit-from 'string)
-
(define-presentation-method presentation-typep (object (type channel))
(channelp object))
@@ -567,6 +583,15 @@
(define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who"))
(irc:deop (current-connection *application-frame*) (target) who))
+(define-beirc-command (com-ban-nick :name t) ((who 'nickname :prompt "who"))
+ (irc:ban (current-connection *application-frame*) (target) (format nil "~A!*@*" who)))
+
+(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-names :name t) ()
(irc:names (current-connection *application-frame*) (target)))
@@ -662,8 +687,8 @@
(clim-sys:make-process #'(lambda ()
(unwind-protect
(irc-event-loop frame connection)
- (disconnect frame)))
- :name "IRC Message Muffling Loop")) )))))
+ (quit frame "IRC event loop terminated.")))
+ :name "IRC Message Muffling Loop")))))))
(defun disconnect (frame)
(raise-receiver (server-receiver frame))
Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.11 beirc/message-display.lisp:1.12
--- beirc/message-display.lisp:1.11 Sat Sep 24 20:13:44 2005
+++ beirc/message-display.lisp Sat Sep 24 21:03:15 2005
@@ -114,6 +114,8 @@
(incf column))
(terpri))
+;;; privmsg-like messages
+
(defun print-privmsg-like-message (message receiver start-string end-string)
(with-drawing-options
(*standard-output*
@@ -145,6 +147,22 @@
(format t " ")
(format-message* matter :start-length (+ 2 (length source)))))))
+;;; server messages
+
+(defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
+ (formatting-message (t message receiver)
+ ((format t "~A" (irc:source message)))
+ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+ (format t "MOTD: ~A" (irc:trailing-argument message))))))
+
+(defmethod print-message (message receiver)
+ (formatting-message (t message receiver)
+ ((format t "!!! ~A" (irc:source message)))
+ ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
+ (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))
+
+;;; user-related messages
+
(defmethod print-message ((message irc:irc-quit-message) receiver)
(formatting-message (t message receiver)
((format t " "))
@@ -155,22 +173,16 @@
(format-message* (irc:trailing-argument message)
:start-length (+ 8 (length (irc:source message))))))))
-(defmethod print-message ((message irc:irc-join-message) receiver)
- (formatting-message (t message receiver)
- ((format t " "))
- ((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))))))
-
(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)
- (format t " (~A@~A) is now known as " (irc:user message) (irc:host message))
- (present (irc:trailing-argument message) 'nickname)))))
+ ((format t " "))
+ ((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))
+ (present (irc:trailing-argument message) 'nickname)))))
+
+;;; channel management messages
(defun print-topic (receiver message sender channel topic)
(formatting-message (t message receiver)
@@ -205,6 +217,25 @@
(present (irc:source message) 'nickname)
(format t " 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)
+ ((format t " "))
+ ((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))))))
+
+(defmethod print-message ((message irc:irc-kick-message) receiver)
+ (formatting-message (t message receiver)
+ ((format t " "))
+ ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
+ (present (irc:source message) 'nickname)
+ (write-string " kicked ")
+ (present (second (irc:arguments message)) 'nickname)
+ (format-message* (format nil ": ~A" (irc:trailing-argument message))
+ :start-length (+ 9 (length (second (irc:arguments message)))
+ (length (irc:source message))))))))
+
(defmethod print-message ((message irc:irc-mode-message) receiver)
(case (length (irc:arguments message))
(1 (formatting-message (t message receiver)
@@ -221,17 +252,7 @@
(present (irc:source message) 'nickname)
(format-message* (format nil " set mode ~A ~A" modes args)))))))))
-(defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
- (formatting-message (t message receiver)
- ((format t "~A" (irc:source message)))
- ((with-drawing-options (*standard-output* :ink +gray33+ :text-size :small)
- (format t "MOTD: ~A" (irc:trailing-argument message))))))
-
-(defmethod print-message (message receiver)
- (formatting-message (t message receiver)
- ((format t "!!! ~A" (irc:source message)))
- ((with-drawing-options (*standard-output* :ink +red+ :text-size :small)
- (format t "args: ~A :~A" (irc:arguments message) (irc:trailing-argument message))))))
+;;; the display function (& utilities)
(defgeneric preamble-length (message)
(:method ((message irc:irc-privmsg-message))
@@ -247,30 +268,4 @@
maximize (preamble-length message))))
(formatting-table (t)
(loop for message in messages
- do (print-message message receiver)))))
-
-
-#|
- (let ((k 100)
- (n (length messages)))
- (loop for i below (* k (ceiling n k)) by k do
- (updating-output (*standard-output*
- :unique-id i
- :cache-value
- (list (min n (+ i k))
- (focused-nicks receiver)
- (slot-value *application-frame* 'ignored-nicks)
- w)
- :cache-test #'equal)
- (loop for j from i below (min n (+ i k)) do
- (let ((m (elt messages j)))
- (updating-output (*standard-output*
- :unique-id j
- :cache-value
- (list m
- (focused-nicks receiver)
- (slot-value *application-frame* 'ignored-nicks)
- w)
- :cache-test #'equal)
- (print-message m receiver)))))))
-|#
\ No newline at end of file
+ do (print-message message receiver)))))
\ No newline at end of file
More information about the Beirc-cvs
mailing list