cl-irc-cvs May 2006

cl-irc-cvs@common-lisp.net

1 participants
14 discussions

[cl-irc-cvs] r161 - in trunk: . test
by ehuelsmann＠common-lisp.net 23 May '06

23 May '06

Author: ehuelsmann Date: Tue May 23 16:40:48 2006 New Revision: 161 Added: trunk/test/test-binding-macro.lisp (contents, props changed) Modified: trunk/package.lisp (contents, props changed) trunk/test/cl-irc-test.asd (contents, props changed) trunk/test/package.lisp trunk/utility.lisp (contents, props changed) Log: Replace destructuring-arguments with a hopefully more useful version. Including tests. Raising specific errors has been raised as its own issue #22. Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Tue May 23 16:40:48 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See the LICENSE file for licensing information. @@ -16,6 +16,7 @@ :start-background-message-handler :stop-background-message-handler :destructuring-arguments + :&req :socket-connect :server-name :server-port Modified: trunk/test/cl-irc-test.asd ============================================================================== --- trunk/test/cl-irc-test.asd (original) +++ trunk/test/cl-irc-test.asd Tue May 23 16:40:48 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See the LICENSE file for licensing information. @@ -16,11 +16,11 @@ :version "0.1.0" :licence "MIT" :description "Tests for the cl-irc system" - :depends-on - #+sbcl (:sb-bsd-sockets :split-sequence :rt :cl-irc) - #-sbcl (:split-sequence :rt :cl-irc) + :depends-on (:split-sequence :rt :cl-irc) :components ((:file "package") (:file "test-parse-message" :depends-on ("package")) (:file "test-protocol" - :depends-on ("test-parse-message")))) + :depends-on ("test-parse-message")) + (:file "test-binding-macro" + :depends-on ("package")))) Modified: trunk/test/package.lisp ============================================================================== --- trunk/test/package.lisp (original) +++ trunk/test/package.lisp Tue May 23 16:40:48 2006 @@ -7,6 +7,6 @@ (eval-when (:execute :load-toplevel :compile-toplevel) (defpackage :cl-irc-test - (:use :cl :rt) + (:use :cl :rt :cl-irc) (:nicknames :cl-irc-test) (:export :do-tests))) Added: trunk/test/test-binding-macro.lisp ============================================================================== --- (empty file) +++ trunk/test/test-binding-macro.lisp Tue May 23 16:40:48 2006 @@ -0,0 +1,56 @@ +;;;; $Id$ +;;;; $URL$ + +;;;; See the LICENSE file for licensing information. + + +(in-package :cl-irc-test) + +(defvar *protocol-mode* + ":Chanserv!chanserve@services. MODE #svn +o eh") + + +;; tests which should complete successfully + +(deftest binding.1 + (destructuring-arguments + (target modes &rest arguments) + (cl-irc::create-irc-message *protocol-mode*) + (values target modes arguments)) + "#svn" "+o" ("eh")) + + +(deftest binding.2 + (destructuring-arguments + (target :ignored &rest arguments) + (cl-irc::create-irc-message *protocol-mode*) + (values target arguments)) + "#svn" ("eh")) + +(deftest binding.3 + (destructuring-arguments + (:ignored &rest arguments &req nick) + (cl-irc::create-irc-message *protocol-mode*) + (values nick arguments)) + "eh" ("+o")) + +(deftest binding.4 + (destructuring-arguments + (target &optional modes &req nick) + (cl-irc::create-irc-message *protocol-mode*) + (values target modes nick)) + "#svn" "+o" "eh") + +(deftest binding.5 + (destructuring-arguments + (&whole all target &optional modes &req nick) + (cl-irc::create-irc-message *protocol-mode*) + (values all target modes nick)) + ("#svn" "+o" "eh") "#svn" "+o" "eh") + +(deftest binding.6 + (destructuring-arguments + (target &optional modes &rest args &req nick) + (cl-irc::create-irc-message *protocol-mode*) + (values target modes args nick)) + "#svn" "+o" nil "eh") Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Tue May 23 16:40:48 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See the LICENSE file for licensing information. @@ -215,65 +215,115 @@ ;; Message arguments binding macro ;; - (defmacro destructuring-arguments (lambda-list message &body body) - "Destructures the arguments slot in MESSAGE according -to LAMBDA-LIST and binds them in BODY. -destructuring-irc-message-arguments's lambda list syntax is as follows: + "Destructures the `arguments' slot in `message' according +to `lambda-list' and binds them in `body'. + +The lambda list syntax is as follows: +wholevar::= &whole var reqvars::= var* -optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}*] +optvars::= [&optional {var | (var [init-form [supplied-p-parameter]])}* ] restvar::= [&rest var] -wholevar::= [&whole var] -lastvar::= [&last var] -lambda-list::= (wholevar reqvars optvars restvar lastvar) - -With the exception of &last, all lambda list keywords are -analogous to a destructuring lambda list's (see clhs 3.4.5). - -If &last is given, the specified variable is bound to the last -argument in the message. Specifying &last implies that all -arguments past the last of the required variables will be -ignored, even if there is no &rest lambda list keyword present. - -If both &rest and &last are specified, the last element in the -list is also included in the rest list." - (let ((valid-bare-ll-keywords '(&optional &rest &whole)) - (nothing (gensym)) - (%message (gensym))) - (labels ((keyword-ll-entry-p (entry) - (eql (schar (symbol-name entry) 0) #\&)) - (valid-bare-ll-entry-p (entry) - (or (not (keyword-ll-entry-p entry)) - (member entry valid-bare-ll-keywords :test 'string=))) - (append-&rest-p (last-entries destructuring-ll) - (not (or (null last-entries) - (member '&rest destructuring-ll :test 'string=))))) - (let* ((last-entries (member '&last lambda-list :test 'string=)) - (last-variable (second last-entries)) - (destructuring-ll (butlast lambda-list (length last-entries))) - (invalid-ll-entries (remove-if #'valid-bare-ll-entry-p - destructuring-ll))) - (unless (or (null last-entries) (= 2 (length last-entries))) - (error "Invalid number of &last arguments in ~S" lambda-list)) - (when (and last-variable (member last-variable destructuring-ll)) - (error "Duplicate entry ~S in lambda list ~S" - last-variable lambda-list)) - (when invalid-ll-entries - (error "Invalid lambda list entries ~S found in ~S" - invalid-ll-entries lambda-list)) - `(let ((,%message ,message)) - (let (,@(when last-entries - `((,last-variable (car (last (arguments ,%message))))))) - (destructuring-bind ,(if (append-&rest-p last-entries - destructuring-ll) - (append destructuring-ll - `(&rest ,nothing)) - destructuring-ll) - (arguments ,%message) - ,@(when (append-&rest-p last-entries destructuring-ll) - `((declare (ignore ,nothing)))) - ,@body))))))) +reqtrailingvars::= [&req var*] +lambda-list::= (wholevar reqvars optvars restvar reqtrailingvars) + +With the exception of &req (which is new) and &rest, all lambda list +keywords are analogous to a destructuring lambda list (see clhs 3.4.5). + +If &req is specified, these values are consumed off the end of the list +before processing any preceeding &optional or &rest keywords. + +For any variable, the `:ignored' keyword can be passed instead, +indicating the binding should be ignored in the `body'." + (let ((%message (gensym)) + (%args (gensym)) + (%arg-count (gensym)) + (valid-keywords '(&whole &optional &rest &req))) + (labels ((lambda-key-p (x) + (member x valid-keywords)) + (ignored-p (x) + (eq x :ignored)) + (count-valid-keys (lambda-list) + (count-if #'lambda-key-p lambda-list)) + (replace-ignored (lambda-list) + (let ((ignores)) + (values (mapcar #'(lambda (x) + (if (ignored-p x) + (let ((y (gensym))) + (push y ignores) + y) + x)) + lambda-list) + ignores))) + (bind-req-trail (req-trail args body) + (let ((req-syms (cdr req-trail))) + (if (and req-trail + (notevery #'ignored-p req-syms)) + (multiple-value-bind + (ll ignores) (replace-ignored req-syms) + `(destructuring-bind + ,ll ,args + ,(if ignores + `(declare (ignore ,@ignores)) + (values)) + ,body)) + body)))) + + (let* ((whole-var (when (eq (car lambda-list) '&whole) + (second lambda-list))) + (lambda-list (if whole-var (nthcdr 2 lambda-list) lambda-list)) + (opt-entries (member '&optional lambda-list)) + (rest-entries (member '&rest lambda-list)) + (req-trail (member '&req lambda-list)) + (destructuring-ll (butlast lambda-list (length req-trail))) + (longest-sublist (cond + (opt-entries opt-entries) + (rest-entries rest-entries) + (req-trail req-trail) + (t nil))) + (min-entries (+ (if req-trail (1- (length req-trail)) 0) + ;; required start && end + (- (- (length lambda-list) + (count-valid-keys lambda-list)) + (- (length longest-sublist) + (count-valid-keys longest-sublist))))) + (max-entries (when (null rest-entries) + ;; required start && end && optionals + (+ min-entries + (if opt-entries + (- (1- (length opt-entries)) + (length req-trail)) + 0))))) + + `(let* ((,%message ,message) + (,%args (arguments ,%message)) + (,%arg-count (length ,%args)) + ,@(if (and whole-var + (not (ignored-p whole-var))) + `((,whole-var ,%args)) + (values))) + (when ,(if max-entries + `(not (and (<= ,min-entries ,%arg-count) + (<= ,%arg-count ,max-entries))) + `(> ,min-entries ,%arg-count)) + ;; we want to raise a cl-irc condition here! + (error "Unexpected protocol input")) + ,(bind-req-trail + req-trail + `(last ,%args ,(1- (length req-trail))) + (multiple-value-bind + (ll ignores) (replace-ignored destructuring-ll) + `(destructuring-bind + ,ll + ,(if req-trail + `(butlast ,%args ,(1- (length req-trail))) + %args) + ,(if ignores + `(declare (ignore ,@ignores)) + (values)) + ,@body)))))))) + ;; ;; RPL_ISUPPORT support routines

