cl-irc-cvs

cl-irc-cvs@common-lisp.net

220 discussions

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 30 Jan '06

30 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv28092 Modified Files: protocol.lisp Log Message: Satisfy read-message-loop assumption of read-message NIL return on eof. --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/27 21:10:02 1.31 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/30 19:51:12 1.32 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.31 2006/01/27 21:10:02 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.32 2006/01/30 19:51:12 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -244,7 +244,8 @@ (let ((message (read-irc-message connection))) (when *debug-p* (format *debug-stream* "~A" (describe message))) - (irc-message-event connection message) + (when message + (irc-message-event connection message)) message))) ; needed because of the "loop while" in read-message-loop (defvar *process-count* 0) @@ -293,10 +294,13 @@ (defmethod read-irc-message ((connection connection)) "Read and parse an IRC-message from the `connection'." - (let ((message (create-irc-message - (read-line (network-stream connection) t)))) - (setf (connection message) connection) - message)) + (handler-case + (let ((message (create-irc-message + (read-line (network-stream connection) t)))) + (setf (connection message) connection) + message) + (end-of-file))) + ;; satisfy read-message-loop assumption of nil when no more messages (defmethod send-irc-message ((connection connection) command &optional trailing-argument &rest arguments)

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 27 Jan '06

27 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv6027 Modified Files: package.lisp Log Message: Follow up commit as requested by Andreas Fuchs. --- /project/cl-irc/cvsroot/cl-irc/package.lisp 2006/01/25 20:03:27 1.9 +++ /project/cl-irc/cvsroot/cl-irc/package.lisp 2006/01/27 22:54:17 1.10 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.9 2006/01/25 20:03:27 ehuelsmann Exp $ +;;;; $Id: package.lisp,v 1.10 2006/01/27 22:54:17 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -12,6 +12,7 @@ (:nicknames :irc) (:export :read-message-loop :read-message + :irc-message-event :start-background-message-handler :stop-background-message-handler :socket-connect

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 27 Jan '06

27 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv2096 Modified Files: event.lisp protocol.lisp Log Message: Patch by Andreas Fuchs [asf at boinkor.net] to allow specialization of irc-message-event on the type of connection. --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/01/24 22:10:58 1.12 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/01/27 21:10:02 1.13 @@ -1,16 +1,17 @@ -;;;; $Id: event.lisp,v 1.12 2006/01/24 22:10:58 ehuelsmann Exp $ +;;;; $Id: event.lisp,v 1.13 2006/01/27 21:10:02 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. (in-package :irc) -(defgeneric irc-message-event (message) +(defgeneric irc-message-event (connection message) (:documentation "Upon receipt of an IRC message from the connection's stream, irc-message-event will be called with the message.")) -(defmethod irc-message-event ((message irc-message)) +(defmethod irc-message-event (connection (message irc-message)) + (declare (ignore connection)) (apply-to-hooks message) (client-log (connection message) message "UNHANDLED-EVENT:")) @@ -286,7 +287,8 @@ (format nil "PING ~A" (trailing-argument message))) (source message))) -(defmethod irc-message-event ((message ctcp-dcc-chat-request-message)) +(defmethod irc-message-event (connection (message ctcp-dcc-chat-request-message)) + (declare (ignore connection)) (apply-to-hooks message) (client-log (connection message) message)) ; (when (automatically-accept-dcc-connections (configuration (connection message))) @@ -299,7 +301,8 @@ ; :remote-port remote-port) ; *dcc-connections*)))) -(defmethod irc-message-event ((message ctcp-dcc-send-request-message)) +(defmethod irc-message-event (connection (message ctcp-dcc-send-request-message)) + (declare (ignore connection)) (apply-to-hooks message) (client-log (connection message) message)) ; (when (automatically-accept-dcc-downloads (configuration (connection message))) --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/25 20:22:31 1.30 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/27 21:10:02 1.31 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.30 2006/01/25 20:22:31 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.31 2006/01/27 21:10:02 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -244,7 +244,7 @@ (let ((message (read-irc-message connection))) (when *debug-p* (format *debug-stream* "~A" (describe message))) - (irc-message-event message) + (irc-message-event connection message) message))) ; needed because of the "loop while" in read-message-loop (defvar *process-count* 0)

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 25 Jan '06

