Author: ehuelsmann Date: Sun Sep 23 02:50:06 2012 New Revision: 219
Log: Fix long-standing complaint that cl-irc hits the debugger on unknown (and, as Matthew Emerson puts it, irrelevant) response codes.
* parse-message.lisp: (find-reply-name): Simply return the reply name. (create-irc-message): If there's no reply name, raise an error.
* protocol.lisp: (read-irc-message, read-message, read-message-loop): restructure condition handling for END-OF-FILE and NO-SUCH-REPLY to eliminate "trickery" (returning values which mean different things than what they are)
* variable.lisp: (*unknown-reply-hook*): New variable for function to catch unhandled replies. Defaults to ignore unhandled replies.
Modified: trunk/parse-message.lisp trunk/protocol.lisp trunk/variable.lisp
Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp Sat Aug 18 14:58:37 2012 (r218) +++ trunk/parse-message.lisp Sun Sep 23 02:50:06 2012 (r219) @@ -12,12 +12,8 @@ (`no-such-reply') which gives you the opportunity to ignore the situation." (let ((name (assoc reply-number reply-names))) - (if name - (cadr name) - (progn - (cerror "Ignore unknown reply." - 'no-such-reply :reply-number reply-number) - :unknown-reply)))) + (when name + (cadr name))))
(defun return-source (string &key (start 0)) "Assuming `string' is a valid IRC message this function returns the @@ -198,14 +194,17 @@ ;; (setf command (find-reply-name (parse-integer command))) ;; (setf class 'irc-error-reply))) ((numeric-reply-p command) - (progn - (setf command (find-reply-name (parse-integer command))) + (let* ((reply-number (parse-integer command)) + (reply-name (find-reply-name reply-number))) + (unless reply-name + (error "Ignore unknown reply." + 'no-such-reply :reply-number reply-number)) + (setf command reply-name) (setf class (find-irc-message-class command)))) (t - (progn - (setf command (intern (string-upcase command) - (find-package :keyword))) - (setf class (find-irc-message-class command)))))) + (setf command (intern (string-upcase command) + (find-package :keyword))) + (setf class (find-irc-message-class command))))) (when ctcp (setf class (find-ctcp-message-class ctcp))) (let ((instance (make-instance class
Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp Sat Aug 18 14:58:37 2012 (r218) +++ trunk/protocol.lisp Sun Sep 23 02:50:06 2012 (r219) @@ -280,8 +280,8 @@ (when *debug-p* (format *debug-stream* "~A" (describe message))) (when message - (irc-message-event connection message)) - message))) ; needed because of the "loop while" in read-message-loop + (irc-message-event connection message))) + t)) ;; connected -> continue processing
(defvar *process-count* 0)
@@ -311,34 +311,21 @@ (flet ((select-handler (fd) (declare (ignore fd)) (if (listen (network-stream connection)) - (handler-bind - ;; install sensible recovery: nobody can wrap the - ;; handler... - ((no-such-reply - #'(lambda (c) - (declare (ignore c)) - (invoke-restart 'continue)))) - (read-message connection)) - ;; 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 - (network-stream connection)))))) + (read-message connection) + ;; 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 + (network-stream connection)))))) (sb-sys:add-fd-handler (sb-sys:fd-stream-fd (network-stream connection)) :input #'select-handler))
#-(and sbcl (not sb-thread)) (flet ((do-loop () - (loop - (handler-bind - ((no-such-reply - #'(lambda (c) - (declare (ignore c)) - (invoke-restart 'continue)))) - (read-message-loop connection))))) + (read-message-loop connection))) (let ((name (format nil "irc-handler-~D" (incf *process-count*)))) (start-process #'do-loop name))))
@@ -357,19 +344,23 @@
(defgeneric read-message-loop (connection)) (defmethod read-message-loop (connection) - (loop while (read-message connection))) + (handler-bind + (loop while (read-message connection)) + (end-of-file () nil)))
(defmethod read-irc-message ((connection connection)) - "Read and parse an IRC-message from the `connection'." - (handler-case - (let* ((msg-string (read-protocol-line connection)) - (message (when msg-string (create-irc-message msg-string)))) - (when message (setf (connection message) connection)) - message) - (end-of-file - ;; satisfy read-message-loop assumption of nil when no more messages - ()))) + "Read and parse an IRC message from the `connection'." + (let* ((msg-string (read-protocol-line connection)) + (message (when msg-string + (handler-case + (create-irc-message msg-string) + (no-such-reply () + (when *unknown-reply-hook* + (funcall *unknown-reply-hook* + connection msg-string))))))) + (when message (setf (connection message) connection)) + message))
(defmethod send-irc-message ((connection connection) command
Modified: trunk/variable.lisp ============================================================================== --- trunk/variable.lisp Sat Aug 18 14:58:37 2012 (r218) +++ trunk/variable.lisp Sun Sep 23 02:50:06 2012 (r219) @@ -15,8 +15,8 @@ (format nil "CL IRC library, cl-irc:~A:~A ~A" *version* (machine-type) (machine-version)))
-(defparameter *download-host* "ftp://common-lisp.net/") -(defparameter *download-directory* "/pub/project/cl-irc/") +(defparameter *download-host* "http://common-lisp.net/") +(defparameter *download-directory* "/project/cl-irc/") (defparameter *download-file* (format nil "cl-irc-~A.tar.gz" *version*))
@@ -28,6 +28,15 @@ (defvar *default-quit-message* "Common Lisp IRC library - http://common-lisp.net/project/cl-irc")
+(defparameter *unknown-reply-hook* nil + "A function of two arguments, called with the related irc connection +object and the protocol message string upon detection of an unmappable +response code. + +The function should return a valid IRC-MESSAGE class or NIL. + +The parameter can be NIL to disable the hook.") + (defparameter *default-isupport-CHANMODES* "beI,kO,l,aimnpqsrt") (defparameter *default-isupport-PREFIX*