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)