25 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv29107 Modified Files: protocol.lisp Log Message: Followup to last commit; updating slot accessor and initialiser. --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/25 20:03:27 1.29 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/25 20:22:31 1.30 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.29 2006/01/25 20:03:27 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.30 2006/01/25 20:22:31 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -171,8 +171,6 @@ (defgeneric connectedp (connection)) (defgeneric read-message (connection)) (defgeneric start-process (function name)) -(defgeneric start-background-message-handler (connection)) -(defgeneric read-message-loop (connection)) (defgeneric read-irc-message (connection)) (defgeneric send-irc-message (connection command &optional trailing-argument &rest arguments)) @@ -259,7 +257,7 @@ #+openmcl (ccl:process-run-function name function) #+armedbear (ext:make-thread function)) -(defmethod start-background-message-handler ((connection connection)) +(defun start-background-message-handler (connection) "Read messages from the `connection', parse them and dispatch irc-message-event on them. Returns background process ID if available." (flet ((do-loop () (read-message-loop connection))) @@ -290,7 +288,7 @@ #+openmcl (ccl:process-kill process) #+armedbear (ext:destroy-thread process)) -(defmethod read-message-loop ((connection connection)) +(defun read-message-loop (connection) (loop while (read-message connection))) (defmethod read-irc-message ((connection connection)) @@ -377,8 +375,8 @@ :accessor user :documentation "The user at the other end of this connection. The user at this end can be reached via your normal connection object.") - (stream - :initarg :stream + (network-stream + :initarg :network-stream :accessor network-stream) (output-stream :initarg :output-stream @@ -400,20 +398,21 @@ (output-stream t)) (make-instance 'dcc-connection :user user - :stream (socket-connect remote-address remote-port) + :network-stream (socket-connect remote-address remote-port) :output-stream output-stream)) (defgeneric dcc-close (connection)) (defgeneric send-dcc-message (connection message)) (defmethod read-message ((connection dcc-connection)) - (let ((message (read-line (network-stream connection)))) - (format (output-stream connection) "~A~%" message) - (force-output (output-stream connection)) - message)) - -(defmethod read-message-loop ((connection dcc-connection)) - (loop while (read-message connection))) + (when (connectedp connection) + (let ((message (read-line (network-stream connection)))) + (format (output-stream connection) "~A~%" message) + (force-output (output-stream connection)) + (when *debug-p* + (format *debug-stream* "~A" (describe message))) + ;; (dcc-message-event message) + message))) ; needed because of the "loop while" in read-message-loop (defmethod send-dcc-message ((connection dcc-connection) message) (format (network-stream connection) "~A~%" message)

1 0

[cl-irc-cvs] CVS cl-irc
by ehuelsmann 25 Jan '06

