January 2006 - cl-irc-devel - mailman3.common-lisp.net

[cl-irc-devel] [patch] Make cl-irc more compatible with bouncers
by Andreas Fuchs 27 Jan '06

27 Jan '06

Hi, irc bouncers like miau send a 30-minute backlog on reconnect. The problem is that they don't send NAMES before they send the backlog. AFAICT, that's even allowed by the irc spec. cl-irc breaks when it sees a QUIT message when it didn't build a channel user table before. This patch makes cl-irc accept quit messages when it can't find a user for them: Cheers, -- Andreas Fuchs, (http://|im:asf@|mailto:asf@)boinkor.net, antifuchs

1 0

[cl-irc-devel] [patch] Add a connection arg to irc-message-event
by Andreas Fuchs 27 Jan '06

27 Jan '06

Hi, Beirc as it is right now uses a really ugly re-implementation of the read-message method, because in order to operate correctly, we can't just use an :around method on read-message like this: (defmethod read-message ((con my-irc-connection)) (let ((m (call-next-method))) (dispatch-on-message m) m)) Why? Because (in the case of a QUIT message) read-message modified the channel user table already when beirc tries to find out which channels a user who just quit was on. So, I think we're specializing a method one level too high. We should be specializing the irc-message-event method, but it has no connection argument. Yet. The attached patch adds a connection argument on which irc-message-event can be specialized. I would also suggest exporting irc-message-event and making that method the recommended way to dispatch on all messages on an irc connection. I've used this patch with a locally hacked version of beirc for a few days now and it works very well for me. I hope you all like it, because I'd really like to see that ugly wart in beirc go away. (-: -- Andreas Fuchs, (http://|im:asf@|mailto:asf@)boinkor.net, antifuchs

2 1

[cl-irc-devel] Re: [Cl-irc-cvs] r120 - trunk/cl-irc
by Erik Huelsmann 24 Jan '06

24 Jan '06

Sorry for the noise: this was a test commit message to see if I configured the commit mailer program correctly. It looks like I did... bye, Erik. > --- Ursprüngliche Nachricht --- > Von: ehuelsmann(a)common-lisp.net > An: cl-irc-cvs(a)common-lisp.net > Betreff: [Cl-irc-cvs] r120 - trunk/cl-irc > Datum: Tue, 24 Jan 2006 15:36:49 -0600 (CST) > > Author: ehuelsmann > Date: Mon Jan 23 17:49:01 2006 > New Revision: 120 > > Modified: > trunk/cl-irc/protocol.lisp > Log: > Untabify for consistent indenting accross all systems and editors. > > > Modified: trunk/cl-irc/protocol.lisp > ============================================================================== > --- trunk/cl-irc/protocol.lisp (original) > +++ trunk/cl-irc/protocol.lisp Mon Jan 23 17:49:01 2006 > @@ -268,9 +268,9 @@ > (start-process #'do-loop name) > #+(and sbcl (not sb-thread)) > (sb-sys:add-fd-handler (sb-sys:fd-stream-fd > - (server-stream connection)) > - :input (lambda (fd) > - (declare (ignore fd)) > + (server-stream connection)) > + :input (lambda (fd) > + (declare (ignore fd)) > (if (listen (server-stream > connection)) > (read-message connection) > ;; select() returns with no > @@ -850,19 +850,19 @@ > "Intern based on symbol-name to support case-sensitive mlisp" > (intern > (concatenate 'string > - (symbol-name prefix) > - "-" > - (symbol-name name) > - "-" > - (symbol-name '#:message)))) > + (symbol-name prefix) > + "-" > + (symbol-name name) > + "-" > + (symbol-name '#:message)))) > > (defun define-irc-message (command) > (let ((name (intern-message-symbol :irc command))) > `(progn > - (defmethod find-irc-message-class ((type (eql ,command))) > - (find-class ',name)) > - (export ',name) > - (defclass ,name (irc-message) ()))))) > + (defmethod find-irc-message-class ((type (eql ,command))) > + (find-class ',name)) > + (export ',name) > + (defclass ,name (irc-message) ()))))) > > (defmacro create-irc-message-classes (class-list) > `(progn ,@(mapcar #'define-irc-message class-list))) > @@ -870,7 +870,7 @@ > ;; should perhaps wrap this in an eval-when? > (create-irc-message-classes #.(remove-duplicates (mapcar #'second > *reply-names*))) > (create-irc-message-classes (:privmsg :notice :kick :topic :error :mode > :ping > - :nick :join :part :quit :kill :pong :invite)) > + :nick :join :part :quit :kill :pong > :invite)) > > (defmethod find-irc-message-class (type) > (declare (ignore type)) > @@ -909,10 +909,10 @@ > (defun define-ctcp-message (ctcp-command) > (let ((name (intern-message-symbol :ctcp ctcp-command))) > `(progn > - (defmethod find-ctcp-message-class ((type (eql ,ctcp-command))) > - (find-class ',name)) > - (export ',name) > - (defclass ,name (ctcp-mixin irc-message) ()))))) > + (defmethod find-ctcp-message-class ((type (eql ,ctcp-command))) > + (find-class ',name)) > + (export ',name) > + (defclass ,name (ctcp-mixin irc-message) ()))))) > > (defmacro create-ctcp-message-classes (class-list) > `(progn ,@(mapcar #'define-ctcp-message class-list))) > _______________________________________________ > Cl-irc-cvs mailing list > Cl-irc-cvs(a)common-lisp.net > http://common-lisp.net/cgi-bin/mailman/listinfo/cl-irc-cvs > -- DSL-Aktion wegen großer Nachfrage bis 28.2.2006 verlängert: GMX DSL-Flatrate 1 Jahr kostenlos* http://www.gmx.net/de/go/dsl

1 0

[cl-irc-devel] Start using trivial-sockets to reduce implementation dependent code
by Erik Huelsmann 24 Jan '06

24 Jan '06

Hi! Somewhere in the TODO, there's mention of abstracting/extracting implementation dependent sockets code into it's own (simple) library. I believe that library has been available for a while now and would like to switch cl-irc to using that: trivial-sockets. Hoping for reactions (but committing the change otherwise), Erik. -- Telefonieren Sie schon oder sparen Sie noch? NEU: GMX Phone_Flat http://www.gmx.net/de/go/telefonie

1 1

[cl-irc-devel] Switching CVS to Subversion?
by Erik Huelsmann 23 Jan '06

23 Jan '06

Hi! Well, it's no secret that I am a Subversion dev, but apart from that: I like Subversion's interface (much) better than CVS's. Is there anybody who objects to switching the CVS repository to Subversion? bye, Erik. -- 10 GB Mailbox, 100 FreeSMS/Monat http://www.gmx.net/de/go/topmail +++ GMX - die erste Adresse f�r Mail, Message, More +++

1 0

[cl-irc-devel] [PATCH] Add 'seen' and 'spoke' support
by Erik Huelsmann 06 Jan '06

06 Jan '06

Hi! Some time ago Xach (Zach) gave me the source to a utility routine he wrote to add 'seen' tracking to a bot of his. I generalised the code and made library-code of it adding several hooks. The patch below applies to HEAD as of this moment and adds a generalised version of event tracking. It does not only track 'seen', it adds 'spoke' by default too. Next to that, it implements the general tools to track any event a library-user may want to track. I'd *love* to hear your comments. bye, Erik. Index: cl-irc.asd =================================================================== RCS file: /project/cl-irc/cvsroot/cl-irc/cl-irc.asd,v retrieving revision 1.2 diff -u -r1.2 cl-irc.asd --- cl-irc.asd 29 Mar 2004 19:07:54 -0000 1.2 +++ cl-irc.asd 6 Jan 2006 21:38:25 -0000 @@ -39,4 +39,6 @@ (:file "command" :depends-on ("protocol")) (:file "event" + :depends-on ("command")) + (:file "track" :depends-on ("command")))) Index: package.lisp =================================================================== RCS file: /project/cl-irc/cvsroot/cl-irc/package.lisp,v retrieving revision 1.8 diff -u -r1.8 package.lisp --- package.lisp 15 Apr 2005 16:01:22 -0000 1.8 +++ package.lisp 6 Jan 2006 21:38:25 -0000 @@ -129,5 +129,11 @@ :users- :wallops :userhost - :ison))) + :ison + ;;; user activity tracking + :record-events + :recorded-event + :seen + :spoke + ))) Index: protocol.lisp =================================================================== RCS file: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v retrieving revision 1.25 diff -u -r1.25 protocol.lisp --- protocol.lisp 25 Sep 2005 14:55:02 -0000 1.25 +++ protocol.lisp 6 Jan 2006 21:38:25 -0000 @@ -159,7 +159,8 @@ (users :initarg :users :accessor users - :initform (make-hash-table :test #'equal)))) + :initform (make-hash-table :test #'equal)) + (track-db))) (defmethod print-object ((object connection) stream) "Print the object for the Lisp reader." Index: track.lisp =================================================================== RCS file: track.lisp diff -N track.lisp --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ track.lisp 6 Jan 2006 21:38:25 -0000 @@ -0,0 +1,288 @@ +;;; +;;; track.lisp +;;; +;;; Heavily based on seen.lisp +;;; as created on 2004-01-08 by Zach Beane <xach(a)gwi.net> +;;; +;;; Adapted to be part of cl-irc by Erik Huelsmann <e.huelsmann(a)gmx.net> +;;; +;;; + +(in-package :irc) + + +(defclass msg-db () + ((table :reader msg-db-table + :initform (make-hash-table :test 'equalp) + :documentation "A hash table mapping IRC nicknames to + their seen data.") + (file :reader msg-db-file + :initarg :file + :documentation "The file to which seen data will be + saved and updated.") + (compact-threshold :accessor msg-db-compact-threshold + :initarg :compact-threshold + :initform 10000 + :documentation "How many updates to write + to the data file before compacting it.") + (update-count :accessor msg-db-update-count + :initform 0))) + +(defun %file-update (stream key &rest args) + (let ((*print-pretty* nil) + (*print-readably* t)) + (print (cons key args) stream))) + +(defun %table-update (table key &rest args) + (setf (gethash key table) args)) + +(defmethod update-db ((db msg-db) + nick msg-type time &rest rest) + (let ((key (list nick msg-type))) + (with-open-file (out (msg-db-file db) + :direction :output + :if-exists :append + :if-does-not-exist :create) + (apply #'%file-update (append (list out key time) rest))) + (incf (msg-db-update-count db)) + (maybe-compact-db db) + (apply #'%table-update (append (list (msg-db-table db) key time) rest)))) + +(defmethod save-db ((db msg-db)) + (with-open-file (out (msg-db-file db) + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (maphash #'(lambda (key val) + (apply #'%file-update out key val)) + (msg-db-table db)))) + +(defmethod compact-db ((db msg-db)) + (save-db db) + (setf (msg-db-update-count db) 0)) + +(defmethod maybe-compact-db ((db msg-db)) + (when (> (msg-db-update-count db) + (msg-db-compact-threshold db)) + (compact-db db))) + +(defmethod load-db ((db msg-db)) + (with-open-file (in (msg-db-file db) + :direction :input + :if-does-not-exist :create) + (loop for item = (read in nil nil) + while item + do + (destructuring-bind + (nick &rest rest) + item + (apply #'%table-update (append (list (msg-db-table db) nick) + rest)))))) + + +(defun make-msg-db (&key file (compact-threshold 10000)) + (let ((db (make-instance 'msg-db + :file file + :compact-threshold compact-threshold))) + (load-db db) + (compact-db db) + db)) + + +;;; Producing pretty messages for various events + +(defmacro with-slots-and-args (slots args message &body body) + "Evaluate BODY with the slots of the MESSAGE bound to the + symbols of SLOTS, and the arguments of the message + destructuring-bind'ed to ARGS." + (let ((irc-message (gensym))) + `(let ((,irc-message ,message)) + (with-slots ,slots ,irc-message + (destructuring-bind ,args (arguments ,irc-message) + ,@body))))) + + +;; track-data returns (values): + +;; * a keyword designating the registered event, one of: +;; :joined +;; :left +;; :quit +;; :kicked +;; :nick-changed +;; :unknown +;; * a list of arguments for the given event + + +;; Default events to be recorded + +(defmethod track-data ((message irc-message)) + (values :unknown (list command message))) + +(defmethod track-data ((message irc-kick-message)) + (with-slots-and-args (source trailing-argument) (channel target) + message + (declare (ignore target)) + (values :kicked (list channel source trailing-argument)))) + +(defmethod track-data ((message irc-join-message)) + (values :joined (list (trailing-argument message)))) + +(defmethod track-data ((message irc-quit-message)) + (values :quit (list (trailing-argument message)))) + +(defmethod track-data ((message irc-part-message)) + (with-slots-and-args (trailing-argument) (channel) + message + (values :left (list channel trailing-argument)))) + +(defmethod track-data ((message irc-nick-message)) + (with-slots-and-args (source) (new-nick) + message + (values :nick-changed (list source new-nick)))) + +(defmethod track-data ((message irc-privmsg-message)) + (with-slots-and-args (received-time trailing-argument arguments) + (channel) + message + (values :privmsg (list trailing-argument channel)))) + +(defmethod track-data ((message ctcp-action-message)) + (with-slots-and-args (received-time trailing-argument arguments) + (channel) + message + (values :action (list trailing-argument channel)))) + +;; Most messages have the the source as track-related nick, +;; but there are exceptions. + +(defmethod track-nicks ((message irc-message)) + (list (source message))) + +(defmethod track-nicks ((message irc-kick-message)) + (destructuring-bind (channel target) + (arguments message) + (declare (ignore channel)) + (list target (source message)))) + + + +;; Hook setup + +(defun make-track-hook (connection db data-callback nicks-callback) + (lambda (message) + (let ((time (received-time message)) + (data (multiple-value-list (funcall data-callback message)))) + (dolist (nick (mapcar #'(lambda (x) + (normalize-nickname connection x)) + (funcall nicks-callback message))) + (apply #'update-db + (append (list db nick (type-of message) time) data)))))) + + +(defvar special-message-names + '((:seen irc-kick-message + irc-quit-message + irc-part-message + irc-join-message + irc-nick-message) + (:spoke irc-privmsg-message + ctcp-action-message))) + +(defun map-special-messages (messages) + (mapcan #'(lambda (x) (if (keywordp x) + ;; copy-list is here because + ;; mapcan modifies its lists + (copy-list (cdr (assoc x special-message-names))) + (list x))) + messages)) + +(defun record-events (connection file + &key (data #'track-data) + (nicks #'track-nicks) + (messages '(:seen :spoke))) + "Add hooks to CONNECTION necessary to track event information. +Uses FILE as the event database. + +Returns the database-object used to record events." + (let* ((db (make-msg-db :file file)) + (fun (make-track-hook connection db data nicks))) + (setf (slot-value connection 'track-db) db) + (dolist (class (map-special-messages messages)) + (add-hook connection class fun)) + db)) + +(defmethod recorded-event ((connection connection) nick + &optional (messages '(:seen :spoke))) + (values-list + (reduce #'(lambda (&optional x y) + (cond + ((and x y) + ;; select latest (newest) event + (if (> (first x) (first y)) x y)) + (x x) + (y y))) + (mapcar #'(lambda (x) + (gethash (list nick x) + (msg-db-table + (slot-value connection 'track-db)))) + (map-special-messages messages))))) + +(defmethod seen ((connection connection) nick) + "Returns (values time event-type msg-data ...)" + (recorded-event connection nick '(:seen))) + +(defmethod spoke ((connection connection) nick) + "Returns (values time event-type msg-data ...)" + (recorded-event connection nick '(:spoke))) + + +;; Formatting of default recorded events + +(defmethod fmt-track (stream (action (eql :kicked)) arguments) + (declare (ignore action)) + (destructuring-bind + (channel oper text) + arguments + (format stream "being kicked out of ~A by ~A~@[ (~A)~]" + channel oper text))) + +(defmethod fmt-track (stream (action (eql :joined)) arguments) + (declare (ignore action)) + (destructuring-bind + (channel) + arguments + (format stream "joining ~A" channel))) + +(defmethod fmt-track (stream (action (eql :left)) arguments) + (declare (ignore action)) + (destructuring-bind + (channel text) + arguments + (format stream "leaving ~A~@[ (~A)~]" channel text))) + +(defmethod fmt-track (stream (action (eql :quit)) arguments) + (declare (ignore action)) + (destructuring-bind + (text) + arguments + (format stream "leaving irc~@[ (~A)~]" text))) + +(defmethod fmt-track (stream (action (eql :nick-changed)) arguments) + (declare (ignore action)) + (destructuring-bind + (from-nick to-nick) + arguments + (format stream "changing his nick from ~A to ~A" from-nick to-nick))) + +(defmethod fmt-track (stream (action (eql :privmsg)) arguments) + (declare (ignore action)) + (destructuring-bind + (text channel) + arguments + (format stream "'~A' in ~A" text channel))) + + +(defun format-track-data (stream action arguments) + (fmt-track stream action arguments)) + -- 10 GB Mailbox, 100 FreeSMS/Monat http://www.gmx.net/de/go/topmail +++ GMX - die erste Adresse für Mail, Message, More +++ -- 10 GB Mailbox, 100 FreeSMS/Monat http://www.gmx.net/de/go/topmail +++ GMX - die erste Adresse für Mail, Message, More +++

1 0