[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
Andreas Fuchs
afuchs at common-lisp.net
Sat Sep 24 17:28:39 UTC 2005
Update of /project/beirc/cvsroot/beirc
In directory common-lisp.net:/tmp/cvs-serv11001
Modified Files:
beirc.lisp message-display.lisp
Log Message:
* refactor message faking
* fix display of irc-MODE-messages that deal with user modes
* rework /topic to display the topic if no string is passed
* add presentation type CHANNEL and an accept method so that /join
doesn't do stupid things anymore on empty input.
* add minimal receiver closing functionality.
Date: Sat Sep 24 19:28:38 2005
Author: afuchs
Index: beirc/beirc.lisp
diff -u beirc/beirc.lisp:1.22 beirc/beirc.lisp:1.23
--- beirc/beirc.lisp:1.22 Sat Sep 24 17:04:06 2005
+++ beirc/beirc.lisp Sat Sep 24 19:28:38 2005
@@ -121,6 +121,10 @@
(setf (gethash name (receivers frame)) receiver)
receiver)))))
+(defun remove-receiver (receiver frame)
+ (remove-pane (tab-pane receiver) (find-pane-named frame 'query))
+ (remhash (title receiver) (receivers frame)))
+
(defparameter *network-service-sources* '("nickserv" "memoserv" "chanserv" "")
"Sources whose private messages (PRIVMSG, NOTICE, ...) should
be treated as if they came from the connected server itself,
@@ -177,9 +181,11 @@
(intern-receiver target frame :channel target)))
(defmethod receiver-for-message ((message irc:irc-mode-message) frame)
- (destructuring-bind (channel modes args) (irc:arguments message)
- (declare (ignore modes args))
- (intern-receiver channel frame :channel channel)))
+ (case (length (irc:arguments message))
+ (1 (server-receiver frame))
+ (3 (destructuring-bind (channel modes args) (irc:arguments message)
+ (declare (ignore modes args))
+ (intern-receiver channel frame :channel channel)))))
(macrolet ((define-ignore-message-types (&rest mtypes)
`(progn
@@ -244,7 +250,6 @@
;;; KLUDGE: workaround for mcclim bug "Application pane vertical
;;; scrolling does not work with table formatting"
-
(defclass redisplay-frame-mixin ()
())
@@ -469,12 +474,31 @@
(format t "~A" o)))
(format t "~A" o)))
+(define-presentation-type channel () :inherit-from 'string)
+
+(define-presentation-method presentation-typep (object (type channel))
+ (channelp object))
+
+(defun channelp (channel)
+ (and (stringp channel)
+ (> (length channel) 2)
+ (not (null (member (char channel 0) '(#\# #\+ #\! #\&))))))
+
+(define-presentation-method accept ((type channel) *standard-input* (view textual-view) &key)
+ (let ((channel (accept 'string :view view :prompt nil)))
+ (if (not (presentation-typep channel 'channel))
+ (input-not-of-required-type channel 'channel)
+ channel)))
+
(define-beirc-command (com-query :name t) ((nick 'nickname :prompt "who"))
(raise-receiver (intern-receiver nick *application-frame* :query nick)))
(define-beirc-command (com-raise :name t) ((receiver 'receiver :prompt "receiver"))
(raise-receiver receiver))
+(define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver"))
+ (remove-receiver receiver *application-frame*))
+
(define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who"))
(pushnew who (current-focused-nicks) :test #'string=))
@@ -495,8 +519,30 @@
(when (eql status :external)
(apply symbol (current-connection *application-frame*) (coerce args 'list)))))
-(define-beirc-command (com-topic :name t) ((topic 'mumble :prompt "topic"))
- (irc:topic- (current-connection *application-frame*) (target) topic))
+(defun make-fake-irc-message (message-type &key command arguments
+ (source (slot-value *application-frame* 'nick))
+ trailing-argument)
+ (make-instance message-type
+ :received-time (get-universal-time)
+ :connection :local
+ :trailing-argument trailing-argument
+ :arguments arguments
+ :command command
+ :HOST "localhost"
+ :USER "localuser"
+ :SOURCE source))
+
+(define-beirc-command (com-topic :name t) (&key (topic 'mumble :prompt "New topic"))
+ (if (and (not (string= topic "")))
+ (irc:topic- (current-connection *application-frame*) (target) topic)
+ (post-message *application-frame*
+ (make-fake-irc-message 'irc:irc-rpl_topic-message
+ :command "332"
+ :arguments `("=" ,(target))
+ :trailing-argument (irc:topic
+ (irc:find-channel
+ (current-connection *application-frame*)
+ (target)))))))
(define-beirc-command (com-op :name t) ((who 'nickname :prompt "who"))
(irc:op (current-connection *application-frame*) (target) who))
@@ -523,16 +569,10 @@
(define-beirc-command (com-say :name t) ((what 'mumble))
;; make a fake IRC-PRIV-MESSAGE object
(post-message *application-frame*
- (make-instance 'irc:irc-privmsg-message
- :received-time (get-universal-time)
- :connection :local
- :trailing-argument what
- :arguments (list (target))
- :command "PRIVMSG"
- :HOST "localhost"
- :USER "localuser"
- :SOURCE (slot-value *application-frame* 'nick)
- ))
+ (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-nick :name t) ((new-nick 'string :prompt "new nick"))
@@ -581,7 +621,7 @@
(presentation)
(list (presentation-object presentation)))
-(define-beirc-command (com-join :name t) ((channel 'string :prompt "channel"))
+(define-beirc-command (com-join :name t) ((channel 'channel :prompt "channel"))
(raise-receiver (intern-receiver channel *application-frame* :channel channel))
(irc:join (current-connection *application-frame*) channel))
@@ -609,26 +649,18 @@
:name "IRC Message Muffling Loop")) )))))
(defun disconnect (frame)
- (let ((old-nickname (slot-value frame 'nick)))
- (raise-receiver (server-receiver frame))
- (post-message frame
- (make-instance 'irc:irc-quit-message
- :received-time (get-universal-time)
- :connection :local
- :trailing-argument
- (format nil "You disconnected from IRC")
- :arguments nil
- :command "QUIT"
- :host "localhost" ;###
- :user "localuser" ;###
- :source old-nickname))
- (when (and (connection-process frame)
- (not (eql (clim-sys:current-process)
- (connection-process frame))))
- (destroy-process (connection-process frame)))
- (setf (slot-value frame 'connection) nil
- (connection-process frame) nil
- (slot-value frame 'nick) nil)))
+ (raise-receiver (server-receiver frame))
+ (post-message frame
+ (make-fake-irc-message 'irc:irc-quit-message
+ :trailing-argument "You disconnected from IRC"
+ :command "QUIT"))
+ (when (and (connection-process frame)
+ (not (eql (clim-sys:current-process)
+ (connection-process frame))))
+ (destroy-process (connection-process frame)))
+ (setf (slot-value frame 'connection) nil
+ (connection-process frame) nil
+ (slot-value frame 'nick) nil))
(defun quit (frame reason)
(raise-receiver (server-receiver frame))
@@ -725,32 +757,22 @@
(write-char (read-char) bag)))))))
(define-beirc-command (com-me :name t) ((what 'mumble))
- (with-slots (connection nick) *application-frame*
- (let ((m (make-instance 'irc:ctcp-action-message
- :received-time (get-universal-time)
- :connection :local
- :trailing-argument
- (format nil "~AACTION ~A~A" (code-char 1) what (code-char 1))
- :arguments (list (target))
- :command "PRIVMSG"
- :host "localhost" ;###
- :user "localuser" ;###
- :source nick))) ;###
+ (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-instance 'irc:irc-privmsg-message
- :received-time (get-universal-time)
- :connection :local
- :trailing-argument what
- :arguments (list target)
- :command "PRIVMSG"
- :HOST "localhost"
- :USER "localuser"
- :SOURCE (slot-value *application-frame* 'nick) ))
+ (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)
Index: beirc/message-display.lisp
diff -u beirc/message-display.lisp:1.9 beirc/message-display.lisp:1.10
--- beirc/message-display.lisp:1.9 Sat Sep 24 17:04:06 2005
+++ beirc/message-display.lisp Sat Sep 24 19:28:38 2005
@@ -206,13 +206,20 @@
(format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message))))))
(defmethod print-message ((message irc:irc-mode-message) receiver)
- (destructuring-bind (target modes args) (irc:arguments message)
- (declare (ignore target))
- (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)))))))
+ (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))
+ (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)))))))))
(defmethod print-message ((message irc:irc-rpl_motd-message) receiver)
(formatting-message (t message receiver)
More information about the Beirc-cvs
mailing list