25 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv28320 Modified Files: command.lisp package.lisp protocol.lisp Log Message: Rename slots with same function in preparation of more DCC implementation: {server-stream,dcc-stream} -> network-stream. --- /project/cl-irc/cvsroot/cl-irc/command.lisp 2006/01/24 22:10:58 1.13 +++ /project/cl-irc/cvsroot/cl-irc/command.lisp 2006/01/25 20:03:27 1.14 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.13 2006/01/24 22:10:58 ehuelsmann Exp $ +;;;; $Id: command.lisp,v 1.14 2006/01/25 20:03:27 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -141,8 +141,8 @@ (send-irc-message connection :quit message) #+(and sbcl (not sb-thread)) (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd - (server-stream connection))) - (close (server-stream connection)))) + (network-stream connection))) + (close (network-stream connection)))) (defmethod squit ((connection connection) (server string) (comment string)) (send-irc-message connection :squit comment server)) @@ -250,7 +250,7 @@ "Connect to server and return a connection object." (let* ((stream (socket-connect server port)) (connection (make-connection :connection-type connection-type - :server-stream stream + :network-stream stream :client-stream logging-stream :server-name server)) (user (make-user connection --- /project/cl-irc/cvsroot/cl-irc/package.lisp 2005/04/15 16:01:22 1.8 +++ /project/cl-irc/cvsroot/cl-irc/package.lisp 2006/01/25 20:03:27 1.9 @@ -1,4 +1,4 @@ -;;;; $Id: package.lisp,v 1.8 2005/04/15 16:01:22 ehuelsmann Exp $ +;;;; $Id: package.lisp,v 1.9 2006/01/25 20:03:27 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/package.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -38,7 +38,7 @@ :modes :user-count :users - :server-stream + :network-stream :client-stream :channels :add-hook --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/24 22:10:58 1.28 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/25 20:03:27 1.29 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.28 2006/01/24 22:10:58 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.29 2006/01/25 20:03:27 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -114,9 +114,9 @@ :initarg :server-name :accessor server-name :initform "Unknown server") - (server-stream - :initarg :server-stream - :accessor server-stream + (network-stream + :initarg :network-stream + :accessor network-stream :documentation "Stream used to talk to the IRC server.") (server-capabilities :initform *default-isupport-values* @@ -188,13 +188,13 @@ (defun make-connection (&key (connection-type 'connection) (user nil) (server-name "") - (server-stream nil) + (network-stream nil) (client-stream t) (hooks nil)) (let ((connection (make-instance connection-type :user user :server-name server-name - :server-stream server-stream + :network-stream network-stream :client-stream client-stream))) (dolist (hook hooks) (add-hook connection (car hook) (cadr hook))) @@ -237,7 +237,7 @@ (defmethod connectedp ((connection connection)) "Returns t if `connection' is connected to a server and is ready for input." - (let ((stream (server-stream connection))) + (let ((stream (network-stream connection))) (and (streamp stream) (open-stream-p stream)))) @@ -268,10 +268,10 @@ (start-process #'do-loop name) #+(and sbcl (not sb-thread)) (sb-sys:add-fd-handler (sb-sys:fd-stream-fd - (server-stream connection)) + (network-stream connection)) :input (lambda (fd) (declare (ignore fd)) - (if (listen (server-stream connection)) + (if (listen (network-stream connection)) (read-message connection) ;; select() returns with no ;; available data if the stream @@ -279,7 +279,7 @@ ;; end (EPIPE) (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd - (server-stream connection))))))))) + (network-stream connection))))))))) (defun stop-background-message-handler (process) "Stops a background message handler process returned by the start function." @@ -296,7 +296,7 @@ (defmethod read-irc-message ((connection connection)) "Read and parse an IRC-message from the `connection'." (let ((message (create-irc-message - (read-line (server-stream connection) t)))) + (read-line (network-stream connection) t)))) (setf (connection message) connection) message)) @@ -307,8 +307,8 @@ (let ((raw-message (make-irc-message command :arguments arguments :trailing-argument trailing-argument))) - (write-sequence raw-message (server-stream connection)) - (force-output (server-stream connection)) + (write-sequence raw-message (network-stream connection)) + (force-output (network-stream connection)) raw-message)) (defmethod get-hooks ((connection connection) (class symbol)) @@ -379,7 +379,7 @@ user at this end can be reached via your normal connection object.") (stream :initarg :stream - :accessor dcc-stream) + :accessor network-stream) (output-stream :initarg :output-stream :accessor output-stream @@ -407,7 +407,7 @@ (defgeneric send-dcc-message (connection message)) (defmethod read-message ((connection dcc-connection)) - (let ((message (read-line (dcc-stream connection)))) + (let ((message (read-line (network-stream connection)))) (format (output-stream connection) "~A~%" message) (force-output (output-stream connection)) message)) @@ -416,20 +416,21 @@ (loop while (read-message connection))) (defmethod send-dcc-message ((connection dcc-connection) message) - (format (dcc-stream connection) "~A~%" message)) + (format (network-stream connection) "~A~%" message) + (force-output (network-stream connection))) ;; argh. I want to name this quit but that gives me issues with ;; generic functions. need to resolve. (defmethod dcc-close ((connection dcc-connection)) #+(and sbcl (not sb-thread)) (sb-sys:invalidate-descriptor (sb-sys:fd-stream-fd (stream connection))) - (close (dcc-stream connection)) + (close (network-stream connection)) (setf (user connection) nil) (setf *dcc-connections* (remove connection *dcc-connections*)) ) (defmethod connectedp ((connection dcc-connection)) - (let ((stream (dcc-stream connection))) + (let ((stream (network-stream connection))) (and (streamp stream) (open-stream-p stream))))