1 0

[cl-irc-cvs] r160 - trunk
by ehuelsmann＠common-lisp.net 22 May '06

22 May '06

Author: ehuelsmann Date: Mon May 22 16:21:38 2006 New Revision: 160 Modified: trunk/command.lisp (contents, props changed) trunk/event.lisp (contents, props changed) trunk/parse-message.lisp (contents, props changed) trunk/protocol.lisp (contents, props changed) trunk/variable.lisp (contents, props changed) Log: Change Source to URL keyword (remainder of CVS to svn conversion. Modified: trunk/command.lisp ============================================================================== --- trunk/command.lisp (original) +++ trunk/command.lisp Mon May 22 16:21:38 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See LICENSE for licensing information. Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Mon May 22 16:21:38 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See LICENSE for licensing information. Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Mon May 22 16:21:38 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See the LICENSE file for licensing information. Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Mon May 22 16:21:38 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See LICENSE for licensing information. Modified: trunk/variable.lisp ============================================================================== --- trunk/variable.lisp (original) +++ trunk/variable.lisp Mon May 22 16:21:38 2006 @@ -1,5 +1,5 @@ ;;;; $Id$ -;;;; $Source$ +;;;; $URL$ ;;;; See the LICENSE file for licensing information.

1 0

[cl-irc-cvs] r159 - trunk
by ehuelsmann＠common-lisp.net 22 May '06

22 May '06

Author: ehuelsmann Date: Mon May 22 16:01:09 2006 New Revision: 159 Modified: trunk/event.lisp Log: Mostly resolve issue #17: decode RPL_ISUPPORT encoded characters. Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Mon May 22 16:01:09 2006 @@ -70,31 +70,55 @@ (declare (ignore target)) (let* ((connection (connection message)) (current-case-mapping (case-map-name connection))) - (setf (server-capabilities connection) - (reduce #'(lambda (x y) - ;; O(n^2), but we're talking small lists anyway... - ;; maybe I should have chosen a hash interface - ;; after all... - (if (assoc (first y) x :test #'string=) - x - (cons y x))) - (append - (mapcar #'(lambda (x) - (let ((eq-pos (position #\= x))) - (if eq-pos - (list (substring x 0 eq-pos) - (substring x (1+ eq-pos))) - (list x)))) capabilities) - (server-capabilities connection)) - :initial-value '())) - (setf (channel-mode-descriptions connection) - (chanmode-descs-from-isupport (server-capabilities connection)) - (nick-prefixes connection) - (nick-prefixes-from-isupport (server-capabilities connection))) - (when (not (equal current-case-mapping - (case-map-name connection))) - ;; we need to re-normalize nicks and channel names - (re-apply-case-mapping connection))))) + (flet ((split-arg (x) + (let ((eq-pos (position #\= x))) + (if eq-pos + (list (substring x 0 eq-pos) + (substring x (1+ eq-pos))) + (list x)))) + (decode-arg (text) + ;; decode \xHH into (char-code HH) + ;; btw: how should that work with multibyte utf8? + (format nil "~{~A~}" + (do* ((start 0 (+ 4 pos)) + (pos (search "\\x" text) + (search "\\x" text :start2 (1+ pos))) + (points)) + ((null pos) + (reverse (push (substring text start) points))) + (push (substring text start pos) points) + (push (code-char (parse-integer text + :start (+ 2 pos) + :end (+ 4 pos) + :junk-allowed nil + :radix 16)) + points)))) + (negate-param (param) + (if (eq #\- (char (first param) 0)) + (assoc (substring (first param) 1) + *default-isupport-values* + :test #'string=) + param))) + + (setf (server-capabilities connection) + (reduce #'(lambda (x y) + (adjoin y x :key #'first :test #'string=)) + (append + (remove nil (mapcar #'negate-param + (mapcar #'(lambda (x) + (mapcar #'decode-arg x)) + (mapcar #'split-arg + capabilities)))) + (server-capabilities connection)) + :initial-value '())) + (setf (channel-mode-descriptions connection) + (chanmode-descs-from-isupport (server-capabilities connection)) + (nick-prefixes connection) + (nick-prefixes-from-isupport (server-capabilities connection))) + (when (not (equal current-case-mapping + (case-map-name connection))) + ;; we need to re-normalize nicks and channel names + (re-apply-case-mapping connection)))))) (defmethod default-hook ((message irc-rpl_whoisuser-message)) (destructuring-bind

1 0

[cl-irc-cvs] r158 - trunk/test
by ehuelsmann＠common-lisp.net 22 May '06

22 May '06

Author: ehuelsmann Date: Mon May 22 15:18:47 2006 New Revision: 158 Modified: trunk/test/ (props changed) Log: Add ignore for fasls.

1 0

[cl-irc-cvs] r157 - trunk
by ehuelsmann＠common-lisp.net 16 May '06

16 May '06

Author: ehuelsmann Date: Tue May 16 16:23:04 2006 New Revision: 157 Modified: trunk/package.lisp trunk/protocol.lisp Log: Fix issue #6: insufficient data to reconnect. Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Tue May 16 16:23:04 2006 @@ -18,6 +18,7 @@ :destructuring-arguments :socket-connect :server-name + :server-port :no-such-reply :irc-mode :boolean-value-mode @@ -61,6 +62,7 @@ :irc-message :source :user + :password :host :command :arguments Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Tue May 16 16:23:04 2006 @@ -110,10 +110,18 @@ ((user :initarg :user :accessor user) + (password + :initarg :password + :accessor password + :initform nil) (server-name :initarg :server-name :accessor server-name :initform "Unknown server") + (server-port + :initarg :server-port + :accessor server-port + :initform *default-irc-server-port*) (network-stream :initarg :network-stream :accessor network-stream @@ -188,7 +196,9 @@ (defun make-connection (&key (connection-type 'connection) (user nil) + (password nil) (server-name "") + (server-port nil) (network-stream nil) (outgoing-external-format *default-outgoing-external-format*) (client-stream t) @@ -199,7 +209,9 @@ :external-format (external-format-fixup outgoing-external-format))) (connection (make-instance connection-type :user user + :password password :server-name server-name + :server-port server-port :network-stream network-stream :output-stream output-stream :client-stream client-stream)))

1 0

[cl-irc-cvs] r156 - trunk
by ehuelsmann＠common-lisp.net 16 May '06

16 May '06

Author: ehuelsmann Date: Tue May 16 00:55:51 2006 New Revision: 156 Modified: trunk/parse-message.lisp trunk/utility.lisp Log: Fix the hasty fix. Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Tue May 16 00:55:51 2006 @@ -58,7 +58,8 @@ "Assuming `string' is a valid IRC message this function returns the trailing-argument part of the message. Returns nil if the trailing-argument part is not present." - (cut-between string #\: '(#\Return) :start start :cut-to-end t)) + (when (< start (length string)) + (cut-between string #\: '(#\Return) :start start :cut-to-end t))) (defun combine-arguments-and-trailing (string &key (start 0)) (multiple-value-bind Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Tue May 16 00:55:51 2006 @@ -146,7 +146,7 @@ (defun substring (string start &optional end) (let* ((end-index (if end end (length string))) - (seq-len (1- (- end-index start)))) + (seq-len (- end-index start))) (make-array seq-len :element-type (array-element-type string) :displaced-to string

1 0

[cl-irc-cvs] r155 - in trunk: . test
by ehuelsmann＠common-lisp.net 16 May '06

16 May '06

Author: ehuelsmann Date: Mon May 15 18:54:48 2006 New Revision: 155 Modified: trunk/parse-message.lisp trunk/test/test-parse-message.lisp trunk/utility.lisp Log: Fix (amongst others) the MODE command where there is no terminating #\Return. Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Mon May 15 18:54:48 2006 @@ -50,7 +50,7 @@ arguments part of the message as a list. Returns nil if the arguments part is not present." (multiple-value-bind (end-position return-argument) - (cut-before string " :" '(#\Return) :start start) + (cut-before string " :" '(#\Return) :start start :cut-to-end t) (values end-position (tokenize-string return-argument :delimiters '(#\Space))))) Modified: trunk/test/test-parse-message.lisp ============================================================================== --- trunk/test/test-parse-message.lisp (original) +++ trunk/test/test-parse-message.lisp Mon May 15 18:54:48 2006 @@ -11,6 +11,7 @@ (defvar *msg4* (format nil ":kire_!~~eenge@adsl-156-35-240.asm.bellsouth.net MODE #lisppaste +k key~A" #\Return)) (defvar *msg5* (format nil ":kire_!~~eenge@adsl-156-35-240.asm.bellsouth.net MODE #lisppaste +bbb *!*(a)somewhere.com *!*(a)somewhereles.com *!*(a)youdontwannaknow.org~A" #\Return)) (defvar *msg6* (format nil ":kire!~~eenge@216.248.178.227 PRIVMSG cl-irc heyhey!~A" #\Return)) +(defvar *msg7* (format nil ":ChanServ!ChanServ@services. MODE #lisppaste +o eh ")) (deftest find-reply-name.1 (irc:find-reply-name 1) :rpl_welcome) @@ -66,3 +67,7 @@ (deftest no-trailing.1 (irc::parse-raw-message *msg6*) "kire" "~eenge" "216.248.178.227" "PRIVMSG" ("cl-irc" "heyhey!")) + +(deftest mode.1 + (irc::parse-raw-message *msg7*) + "ChanServ" "ChanServ" "services." "MODE" ("#lisppaste" "+o" "eh")) Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Mon May 15 18:54:48 2006 @@ -146,7 +146,7 @@ (defun substring (string start &optional end) (let* ((end-index (if end end (length string))) - (seq-len (- end-index start))) + (seq-len (1- (- end-index start)))) (make-array seq-len :element-type (array-element-type string) :displaced-to string

1 0

[cl-irc-cvs] r154 - trunk
by ehuelsmann＠common-lisp.net 14 May '06

14 May '06

Author: ehuelsmann Date: Sun May 14 10:26:40 2006 New Revision: 154 Modified: trunk/event.lisp trunk/protocol.lisp trunk/utility.lisp Log: Fix issues with newly added code. Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Sun May 14 10:26:40 2006 @@ -135,8 +135,8 @@ (let ((channel (find-channel connection channel))) (setf (visibility channel) (or (car (assoc chan-visibility - '((#\= :public) (#\* :private) (#\@ :secret)) - :test #'char=)) + '(("=" :public) ("*" :private) ("@" :secret)) + :test #'string=)) :unknown)) (unless (has-mode-p channel 'namreply-in-progress) (add-mode channel 'namreply-in-progress Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Sun May 14 10:26:40 2006 @@ -335,7 +335,6 @@ :fill-pointer t) '(13 10)) (setf (fill-pointer buf) buf-len) - (print buf) (let* ((message (create-irc-message (try-decode-line buf *default-incoming-external-formats*)))) (setf (connection message) connection) message)) Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Sun May 14 10:26:40 2006 @@ -121,7 +121,7 @@ (let ((read-fun (if (subtypep (stream-element-type stream) 'integer) (if non-blocking #'read-byte-no-hang #'read-byte) (if non-blocking #'read-char-no-hang #'read-char))) - (limit-vector (coerce limit '(vector * t))) + (limit-vector (coerce limit '(vector t *))) (targ-max (1- (length target))) (limit-max (length limit)) (limit-cur 0)

1 0

[cl-irc-cvs] r153 - trunk
by ehuelsmann＠common-lisp.net 14 May '06

14 May '06

Author: ehuelsmann Date: Sun May 14 10:05:43 2006 New Revision: 153 Modified: trunk/event.lisp trunk/package.lisp trunk/protocol.lisp Log: Automatically record channel visibility for library users to use. Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Sun May 14 10:05:43 2006 @@ -132,11 +132,12 @@ (nick chan-visibility channel names) (arguments message) (declare (ignore nick chan-visibility)) - ;; chan-visibility is (member '= '@ '*) - ;; '= == public - ;; '@ == secret - ;; '* == private (let ((channel (find-channel connection channel))) + (setf (visibility channel) + (or (car (assoc chan-visibility + '((#\= :public) (#\* :private) (#\@ :secret)) + :test #'char=)) + :unknown)) (unless (has-mode-p channel 'namreply-in-progress) (add-mode channel 'namreply-in-progress (make-instance 'list-value-mode :value-type :user))) Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Sun May 14 10:05:43 2006 @@ -38,6 +38,7 @@ :normalized-name :topic :modes + :visibility :user-count :users :network-stream Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Sun May 14 10:05:43 2006 @@ -494,6 +494,11 @@ :initarg :modes :accessor modes :initform '()) + (visibility + :initarg :visibility + :accessor visibility + :initform nil + :type '(member nil :public :private :secret :unknown)) (users :initarg :users :accessor users

1 0

[cl-irc-cvs] r152 - trunk
by ehuelsmann＠common-lisp.net 14 May '06

14 May '06

Author: ehuelsmann Date: Sun May 14 09:56:19 2006 New Revision: 152 Modified: trunk/event.lisp trunk/protocol.lisp trunk/utility.lisp Log: Fix SBCL compile warnings, at least one of which was a bug. Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Sun May 14 09:56:19 2006 @@ -129,8 +129,13 @@ (defmethod default-hook ((message irc-rpl_namreply-message)) (let* ((connection (connection message))) (destructuring-bind - (nick chan-mode channel names) + (nick chan-visibility channel names) (arguments message) + (declare (ignore nick chan-visibility)) + ;; chan-visibility is (member '= '@ '*) + ;; '= == public + ;; '@ == secret + ;; '* == private (let ((channel (find-channel connection channel))) (unless (has-mode-p channel 'namreply-in-progress) (add-mode channel 'namreply-in-progress @@ -205,6 +210,7 @@ (destructuring-bind (channel &optional text) arguments + (declare (ignore text)) (let ((channel (find-channel connection channel)) (user (find-user connection source))) (when (and user channel) @@ -225,11 +231,10 @@ (destructuring-bind (target channel &rest mode-arguments) arguments - (declare (ignore target)) (let* ((channel (find-channel connection channel)) (mode-changes (when channel - (parse-mode-arguments connection channel arguments + (parse-mode-arguments connection channel mode-arguments :server-p (user connection))))) (dolist (change mode-changes) (destructuring-bind @@ -281,7 +286,7 @@ (destructuring-bind (channel nick &optional reason) arguments - (declare (ignore arguments)) + (declare (ignore reason)) (let* ((channel (find-channel connection channel)) (user (find-user connection nick))) (when (and user channel) Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Sun May 14 09:56:19 2006 @@ -260,6 +260,7 @@ (defvar *process-count* 0) (defmethod start-process (function name) + (declare (ignorable name)) #+allegro (mp:process-run-function name function) #+cmu (mp:make-process function :name name) #+lispworks (mp:process-run-function name nil function) @@ -273,6 +274,7 @@ (flet (#-(and sbcl (not sb-thread)) (do-loop () (read-message-loop connection))) (let ((name (format nil "irc-hander-~D" (incf *process-count*)))) + (declare (ignorable name)) #+(or allegro cmu lispworks sb-thread openmcl armedbear) (start-process #'do-loop name) #+(and sbcl (not sb-thread)) @@ -292,6 +294,7 @@ (defun stop-background-message-handler (process) "Stops a background message handler process returned by the start function." + (declare (ignorable process)) #+cmu (mp:destroy-process process) #+allegro (mp:process-kill process) #+sb-thread (sb-thread:destroy-thread process) Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Sun May 14 09:56:19 2006 @@ -121,12 +121,13 @@ (let ((read-fun (if (subtypep (stream-element-type stream) 'integer) (if non-blocking #'read-byte-no-hang #'read-byte) (if non-blocking #'read-char-no-hang #'read-char))) - (limit-pos 0) + (limit-vector (coerce limit '(vector * t))) (targ-max (1- (length target))) (limit-max (length limit)) (limit-cur 0) (targ-cur -1)) - (declare (optimize (speed 3) (debug 0))) + (declare (optimize (speed 3) (debug 0)) + (type fixnum targ-cur)) ;; In SBCL read-char is a buffered operations (depending on ;; stream creation parameters), so this loop should be quite efficient ;; For others, if this becomes an efficiency problem, please report... @@ -135,7 +136,7 @@ do (return (values target targ-cur t)) else do (setf (elt target (incf targ-cur)) next-elt) - (if (eql next-elt (elt limit limit-cur)) + (if (eql next-elt (aref limit-vector limit-cur)) (incf limit-cur) (setf limit-cur 0))

1 0

[cl-irc-cvs] r151 - trunk
by ehuelsmann＠common-lisp.net 13 May '06

13 May '06

Author: ehuelsmann Date: Sat May 13 03:56:53 2006 New Revision: 151 Modified: trunk/cl-irc.asd trunk/package.lisp trunk/protocol.lisp trunk/utility.lisp trunk/variable.lisp Log: Resolve issue #2: Start guessing the message encoding. On some lisps, reading character data mismatching the stream external format would break server communication. Modified: trunk/cl-irc.asd ============================================================================== --- trunk/cl-irc.asd (original) +++ trunk/cl-irc.asd Sat May 13 03:56:53 2006 @@ -16,7 +16,7 @@ :version "0.5.2" :licence "MIT" :description "Common Lisp interface to the IRC protocol" - :depends-on (:split-sequence :trivial-sockets) + :depends-on (:split-sequence :trivial-sockets :flexi-streams) :properties ((#:author-email . "cl-irc-devel(a)common-lisp.net") (#:date . "$Date$") ((#:albert #:output-dir) . "doc/api-doc/") Modified: trunk/package.lisp ============================================================================== --- trunk/package.lisp (original) +++ trunk/package.lisp Sat May 13 03:56:53 2006 @@ -41,6 +41,7 @@ :user-count :users :network-stream + :output-stream :client-stream :channels :add-hook Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Sat May 13 03:56:53 2006 @@ -117,7 +117,11 @@ (network-stream :initarg :network-stream :accessor network-stream - :documentation "Stream used to talk to the IRC server.") + :documentation "Stream used to talk binary to the IRC server.") + (output-stream + :initarg :output-stream + :accessor output-stream + :documentation "Stream used to send messages to the IRC server") (server-capabilities :initform *default-isupport-values* :accessor server-capabilities @@ -186,12 +190,18 @@ (user nil) (server-name "") (network-stream nil) + (outgoing-external-format *default-outgoing-external-format*) (client-stream t) (hooks nil)) - (let ((connection (make-instance connection-type + (let* ((output-stream (flexi-streams:make-flexi-stream + network-stream + :element-type 'character + :external-format (external-format-fixup outgoing-external-format))) + (connection (make-instance connection-type :user user :server-name server-name :network-stream network-stream + :output-stream output-stream :client-stream client-stream))) (dolist (hook hooks) (add-hook connection (car hook) (cadr hook))) @@ -292,13 +302,40 @@ (defun read-message-loop (connection) (loop while (read-message connection))) +(defun try-decode-line (line external-formats) + (loop for external-format in external-formats + for decoded = nil + for error = nil + do (multiple-value-setq (decoded error) + (handler-case + (flexi-streams:with-input-from-sequence (in line) + (let ((flexi (flexi-streams:make-flexi-stream in +;; :element-type 'character + :external-format + (external-format-fixup external-format)))) + (read-line flexi nil nil))) + (flexi-streams:flexi-stream-encoding-error () + nil))) + if decoded + do (return decoded))) + (defmethod read-irc-message ((connection connection)) "Read and parse an IRC-message from the `connection'." (handler-case - (let ((message (create-irc-message - (read-line (network-stream connection) t)))) - (setf (connection message) connection) - message) + (multiple-value-bind + (buf buf-len) + ;; Note: we cannot use read-line here (or any other + ;; character based functions), since they may cause conversion + (read-sequence-until (network-stream connection) + (make-array 1024 + :element-type '(unsigned-byte 8) + :fill-pointer t) + '(13 10)) + (setf (fill-pointer buf) buf-len) + (print buf) + (let* ((message (create-irc-message (try-decode-line buf *default-incoming-external-formats*)))) + (setf (connection message) connection) + message)) (end-of-file ()))) ;; satisfy read-message-loop assumption of nil when no more messages @@ -307,8 +344,8 @@ "Turn the arguments into a valid IRC message and send it to the server, via the `connection'." (let ((raw-message (apply #'make-irc-message command arguments))) - (write-sequence raw-message (network-stream connection)) - (force-output (network-stream connection)) + (write-sequence raw-message (output-stream connection)) + (force-output (output-stream connection)) raw-message)) (defmethod get-hooks ((connection connection) (class symbol)) Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Sat May 13 03:56:53 2006 @@ -54,9 +54,8 @@ parameters." (let ((*print-circle* nil)) (format nil - "~A~{ ~A~}~@[ :~A~]~A~A" - command (butlast arguments) (car (last arguments)) - #\Return #\Linefeed))) + "~A~{ ~A~}~@[ :~A~]~%" + command (butlast arguments) (car (last arguments))))) (defun make-ctcp-message (string) "Return a valid IRC CTCP message, as a string, composed by @@ -104,7 +103,45 @@ (defun socket-connect (server port) "Create a socket connected to `server':`port' and return stream for it." - (trivial-sockets:open-stream server port)) + (trivial-sockets:open-stream server port :element-type '(unsigned-byte 8))) + +(defun external-format-fixup (format) + (let ((new-format (copy-list format))) + (setf (getf (cdr new-format) :eol-style) :crlf) + new-format)) + +(defun read-byte-no-hang (stream &optional eof-error-p eof-value) + (declare (optimize (speed 3) (debug 0) (safety 0))) + (when (listen stream) + (read-byte stream eof-error-p eof-value))) + +(defun read-sequence-until (stream target limit &key non-blocking) + "Reads data from `stream' into `target' until the subsequence +`limit' is reached or `target' is not large enough to hold the data." + (let ((read-fun (if (subtypep (stream-element-type stream) 'integer) + (if non-blocking #'read-byte-no-hang #'read-byte) + (if non-blocking #'read-char-no-hang #'read-char))) + (limit-pos 0) + (targ-max (1- (length target))) + (limit-max (length limit)) + (limit-cur 0) + (targ-cur -1)) + (declare (optimize (speed 3) (debug 0))) + ;; In SBCL read-char is a buffered operations (depending on + ;; stream creation parameters), so this loop should be quite efficient + ;; For others, if this becomes an efficiency problem, please report... + (loop for next-elt = (funcall read-fun stream nil nil) + if (null next-elt) + do (return (values target targ-cur t)) + else do + (setf (elt target (incf targ-cur)) next-elt) + (if (eql next-elt (elt limit limit-cur)) + (incf limit-cur) + (setf limit-cur 0)) + + if (or (= targ-cur targ-max) + (= limit-cur limit-max)) + do (return (values target (1+ targ-cur) nil))))) (defun substring (string start &optional end) (let* ((end-index (if end end (length string))) Modified: trunk/variable.lisp ============================================================================== --- trunk/variable.lisp (original) +++ trunk/variable.lisp Sat May 13 03:56:53 2006 @@ -41,6 +41,25 @@ ("PREFIX" ,*default-isupport-PREFIX*) ("TARGMAX"))) +(defparameter *default-outgoing-external-format* '(:utf-8) + "The external-format we use to encode outgoing messages. This + should be an external format spec that flexi-streams accepts. + + :eol-style will always be overridden to be :crlf as required + by the IRC protocol.") + +(defparameter *default-incoming-external-formats* '((:utf-8 :eol-style :crlf) + (:latin1 :eol-style :crlf)) + "The external-formats we use to decode incoming messages. This should + be a list of external format specs that flexi-streams accepts. + + The external formats are tried in order, until one decodes the + message without encoding errors. Note that the last external + format should be a single-byte one with most or even all valid + codepoints (such as latin-1). + + :eol-style will always be overridden to be :crlf as required by the + IRC protocol.") (defvar *dcc-connections* nil)

1 0

[cl-irc-cvs] r150 - trunk
by ehuelsmann＠common-lisp.net 08 May '06

08 May '06

Author: ehuelsmann Date: Mon May 8 17:35:07 2006 New Revision: 150 Removed: trunk/TODO Log: Remove TODO, now that all issues have been moved into the bug tracker.

1 0

[cl-irc-cvs] r149 - trunk
by ehuelsmann＠common-lisp.net 05 May '06

05 May '06

Author: ehuelsmann Date: Fri May 5 17:46:25 2006 New Revision: 149 Modified: trunk/event.lisp trunk/parse-message.lisp trunk/protocol.lisp trunk/utility.lisp Log: More efficient string manipulation. Also remove dependency on #\Return character at the end of each line (making cl-irc windows EOL translating lisp implementation compatible). Modified: trunk/event.lisp ============================================================================== --- trunk/event.lisp (original) +++ trunk/event.lisp Fri May 5 17:46:25 2006 @@ -82,8 +82,8 @@ (mapcar #'(lambda (x) (let ((eq-pos (position #\= x))) (if eq-pos - (list (subseq x 0 eq-pos) - (subseq x (1+ eq-pos))) + (list (substring x 0 eq-pos) + (substring x (1+ eq-pos))) (list x)))) capabilities) (server-capabilities connection)) :initial-value '())) Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Fri May 5 17:46:25 2006 @@ -58,7 +58,7 @@ "Assuming `string' is a valid IRC message this function returns the trailing-argument part of the message. Returns nil if the trailing-argument part is not present." - (cut-between string #\: '(#\Return) :start start)) + (cut-between string #\: '(#\Return) :start start :cut-to-end t)) (defun combine-arguments-and-trailing (string &key (start 0)) (multiple-value-bind Modified: trunk/protocol.lisp ============================================================================== --- trunk/protocol.lisp (original) +++ trunk/protocol.lisp Fri May 5 17:46:25 2006 @@ -687,7 +687,7 @@ (second (assoc "PREFIX" (server-capabilities connection) :test #'string=)))) - (subseq nickname 1) + (substring nickname 1) nickname)) (defun normalize-nickname (connection string) Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Fri May 5 17:46:25 2006 @@ -115,10 +115,11 @@ :displaced-index-offset start))) -(defun cut-between (string start-char end-chars &key (start 0) (cut-extra t)) +(defun cut-between (string start-char end-chars + &key (start 0) (cut-extra t) (cut-to-end nil)) "If `start-char' is not nil, cut string between `start-char' and any of the `end-chars', from `start'. If `start-char' is nil, cut from -`start' until any of the `end-chars'. +`start' until any of the `end-chars' (or sting-end when `cut-to-end' is true). If `cut-extra' is t, we will cut from start + 1 instead of just `start'. @@ -126,9 +127,10 @@ When there is no string matching the input parameters `start' and nil will be returned, otherwise `end-position' and the string are returned." - (let ((end-position (position-if #'(lambda (char) - (member char end-chars)) - string :start (1+ start))) + (let ((end-position (or (position-if #'(lambda (char) + (member char end-chars)) + string :start (1+ start)) + (when cut-to-end (length string)))) (cut-from (if cut-extra (1+ start) start))) @@ -142,8 +144,11 @@ (substring string cut-from end-position)) (values start nil))))) -(defun cut-before (string substring end-chars &key (start 0) (cut-extra t)) - "Cut `string' before `substring' or any of the `end-chars', from `start'. +(defun cut-before (string substring end-chars + &key (start 0) (cut-extra t) (cut-to-end nil)) + "Cut `string' before `substring' or any of the `end-chars', from `start', +if none of substring or end-chars are found, until the end of the string +when `cut-to-end' is true. If `cut-extra' is t, we will cut from start + 1 instead of just `start'. @@ -157,9 +162,10 @@ (substring string (if (and cut-extra (< start end-position)) (1+ start) start) end-position)) - (let ((end-position (position-if #'(lambda (x) - (member x end-chars)) - string :start (1+ start))) + (let ((end-position (or (position-if #'(lambda (x) + (member x end-chars)) + string :start (1+ start)) + (when cut-to-end (length string)))) (cut-from (if cut-extra (1+ start) start))) (if end-position (values end-position @@ -240,8 +246,8 @@ (let ((closing-paren-pos (position #\) prefix))) (when (and (eq (elt prefix 0) #\( ) closing-paren-pos) - (let ((prefixes (subseq prefix (1+ closing-paren-pos))) - (modes (subseq prefix 1 closing-paren-pos))) + (let ((prefixes (substring prefix (1+ closing-paren-pos))) + (modes (substring prefix 1 closing-paren-pos))) (when (= (length prefixes) (length modes)) (values prefixes modes)))))) @@ -355,7 +361,7 @@ (do ((changes (pop arguments) (pop arguments))) ((null changes) (values ops nil)) (let* ((this-op (char changes 0)) - (modes (subseq changes 1)) + (modes (substring changes 1)) (param-req (if (char= this-op #\+) #'mode-desc-param-on-set-p #'mode-desc-param-on-unset-p)))

1 0

[cl-irc-cvs] r148 - trunk
by ehuelsmann＠common-lisp.net 03 May '06

03 May '06

Author: ehuelsmann Date: Wed May 3 17:12:42 2006 New Revision: 148 Modified: trunk/parse-message.lisp trunk/utility.lisp Log: Make message parsing more memory efficient by using displaced arrays. Partially resolve issue #7. Modified: trunk/parse-message.lisp ============================================================================== --- trunk/parse-message.lisp (original) +++ trunk/parse-message.lisp Wed May 3 17:12:42 2006 @@ -112,8 +112,8 @@ (defun ctcp-type-p (string type) "Is the `string' actually a representation of the CTCP `type'?" - (if (string-equal (subseq string 1 (min (length string) - (1+ (length (symbol-name type))))) + (if (string-equal (substring string 1 (min (length string) + (1+ (length (symbol-name type))))) type) type nil)) Modified: trunk/utility.lisp ============================================================================== --- trunk/utility.lisp (original) +++ trunk/utility.lisp Wed May 3 17:12:42 2006 @@ -106,6 +106,14 @@ "Create a socket connected to `server':`port' and return stream for it." (trivial-sockets:open-stream server port)) +(defun substring (string start &optional end) + (let* ((end-index (if end end (length string))) + (seq-len (- end-index start))) + (make-array seq-len + :element-type (array-element-type string) + :displaced-to string + :displaced-index-offset start))) + (defun cut-between (string start-char end-chars &key (start 0) (cut-extra t)) "If `start-char' is not nil, cut string between `start-char' and any @@ -127,11 +135,11 @@ (if (and end-position start-char) (if (eql (char string start) start-char) (values end-position - (subseq string cut-from end-position)) + (substring string cut-from end-position)) (values start nil)) (if end-position (values end-position - (subseq string cut-from end-position)) + (substring string cut-from end-position)) (values start nil))))) (defun cut-before (string substring end-chars &key (start 0) (cut-extra t)) @@ -146,7 +154,7 @@ (let ((end-position (search substring string :start2 start))) (if end-position (values (+ end-position (1- (length substring))) - (subseq string (if (and cut-extra + (substring string (if (and cut-extra (< start end-position)) (1+ start) start) end-position)) (let ((end-position (position-if #'(lambda (x) @@ -155,7 +163,7 @@ (cut-from (if cut-extra (1+ start) start))) (if end-position (values end-position - (subseq string cut-from end-position)) + (substring string cut-from end-position)) (values start nil))))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

cl-irc-cvs May 2006