beirc-cvs

beirc-cvs@common-lisp.net

168 discussions

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv18565 Modified Files: beirc.lisp Log Message: add kick and ban presentation translators for nicknames. Date: Sat Sep 24 21:13:54 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.27 beirc/beirc.lisp:1.28 --- beirc/beirc.lisp:1.27 Sat Sep 24 21:03:14 2005 +++ beirc/beirc.lisp Sat Sep 24 21:13:54 2005 @@ -658,6 +658,33 @@ (object) (list object)) +(define-presentation-to-command-translator nickname-to-kick-translator + (nickname com-kick beirc + :gesture :menu + :menu t + :documentation "Kick this user" + :pointer-documentation "Kick this user") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-ban-nick-translator + (nickname com-ban-nick beirc + :gesture :menu + :menu t + :documentation "Ban this user's nickname" + :pointer-documentation "Ban this user's nickname") + (object) + (list object)) + +(define-presentation-to-command-translator nickname-to-ban-hostmask-translator + (nickname com-ban-hostmask beirc + :gesture :menu + :menu t + :documentation "Ban this user's hostmask" + :pointer-documentation "Ban this user's hostmask") + (object) + (list object)) + (define-presentation-to-command-translator url-to-browse-url-translator (url com-browse-url beirc) (presentation)

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

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

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv14230 Modified Files: beirc.lisp Log Message: don't display PING messages. The *Server* buffer should only light up if something important happens, now. Date: Sat Sep 24 20:14:28 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.25 beirc/beirc.lisp:1.26 --- beirc/beirc.lisp:1.25 Sat Sep 24 20:13:44 2005 +++ beirc/beirc.lisp Sat Sep 24 20:14:28 2005 @@ -212,7 +212,8 @@ cl-irc:irc-rpl_endofinfo-message cl-irc:irc-rpl_endofstats-message cl-irc:irc-rpl_endofwho-message - cl-irc:irc-rpl_endofexceptlist-message)) + cl-irc:irc-rpl_endofexceptlist-message + cl-irc:irc-ping-message)) (defmethod receiver-for-message ((message irc:irc-message) frame) (server-receiver frame))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv14202 Modified Files: beirc.lisp message-display.lisp Log Message: don't highlight the user's nickname in the first column. Date: Sat Sep 24 20:13:44 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.24 beirc/beirc.lisp:1.25 --- beirc/beirc.lisp:1.24 Sat Sep 24 19:39:36 2005 +++ beirc/beirc.lisp Sat Sep 24 20:13:44 2005 @@ -437,7 +437,8 @@ (sleep 1))) (define-presentation-type nickname ()) -(define-presentation-type ignored-nickname (nickname)) +(define-presentation-type unhighlighted-nickname () :inherit-from 'nickname) +(define-presentation-type ignored-nickname () :inherit-from 'nickname) (defun hash-alist (hashtable &aux res) (maphash (lambda (k v) (push (cons k v) res)) hashtable) @@ -471,12 +472,15 @@ (irc:normalize-nickname (current-connection *application-frame*) nickname)))) +(define-presentation-method present (o (type unhighlighted-nickname) *standard-output* (view textual-view) &key) + (write-string o)) + (define-presentation-method present (o (type nickname) *standard-output* (view textual-view) &key) (if (nick-equals-my-nick-p o) (with-drawing-options (t :ink +darkgreen+) (with-text-face (t :bold) - (format t "~A" o))) - (format t "~A" o))) + (write-string o))) + (write-string o))) (define-presentation-type channel () :inherit-from 'string) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.10 beirc/message-display.lisp:1.11 --- beirc/message-display.lisp:1.10 Sat Sep 24 19:28:38 2005 +++ beirc/message-display.lisp Sat Sep 24 20:13:44 2005 @@ -126,7 +126,7 @@ (if (message-from-focused-nick-p message receiver) :bold :roman)) (formatting-message (t message receiver) ((write-string start-string *standard-output*) - (present (irc:source message) 'nickname) + (present (irc:source message) 'unhighlighted-nickname) (write-string end-string *standard-output*)) ((format-message* (irc:trailing-argument message))))))))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv12043 Modified Files: beirc.lisp Log Message: add /part and better /close functionality. * /part exits the current channel and leaves the receiver intact. * /close closes the receiver and parts the channel (if the closed receiver is a channel). The part message from a closed channel goes to the server buffer. Date: Sat Sep 24 19:39:36 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.23 beirc/beirc.lisp:1.24 --- beirc/beirc.lisp:1.23 Sat Sep 24 19:28:38 2005 +++ beirc/beirc.lisp Sat Sep 24 19:39:36 2005 @@ -178,7 +178,11 @@ (defmethod receiver-for-message ((message irc:irc-part-message) frame) (let ((target (first (irc:arguments message)))) - (intern-receiver target frame :channel target))) + (if (and + (null (find-receiver target frame)) + (string= (irc:source message) (slot-value frame 'nick))) + (server-receiver frame) ; don't re-open previously closed channels. + (intern-receiver target frame :channel target)))) (defmethod receiver-for-message ((message irc:irc-mode-message) frame) (case (length (irc:arguments message)) @@ -497,7 +501,15 @@ (raise-receiver receiver)) (define-beirc-command (com-close :name t) ((receiver 'receiver :prompt "receiver")) + (let* ((connection (current-connection *application-frame*)) + (channel (irc:find-channel connection (title receiver)))) + (when channel + (irc:part connection channel))) (remove-receiver receiver *application-frame*)) + +(define-beirc-command (com-part :name t) () + (irc:part (current-connection *application-frame*) + (title (current-receiver *application-frame*)))) (define-beirc-command (com-focus :name t) ((who 'nickname :prompt "who")) (pushnew who (current-focused-nicks) :test #'string=))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

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)

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv1363 Modified Files: beirc.lisp message-display.lisp Log Message: further printing / command features: * don't print "end of <anything>" replies from the server. * add a /topic, /names, /op, /deop command. * add a method to print irc-mode-messages. Date: Sat Sep 24 17:04:07 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.21 beirc/beirc.lisp:1.22 --- beirc/beirc.lisp:1.21 Sat Sep 24 16:36:31 2005 +++ beirc/beirc.lisp Sat Sep 24 17:04:06 2005 @@ -176,6 +176,34 @@ (let ((target (first (irc:arguments message)))) (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))) + +(macrolet ((define-ignore-message-types (&rest mtypes) + `(progn + ,@(loop for mtype in mtypes + collect `(defmethod receiver-for-message ((message ,mtype) frame) + nil))))) + (define-ignore-message-types cl-irc:irc-rpl_endofwhowas-message + cl-irc:irc-rpl_endoflinks-message + cl-irc:irc-rpl_endoptions-message + cl-irc:irc-rpl_endofwhois-message + cl-irc:irc-rpl_endsitelist-message + cl-irc:irc-rpl_endofinvitelist-message + cl-irc:irc-rpl_endofservices-message + cl-irc:irc-rpl_endmode-message + cl-irc:irc-rpl_endofmap-message + cl-irc:irc-rpl_endofnames-message + cl-irc:irc-rpl_endofusers-message + cl-irc:irc-rpl_endofbanlist-message + cl-irc:irc-rpl_endofmotd-message + cl-irc:irc-rpl_endofinfo-message + cl-irc:irc-rpl_endofstats-message + cl-irc:irc-rpl_endofwho-message + cl-irc:irc-rpl_endofexceptlist-message)) + (defmethod receiver-for-message ((message irc:irc-message) frame) (server-receiver frame)) @@ -463,9 +491,21 @@ (define-beirc-command (com-eval :name t) ((command 'string :prompt "command") (args '(sequence string) :prompt "arguments")) - (multiple-value-bind (symbol status) (find-symbol command :irc) + (multiple-value-bind (symbol status) (find-symbol (string-upcase command) :irc) (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)) + +(define-beirc-command (com-op :name t) ((who 'nickname :prompt "who")) + (irc:op (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-deop :name t) ((who 'nickname :prompt "who")) + (irc:deop (current-connection *application-frame*) (target) who)) + +(define-beirc-command (com-names :name t) () + (irc:names (current-connection *application-frame*) (target))) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.8 beirc/message-display.lisp:1.9 --- beirc/message-display.lisp:1.8 Sat Sep 24 16:36:31 2005 +++ beirc/message-display.lisp Sat Sep 24 17:04:06 2005 @@ -205,6 +205,15 @@ (present (irc:source message) 'nickname) (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))))))) + (defmethod print-message ((message irc:irc-rpl_motd-message) receiver) (formatting-message (t message receiver) ((format t "~A" (irc:source message)))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv31756 Modified Files: beirc.lisp message-display.lisp Log Message: Handle printing of the server's MOTD. Add an /Eval command to debug cl-irc commands. Date: Sat Sep 24 16:36:32 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.20 beirc/beirc.lisp:1.21 --- beirc/beirc.lisp:1.20 Sat Sep 24 13:43:37 2005 +++ beirc/beirc.lisp Sat Sep 24 16:36:31 2005 @@ -461,6 +461,12 @@ (setf (current-focused-nicks) (remove who (current-focused-nicks) :test #'string=))) +(define-beirc-command (com-eval :name t) ((command 'string :prompt "command") + (args '(sequence string) :prompt "arguments")) + (multiple-value-bind (symbol status) (find-symbol command :irc) + (when (eql status :external) + (apply symbol (current-connection *application-frame*) (coerce args 'list))))) + (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) (when (current-connection *application-frame*) (quit *application-frame* reason)) Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.7 beirc/message-display.lisp:1.8 --- beirc/message-display.lisp:1.7 Sat Sep 24 11:14:03 2005 +++ beirc/message-display.lisp Sat Sep 24 16:36:31 2005 @@ -205,6 +205,12 @@ (present (irc:source message) 'nickname) (format t " left ~A: ~A" (first (irc:arguments message)) (irc:trailing-argument message)))))) +(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)))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv19320 Modified Files: beirc.lisp Log Message: fix NOTICE handling, including network service notices. also, revert the TICKER function back to its old self; the handler-case in there served no purpose. Date: Sat Sep 24 13:43:37 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.19 beirc/beirc.lisp:1.20 --- beirc/beirc.lisp:1.19 Sat Sep 24 11:14:03 2005 +++ beirc/beirc.lisp Sat Sep 24 13:43:37 2005 @@ -97,13 +97,17 @@ (add-pane (tab-pane receiver) (find-pane-named frame 'query)))) (setf (gethash (tab-pane receiver) (tab-panes-to-receivers frame)) receiver)) +(defun find-receiver (name frame) + (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) + (receivers frame))) + (defun intern-receiver (name frame &rest initargs) - (let ((rec (gethash (irc:normalize-channel-name (slot-value frame 'connection) name) - (receivers frame)))) + (let* ((normalized-name (irc:normalize-channel-name (slot-value frame 'connection) name)) + (rec (find-receiver name frame))) (if rec rec (let ((*application-frame* frame)) - (let ((receiver (apply 'make-paneless-receiver name initargs))) + (let ((receiver (apply 'make-paneless-receiver normalized-name initargs))) (initialize-receiver-with-pane receiver frame (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) @@ -117,20 +121,35 @@ (setf (gethash name (receivers frame)) receiver) receiver))))) +(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, + unless the user has opened a query window to the source + already.") + +(defun network-service-p (source frame) + (member source *network-service-sources* + :test (lambda (source1 source2) + (string= (irc:normalize-nickname (current-connection frame) source1) + (irc:normalize-nickname (current-connection frame) source2))))) + (macrolet ((define-privmsg-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) - (let* ((mynick (irc:normalize-nickname (slot-value frame 'connection) - (slot-value frame 'nick))) - (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) - (first (irc:arguments message)))) - (target (if (equal nominal-target mynick) - (irc:source message) - nominal-target))) - (intern-receiver target frame :channel target))))) + (if (or + (find-receiver (irc:source message) frame) + (not (network-service-p (irc:source message) frame))) + (let* ((mynick (irc:normalize-nickname (current-connection frame) + (slot-value frame 'nick))) + (nominal-target (irc:normalize-channel-name (slot-value frame 'connection) + (first (irc:arguments message)))) + (target (if (equal nominal-target mynick) + (irc:source message) + nominal-target))) + (intern-receiver target frame :channel target)) + (server-receiver frame))))) (define-privmsg-receiver-lookup irc:irc-privmsg-message) (define-privmsg-receiver-lookup irc:ctcp-action-message) - ;; (define-privmsg-receiver-lookup irc:irc-notice-message) ; XXX: NOTICEs in freenode are a bit tricky. - ) + (define-privmsg-receiver-lookup irc:irc-notice-message)) (macrolet ((define-global-message-receiver-lookup (message-type) `(defmethod receiver-for-message ((message ,message-type) frame) @@ -361,28 +380,24 @@ (defun post-message (frame message) (let ((receiver (receiver-for-message message frame))) - (setf (messages receiver) - (append (messages receiver) (list message))) - (unless (eql receiver (current-receiver frame)) - (incf (unseen-messages receiver)) - (when (message-directed-to-me-p frame message) - (incf (messages-directed-to-me receiver)))) - (update-drawing-options receiver) - (clim-internals::event-queue-prepend - (climi::frame-event-queue frame) - (make-instance 'foo-event :sheet frame :receiver receiver)) - nil)) + (unless (null receiver) + (setf (messages receiver) + (append (messages receiver) (list message))) + (unless (eql receiver (current-receiver frame)) + (incf (unseen-messages receiver)) + (when (message-directed-to-me-p frame message) + (incf (messages-directed-to-me receiver)))) + (update-drawing-options receiver) + (clim-internals::event-queue-prepend + (climi::frame-event-queue frame) + (make-instance 'foo-event :sheet frame :receiver receiver)) + nil))) -;;; XXX: ticker continues to run even if the frame is no longer active -;;; or on the display. (defun ticker (frame) - (handler-case - (loop - (clim-internals::event-queue-prepend (climi::frame-event-queue frame) - (make-instance 'bar-event :sheet frame)) - (sleep 1)) - (frame-exit () - nil))) + (loop + (clim-internals::event-queue-prepend (climi::frame-event-queue frame) + (make-instance 'bar-event :sheet frame)) + (sleep 1))) (define-presentation-type nickname ()) (define-presentation-type ignored-nickname (nickname))

1 0

[beirc-cvs] CVS update: beirc/beirc.lisp beirc/message-display.lisp
by afuchs＠common-lisp.net 24 Sep '05

24 Sep '05

Update of /project/beirc/cvsroot/beirc In directory common-lisp.net:/tmp/cvs-serv8786 Modified Files: beirc.lisp message-display.lisp Log Message: Fix /quit, /disconnect commands and quitting the irc worker thread. * /quit, /disconnect and later /connect commands now work, hopefully in all combinations. * This change also introduces a level of thread hygiene. When beirc's application frame exits, every thread (except the clim/clx listener thread) should be killed as well. Date: Sat Sep 24 11:14:04 2005 Author: afuchs Index: beirc/beirc.lisp diff -u beirc/beirc.lisp:1.18 beirc/beirc.lisp:1.19 --- beirc/beirc.lisp:1.18 Sat Sep 24 01:22:50 2005 +++ beirc/beirc.lisp Sat Sep 24 11:14:03 2005 @@ -190,7 +190,6 @@ (setf (messages-directed-to-me receiver) 0) (update-drawing-options receiver)))) - (defun raise-receiver (receiver) (setf (unseen-messages receiver) 0) (setf (messages-directed-to-me receiver) 0) @@ -211,6 +210,7 @@ (define-application-frame beirc (redisplay-frame-mixin standard-application-frame) ((connection :initform nil :reader current-connection) + (connection-process :initform nil :accessor connection-process) (nick :initform nil) (ignored-nicks :initform nil) (receivers :initform (make-hash-table :test #'equal) :accessor receivers) @@ -347,11 +347,12 @@ (clim-sys:make-process (lambda () (progv syms vals - (let ((frame (make-application-frame 'beirc))) + (let* ((frame (make-application-frame 'beirc)) + (ticker-process (clim-sys:make-process (lambda () (ticker frame)) + :name "Beirc Ticker"))) (setf *beirc-frame* frame) - (clim-sys:make-process (lambda () (ticker frame)) - :name "Beirc Ticker") - (run-frame-top-level frame)))))))) + (run-frame-top-level frame) + (clim-sys:destroy-process ticker-process)))))))) (defun message-directed-to-me-p (frame message) (let ((my-nick (slot-value frame 'nick)) @@ -372,11 +373,16 @@ (make-instance 'foo-event :sheet frame :receiver receiver)) nil)) +;;; XXX: ticker continues to run even if the frame is no longer active +;;; or on the display. (defun ticker (frame) - (loop - (clim-internals::event-queue-prepend (climi::frame-event-queue frame) - (make-instance 'bar-event :sheet frame)) - (sleep 1))) + (handler-case + (loop + (clim-internals::event-queue-prepend (climi::frame-event-queue frame) + (make-instance 'bar-event :sheet frame)) + (sleep 1)) + (frame-exit () + nil))) (define-presentation-type nickname ()) (define-presentation-type ignored-nickname (nickname)) @@ -406,7 +412,8 @@ (find-in-tab-panes-list object 'tab-layout-pane))) (defun nick-equals-my-nick-p (nickname) - (and *application-frame* + (and (not (null *application-frame*)) + (not (null (slot-value *application-frame* 'connection))) (equal (irc:normalize-nickname (current-connection *application-frame*) (slot-value *application-frame* 'nick)) (irc:normalize-nickname (current-connection *application-frame*) @@ -440,7 +447,13 @@ (remove who (current-focused-nicks) :test #'string=))) (define-beirc-command (com-quit :name t) ((reason 'mumble :prompt "reason")) - (irc:quit (current-connection *application-frame*) reason)) + (when (current-connection *application-frame*) + (quit *application-frame* reason)) + (frame-exit *application-frame*)) + +(define-beirc-command (com-disconnect :name t) ((reason 'mumble :prompt "reason")) + (when (current-connection *application-frame*) + (quit *application-frame* reason))) (defun target (&optional (*application-frame* *application-frame*)) (or (current-query) @@ -527,9 +540,45 @@ (find-pane-named frame 'server) :add-pane-p nil) (setf (gethash "*Server*" (receivers frame)) (server-receiver frame)) - (clim-sys:make-process #'(lambda () - (irc-event-loop frame connection)) - :name "IRC Message Muffling Loop") ))))) + (setf (connection-process *application-frame*) + (clim-sys:make-process #'(lambda () + (unwind-protect + (irc-event-loop frame connection) + (disconnect frame))) + :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))) + +(defun quit (frame reason) + (raise-receiver (server-receiver frame)) + (irc:quit (current-connection frame) reason) + (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)) (defmethod clim:read-frame-command ((frame beirc) &key (stream *standard-input*)) (multiple-value-prog1 @@ -544,12 +593,10 @@ (window-clear stream))) (defun restart-beirc () - (let ((m (current-messages))) - (clim-sys:destroy-process *gui-process*) - (setf *beirc-frame* nil) - (beirc) - (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*)) - (setf (current-messages) m))) + (clim-sys:destroy-process *gui-process*) + (setf *beirc-frame* nil) + (beirc) + (clim-sys:process-wait "waiting for beirc" (lambda () *beirc-frame*))) ;;;;;;;;; Index: beirc/message-display.lisp diff -u beirc/message-display.lisp:1.6 beirc/message-display.lisp:1.7 --- beirc/message-display.lisp:1.6 Sat Sep 24 01:04:21 2005 +++ beirc/message-display.lisp Sat Sep 24 11:14:03 2005 @@ -103,7 +103,8 @@ (present-url word%)) ((or (nick-equals-my-nick-p word%) - (irc:find-user (current-connection *application-frame*) word%)) + (and (current-connection *application-frame*) + (irc:find-user (current-connection *application-frame*) word%))) (present word% 'nickname)) (t (write-string word%))) (write-string stripped-punctuation)))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

beirc-cvs