1 0

[Cl-irc-cvs] CVS cl-irc
by ehuelsmann 24 Jan '06

24 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv8000 Modified Files: cl-irc.asd command.lisp event.lisp protocol.lisp utility.lisp Log Message: Remove code also maintained in trivial-sockets, adding that as a dependency. --- /project/cl-irc/cvsroot/cl-irc/cl-irc.asd 2004/03/29 19:07:54 1.2 +++ /project/cl-irc/cvsroot/cl-irc/cl-irc.asd 2006/01/24 22:10:58 1.3 @@ -1,4 +1,4 @@ -;;;; $Id: cl-irc.asd,v 1.2 2004/03/29 19:07:54 krosenberg Exp $ +;;;; $Id: cl-irc.asd,v 1.3 2006/01/24 22:10:58 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/cl-irc.asd,v $ ;;;; See the LICENSE file for licensing information. @@ -16,12 +16,9 @@ :version "0.5.2" :licence "MIT" :description "Common Lisp interface to the IRC protocol" - :depends-on - #+sbcl (:sb-bsd-sockets :split-sequence) - #-sbcl (:split-sequence) - :depends-on (:split-sequence) + :depends-on (:split-sequence :trivial-sockets) :properties ((#:author-email . "cl-irc-devel(a)common-lisp.net") - (#:date . "$Date: 2004/03/29 19:07:54 $") + (#:date . "$Date: 2006/01/24 22:10:58 $") ((#:albert #:output-dir) . "doc/api-doc/") ((#:albert #:formats) . ("docbook")) ((#:albert #:docbook #:template) . "book") --- /project/cl-irc/cvsroot/cl-irc/command.lisp 2005/09/25 14:55:02 1.12 +++ /project/cl-irc/cvsroot/cl-irc/command.lisp 2006/01/24 22:10:58 1.13 @@ -1,4 +1,4 @@ -;;;; $Id: command.lisp,v 1.12 2005/09/25 14:55:02 bmastenbrook Exp $ +;;;; $Id: command.lisp,v 1.13 2006/01/24 22:10:58 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/command.lisp,v $ ;;;; See LICENSE for licensing information. @@ -343,6 +343,9 @@ (defmethod ctcp ((connection connection) target message) (send-irc-message connection :privmsg (make-ctcp-message message) target)) +#| +There's too much wrong with this method to fix it now. + (defmethod ctcp-chat-initiate ((connection connection) (nickname string)) #+sbcl (let ((socket (sb-bsd-sockets:make-inet-socket :stream :tcp)) @@ -359,3 +362,4 @@ :socket socket)) #-sbcl (warn "ctcp-chat-initiate is not supported on this implementation.") ) +|# --- /project/cl-irc/cvsroot/cl-irc/event.lisp 2005/09/25 14:55:02 1.11 +++ /project/cl-irc/cvsroot/cl-irc/event.lisp 2006/01/24 22:10:58 1.12 @@ -1,4 +1,4 @@ -;;;; $Id: event.lisp,v 1.11 2005/09/25 14:55:02 bmastenbrook Exp $ +;;;; $Id: event.lisp,v 1.12 2006/01/24 22:10:58 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/event.lisp,v $ ;;;; See LICENSE for licensing information. @@ -292,7 +292,7 @@ ; (when (automatically-accept-dcc-connections (configuration (connection message))) ; (let* ((user (find-user (connection message) (source message))) ; (args (tokenize-string (trailing-argument message))) -; (remote-address (hbo-to-vector-quad (parse-integer (fourth args)))) +; (remote-address (hbo-to-dotted-quad (parse-integer (fourth args)))) ; (remote-port (parse-integer (fifth args) :junk-allowed t))) ; (push (make-dcc-connection :user user ; :remote-address remote-address @@ -306,7 +306,7 @@ ; (let* ((user (find-user (connection message) (source message))) ; (args (tokenize-string (trailing-argument message))) ; (filename (third args)) -; (remote-address (hbo-to-vector-quad (parse-integer (fourth args)))) +; (remote-address (hbo-to-dotted-quad (parse-integer (fourth args)))) ; (remote-port (parse-integer (fifth args))) ; (filesize (parse-integer (sixth args) :junk-allowed t))) ; (let ((dcc-connection (make-dcc-connection :user user --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/23 23:49:01 1.27 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/24 22:10:58 1.28 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.27 2006/01/23 23:49:01 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.28 2006/01/24 22:10:58 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -400,7 +400,7 @@ (output-stream t)) (make-instance 'dcc-connection :user user - :stream (socket-stream remote-address remote-port) + :stream (socket-connect remote-address remote-port) :output-stream output-stream)) (defgeneric dcc-close (connection)) --- /project/cl-irc/cvsroot/cl-irc/utility.lisp 2005/10/03 14:11:02 1.8 +++ /project/cl-irc/cvsroot/cl-irc/utility.lisp 2006/01/24 22:10:58 1.9 @@ -1,4 +1,4 @@ -;;;; $Id: utility.lisp,v 1.8 2005/10/03 14:11:02 afuchs Exp $ +;;;; $Id: utility.lisp,v 1.9 2006/01/24 22:10:58 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/utility.lisp,v $ ;;;; See the LICENSE file for licensing information. @@ -106,39 +106,9 @@ (fourth (ldb (byte 8 0) integer))) (vector first second third fourth))) -(defun connect-to-server-socket (host port) - #+sbcl - (let ((s (make-instance 'sb-bsd-sockets:inet-socket - :type :stream - :protocol :tcp))) - (sb-bsd-sockets:socket-connect s (car (sb-bsd-sockets:host-ent-addresses - (sb-bsd-sockets:get-host-by-name host))) port) - s) - ) - -(defun socket-stream (socket) - #+sbcl - (sb-bsd-sockets:socket-make-stream socket - :element-type 'character - :input t - :output t - :buffering :none) - ) - (defun socket-connect (server port) "Create a socket connected to `server':`port' and return stream for it." - #+lispworks (comm:open-tcp-stream server port :errorp t) - #+cmu (sys:make-fd-stream (ext:connect-to-inet-socket server port) - :input t - :output t - :element-type 'character) - #+allegro (socket:make-socket :remote-host server :remote-port port) - #+sbcl (socket-stream (connect-to-server-socket server port)) - #+openmcl (ccl:make-socket :remote-host server :remote-port port) - #+armedbear (ext:get-socket-stream (ext:make-socket server port)) - #-(or lispworks cmu allegro sbcl openmcl armedbear) - (warn "socket-connect not supported for this implementation.") - ) + (trivial-sockets:open-stream server port)) (defun cut-between (string start-char end-chars &key (start 0) (cut-extra t))

1 0

[Cl-irc-cvs] r120 - trunk/cl-irc
by ehuelsmann＠common-lisp.net 24 Jan '06

24 Jan '06

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)))

1 0

[Cl-irc-cvs] CVS cl-irc
by ehuelsmann 24 Jan '06

24 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv3194 Modified Files: protocol.lisp Log Message: Untabify for consistent indenting accross all systems and editors. --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/23 23:23:49 1.26 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/23 23:49:01 1.27 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.26 2006/01/23 23:23:49 ehuelsmann Exp $ +;;;; $Id: protocol.lisp,v 1.27 2006/01/23 23:49:01 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -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)))

1 0

[Cl-irc-cvs] CVS cl-irc
by ehuelsmann 24 Jan '06

24 Jan '06

Update of /project/cl-irc/cvsroot/cl-irc In directory common-lisp:/tmp/cvs-serv852 Modified Files: protocol.lisp Log Message: Replace invalidate-me condition machinery meant to catch EPIPE by code which prevents the EPIPE (and the associated error). --- /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2005/09/25 14:55:02 1.25 +++ /project/cl-irc/cvsroot/cl-irc/protocol.lisp 2006/01/23 23:23:49 1.26 @@ -1,4 +1,4 @@ -;;;; $Id: protocol.lisp,v 1.25 2005/09/25 14:55:02 bmastenbrook Exp $ +;;;; $Id: protocol.lisp,v 1.26 2006/01/23 23:23:49 ehuelsmann Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/protocol.lisp,v $ ;;;; See LICENSE for licensing information. @@ -241,26 +241,13 @@ (and (streamp stream) (open-stream-p stream)))) -(define-condition invalidate-me (condition) - ((stream :initarg :stream - :reader invalidate-me-stream) - (condition :initarg :condition - :reader invalidate-me-condition))) - (defmethod read-message ((connection connection)) - (let ((read-more-p t)) - (handler-case - (progn - (when (and (connectedp connection) read-more-p) - (let ((message (read-irc-message connection))) - (when *debug-p* - (format *debug-stream* "~A" (describe message))) - (irc-message-event message) - message))) ; needed because of the "loop while" in read-message-loop - (stream-error (c) (setf read-more-p nil) - (signal 'invalidate-me :stream - (server-stream connection) - :condition c))))) + (when (connectedp connection) + (let ((message (read-irc-message connection))) + (when *debug-p* + (format *debug-stream* "~A" (describe message))) + (irc-message-event message) + message))) ; needed because of the "loop while" in read-message-loop (defvar *process-count* 0) @@ -284,14 +271,15 @@ (server-stream connection)) :input (lambda (fd) (declare (ignore fd)) - (handler-case + (if (listen (server-stream connection)) (read-message connection) - (invalidate-me (c) - (sb-sys:invalidate-descriptor - (sb-sys:fd-stream-fd - (invalidate-me-stream c))) - (format t "Socket closed: ~A~%" - (invalidate-me-condition c))))))))) + ;; select() returns with no + ;; available data if the stream + ;; has been closed on the other + ;; end (EPIPE) + (sb-sys:invalidate-descriptor + (sb-sys:fd-stream-fd + (server-stream connection))))))))) (defun stop-background-message-handler (process) "Stops a background message handler process returned by the start function."

1 0

[Cl-irc-cvs] CVS update: cl-irc/example/cliki.lisp
by lisppaste＠common-lisp.net 15 Oct '05

15 Oct '05

Update of /project/cl-irc/cvsroot/cl-irc/example In directory common-lisp.net:/home/lisppaste/cl-irc/example Modified Files: cliki.lisp Log Message: For bmastenbrook: protect acronym generation from abuse Date: Sat Oct 15 21:16:52 2005 Author: lisppaste Index: cl-irc/example/cliki.lisp diff -u cl-irc/example/cliki.lisp:1.37 cl-irc/example/cliki.lisp:1.38 --- cl-irc/example/cliki.lisp:1.37 Thu Oct 13 21:52:33 2005 +++ cl-irc/example/cliki.lisp Sat Oct 15 21:16:52 2005 @@ -1,4 +1,4 @@ -;;;; $Id: cliki.lisp,v 1.37 2005/10/13 19:52:33 lisppaste Exp $ +;;;; $Id: cliki.lisp,v 1.38 2005/10/15 19:16:52 lisppaste Exp $ ;;;; $Source: /project/cl-irc/cvsroot/cl-irc/example/cliki.lisp,v $ ;;;; cliki.lisp - CLiki as an infobot; only works on SBCL. @@ -433,40 +433,44 @@ (defparameter *last-warning-time* 0) +(defmacro without-abuse (&body body) + `(flet ((doit () ,@body)) + (if (> (- (get-universal-time) 60) + *last-warning-time*) + (let ((time-6 (first *last-eliza-times*)) + (time-4 (third *last-eliza-times*)) + (time-2 (fifth *last-eliza-times*)) + (current-time (get-universal-time)) + (count 0) + (overload 0)) + (if (or + (and + (< (- current-time 60) + time-2) + (setf count 3) + (setf overload (- current-time time-2))) + (and + (< (- current-time 75) + time-4) + (setf count 5) + (setf overload (- current-time time-4))) + (and + (< (- current-time 90) + time-6) + (setf count 7) + (setf overload (- current-time time-6)))) + (progn + (setf *last-warning-time* (get-universal-time)) + (format nil "Would you /please/ stop playing with me? ~A messages in ~A seconds is too many." count overload)) + (progn + (setf *last-eliza-times* (nconc (cdr *last-eliza-times*) + (list (get-universal-time)))) + (doit)) + + ))))) + (defun do-eliza (first-pass) - (if (> (- (get-universal-time) 60) - *last-warning-time*) - (let ((time-6 (first *last-eliza-times*)) - (time-4 (third *last-eliza-times*)) - (time-2 (fifth *last-eliza-times*)) - (current-time (get-universal-time)) - (count 0) - (overload 0)) - (if (or - (and - (< (- current-time 60) - time-2) - (setf count 3) - (setf overload (- current-time time-2))) - (and - (< (- current-time 75) - time-4) - (setf count 5) - (setf overload (- current-time time-4))) - (and - (< (- current-time 90) - time-6) - (setf count 7) - (setf overload (- current-time time-6)))) - (progn - (setf *last-warning-time* (get-universal-time)) - (format nil "Would you /please/ stop playing with me? ~A messages in ~A seconds is too many." count overload)) - (progn - (setf *last-eliza-times* (nconc (cdr *last-eliza-times*) - (list (get-universal-time)))) - (ignore-errors (eliza::eliza first-pass))) - - )))) + (without-abuse (ignore-errors (eliza::eliza first-pass)))) (defvar *more* "CODE") @@ -685,11 +689,12 @@ (and str (let ((letters (remove #\" (elt str 0)))) (when (< (length letters) 9) - (if (and (> (length letters) 2) - (string-equal (subseq letters (- (length letters) 2)) "cl")) - (steel-bazooka:steel-whatever :letters (string-downcase (subseq letters 0 (- (length letters) 2)))) - (steel-bazooka:steel-whatever :letters (string-downcase letters) :suffix nil)))))) - (let ((str (nth-value 1 (scan-to-strings "^(?i)shorten\\s+(\\w+://.+\\S)\\s*$" term-with-question)))) + (without-abuse + (if (and (> (length letters) 2) + (string-equal (subseq letters (- (length letters) 2)) "cl")) + (steel-bazooka:steel-whatever :letters (string-downcase (subseq letters 0 (- (length letters) 2)))) + (steel-bazooka:steel-whatever :letters (string-downcase letters) :suffix nil))))))) + (let ((str (nth-value 1 (scan-to-strings "^(?i)shorten\\s+(\\w+://.+\\S)\\s*$" term-with-question)))) (and str (shorten (elt str 0)))) (if (should-do-lookup first-pass (or channel sender ""))

1 0

← Newer
1
...
10
11
12
13
14
15
16
...
22
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-irc-cvs