X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src.lisp;h=b886986a7a3a4c5d3aead501ec201f48c6c504bc;hb=e84aacb8c1e71b332b0ba703b7771be9db1f8bef;hp=e824ef4acff11d39d84e9467225596118f3e87d8;hpb=55a5a4735163dc9adc1e6ee9e49e4b0c335732e2;p=puri.git diff --git a/src.lisp b/src.lisp index e824ef4..b886986 100644 --- a/src.lisp +++ b/src.lisp @@ -22,10 +22,11 @@ ;; Original version from ACL 6.1: ;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer ;; -;; $Id: src.lisp,v 1.5 2003/07/19 13:34:12 kevin Exp $ +;; $Id$ (defpackage #:puri (:use #:cl) + #-allegro (:nicknames #:net.uri) (:export #:uri ; the type and a function #:uri-p @@ -55,63 +56,87 @@ #:uri= #:intern-uri #:unintern-uri - #:do-all-uris)) + #:do-all-uris -(in-package #:puri) + #:uri-parse-error ;; Added by KMR + )) -(eval-when (compile) (declaim (optimize (speed 3)))) +(in-package #:puri) +(eval-when (:compile-toplevel) (declaim (optimize (speed 3)))) -#-(or allegro lispworks) -(define-condition parse-error (error) ()) +#-allegro +(defun parse-body (forms &optional env) + "Parses a body, returns (VALUES docstring declarations forms)" + (declare (ignore env)) + ;; fixme -- need to add parsing of multiple declarations + (let (docstring declarations) + (when (stringp (car forms)) + (setq docstring (car forms)) + (setq forms (cdr forms))) + (when (and (listp (car forms)) + (symbolp (caar forms)) + (string-equal (symbol-name '#:declare) + (symbol-name (caar forms)))) + (setq declarations (car forms)) + (setq forms (cdr forms))) + (values docstring declarations forms))) + (defun shrink-vector (str size) #+allegro (excl::.primcall 'sys::shrink-svector str size) #+sbcl - (sb-kernel:shrink-vector str size) + (setq str (sb-kernel:shrink-vector str size)) #+cmu (lisp::shrink-vector str size) #+lispworks (system::shrink-vector$vector str size) - #+(or allegro cmu sbcl lispworks) - str - #-(or allegro cmu sbcl lispworks) - (subseq new-string 0 (incf new-i))) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) + +;; KMR: Added new condition to handle cross-implementation variances +;; in the parse-error condition many implementations define + +(define-condition uri-parse-error (parse-error) + ((fmt-control :initarg :fmt-control :accessor fmt-control) + (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments )) + (:report (lambda (c stream) + (format stream "Parse error:") + (apply #'format stream (fmt-control c) (fmt-arguments c))))) (defun .parse-error (fmt &rest args) - #+allegro (apply #'excl::.parse-error fmt args) - #-allegro (error - (make-condition 'parse-error :format-control fmt - :format-arguments args))) + (error 'uri-parse-error :fmt-control fmt :fmt-arguments args)) +#-allegro (defun internal-reader-error (stream fmt &rest args) - #+allegro - (apply #'excl::internal-reader-error stream fmt args) - #-allegro - (apply #'format stream - "#u takes a string or list argument: ~s" args)) + (apply #'format stream fmt args)) #-allegro (defvar *current-case-mode* :case-insensitive-upper) -#+allegro (eval-when (compile load eval) +#+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (import '(excl:*current-case-mode* excl:delimited-string-to-list + excl::parse-body + excl::internal-reader-error excl:if*))) #-allegro -(defun position-char (char string start max) +(defmethod position-char (char (string string) start max) (declare (optimize (speed 3) (safety 0) (space 0)) - (fixnum start max) (simple-string string)) + (fixnum start max) (string string)) (do* ((i start (1+ i))) ((= i max) nil) (declare (fixnum i)) - (when (char= char (schar string i)) (return i)))) + (when (char= char (char string i)) (return i)))) #-allegro (defun delimited-string-to-list (string &optional (separator #\space) - skip-terminal) + skip-terminal) (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) (type string string) @@ -124,9 +149,9 @@ ((null end) (if (< pos len) (push (subseq string pos) output) - (when (or (not skip-terminal) (zerop len)) - (push "" output))) - (nreverse output)) + (when (and (plusp len) (not skip-terminal)) + (push "" output))) + (nreverse output)) (declare (type fixnum pos len) (type (or null fixnum) end)) (push (subseq string pos end) output) @@ -223,7 +248,7 @@ ((nid :initarg :nid :initform nil :accessor urn-nid) (nss :initarg :nss :initform nil :accessor urn-nss))) -(eval-when (compile eval) +(eval-when (:compile-toplevel :execute) (defmacro clear-caching-on-slot-change (name) `(defmethod (setf ,name) :around (new-value (self uri)) (declare (ignore new-value)) @@ -374,7 +399,7 @@ (defparameter *reserved-fragment-characters* (reserved-char-vector (remove #\# *excluded-characters*))) -(eval-when (compile eval) +(eval-when (:compile-toplevel :execute) (defun gen-char-range-list (start end) (do* ((res '()) (endcode (1+ (char-int end))) @@ -524,7 +549,7 @@ (setq res (loop (when (>= start end) (return nil)) - (setq c (schar string start)) + (setq c (char string start)) (let ((ci (char-int c))) (if* legal-chars then (if* (and (eq :colon kind) (eq c #\:)) @@ -701,7 +726,7 @@ URI ~s contains illegal character ~s at position ~d." (return (values scheme host port - (apply #'concatenate 'simple-string (nreverse path-components)) + (apply #'concatenate 'string (nreverse path-components)) query fragment))) ;; URN parsing: (15 ;; seen urn:, read nid now @@ -730,7 +755,7 @@ URI ~s contains illegal character ~s at position ~d." (max (the fixnum (length string)))) ((= i max) nil) (declare (fixnum i max)) - (when (char= #\% (schar string i)) + (when (char= #\% (char string i)) (return t)))) (defun parse-path (path-string escape) @@ -744,19 +769,23 @@ URI ~s contains illegal character ~s at position ~d." (pl (cdr path-list) (cdr pl)) segments) ((null pl) path-list) - (if* (cdr (setq segments (delimited-string-to-list (car pl) #\;))) + + (if* (cdr (setq segments + (if* (string= "" (car pl)) + then '("") + else (delimited-string-to-list (car pl) #\;)))) then ;; there is a param -;;; (setf (car pl) segments) (setf (car pl) (mapcar #'(lambda (s) - (decode-escaped-encoding - s escape *reserved-path-characters2*)) - segments)) + (decode-escaped-encoding s escape + ;; decode all %xx: + nil)) + segments)) else ;; no param -;;; (setf (car pl) (car segments)) (setf (car pl) - (decode-escaped-encoding - (car segments) escape *reserved-path-characters2*))))) + (decode-escaped-encoding (car segments) escape + ;; decode all %xx: + nil))))) (defun decode-escaped-encoding (string escape &optional (reserved-chars @@ -770,26 +799,27 @@ URI ~s contains illegal character ~s at position ~d." ch ch2 chc chc2) ((= i max) (shrink-vector new-string new-i)) - (if* (char= #\% (setq ch (schar string i))) + (if* (char= #\% (setq ch (char string i))) then (when (> (+ i 3) max) (.parse-error "Unsyntactic escaped encoding in ~s." string)) - (setq ch (schar string (incf i))) - (setq ch2 (schar string (incf i))) + (setq ch (char string (incf i))) + (setq ch2 (char string (incf i))) (when (not (and (setq chc (digit-char-p ch 16)) (setq chc2 (digit-char-p ch2 16)))) (.parse-error "Non-hexidecimal digits after %: %c%c." ch ch2)) (let ((ci (+ (* 16 chc) chc2))) (if* (or (null reserved-chars) - (= 0 (sbit reserved-chars ci))) + (and (< ci (length reserved-chars)) + (= 0 (sbit reserved-chars ci)))) then ;; ok as is - (setf (schar new-string new-i) + (setf (char new-string new-i) (code-char ci)) - else (setf (schar new-string new-i) #\%) - (setf (schar new-string (incf new-i)) ch) - (setf (schar new-string (incf new-i)) ch2))) - else (setf (schar new-string new-i) ch)))) + else (setf (char new-string new-i) #\%) + (setf (char new-string (incf new-i)) ch) + (setf (char new-string (incf new-i)) ch2))) + else (setf (char new-string new-i) ch)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Printing @@ -805,7 +835,7 @@ URI ~s contains illegal character ~s at position ~d." (path (uri-path uri)) (query (uri-query uri)) (fragment (uri-fragment uri))) - (concatenate 'simple-string + (concatenate 'string (when scheme (encode-escaped-encoding (string-downcase ;; for upper case lisps @@ -818,13 +848,9 @@ URI ~s contains illegal character ~s at position ~d." host *reserved-authority-characters* escape)) (when port ":") (when port -;;;; too slow until ACL 6.0: -;;; (format nil "~d" port) -;;; (princ-to-string port) - #-allegro (princ-to-string port) - #+allegro - (with-output-to-string (s) - (excl::maybe-print-fast s port)) + #-allegro (format nil "~D" port) + #+allegro (with-output-to-string (s) + (excl::maybe-print-fast s port)) ) (when path (encode-escaped-encoding path @@ -845,7 +871,7 @@ URI ~s contains illegal character ~s at position ~d." (pl (cdr path-list) (cdr pl)) (pe (car pl) (car pl))) ((null pl) - (when res (apply #'concatenate 'simple-string (nreverse res)))) + (when res (apply #'concatenate 'string (nreverse res)))) (when (or (null first) (prog1 (eq :absolute first) (setq first nil))) @@ -870,7 +896,7 @@ URI ~s contains illegal character ~s at position ~d." (setf (uri-string urn) (let ((nid (urn-nid urn)) (nss (urn-nss urn))) - (concatenate 'simple-string "urn:" nid ":" nss)))) + (concatenate 'string "urn:" nid ":" nss)))) (if* stream then (format stream "~a" (uri-string urn)) else (uri-string urn))) @@ -890,18 +916,18 @@ URI ~s contains illegal character ~s at position ~d." c ci) ((= i max) (shrink-vector new-string (incf new-i))) - (setq ci (char-int (setq c (schar string i)))) + (setq ci (char-int (setq c (char string i)))) (if* (or (null reserved-chars) (> ci 127) (= 0 (sbit reserved-chars ci))) then ;; ok as is (incf new-i) - (setf (schar new-string new-i) c) + (setf (char new-string new-i) c) else ;; need to escape it (multiple-value-bind (q r) (truncate ci 16) - (setf (schar new-string (incf new-i)) #\%) - (setf (schar new-string (incf new-i)) (elt *escaped-encoding* q)) - (setf (schar new-string (incf new-i)) + (setf (char new-string (incf new-i)) #\%) + (setf (char new-string (incf new-i)) (elt *escaped-encoding* q)) + (setf (char new-string (incf new-i)) (elt *escaped-encoding* r)))))) (defmethod print-object ((uri uri) stream) @@ -926,12 +952,10 @@ URI ~s contains illegal character ~s at position ~d." (defmethod merge-uris ((uri string) (base uri) &optional place) (merge-uris (parse-uri uri) base place)) + (defmethod merge-uris ((uri uri) (base uri) &optional place) - ;; The following is from - ;; http://info.internet.isi.edu/in-notes/rfc/files/rfc2396.txt - ;; and is algorithm we use to merge URIs. - ;; - ;; For more information, see section 5.2 of the RFC. + ;; See ../doc/rfc2396.txt for info on the algorithm we use to merge + ;; URIs. ;; (tagbody ;;;; step 2 @@ -947,7 +971,7 @@ URI ~s contains illegal character ~s at position ~d." (when (uri-fragment uri) (setf (uri-fragment new) (uri-fragment uri))) new))) - + (setq uri (copy-uri uri :place place)) ;;;; step 3 @@ -962,6 +986,18 @@ URI ~s contains illegal character ~s at position ~d." ;;;; step 5 (let ((p (uri-parsed-path uri))) + + ;; bug13133: + ;; The following form causes our implementation to be at odds with + ;; RFC 2396, however this is apparently what was intended by the + ;; authors of the RFC. Specifically, (merge-uris "?y" "/foo") + ;; should return # instead of #, according to + ;; this: +;;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query + (when (null p) + (setf (uri-path uri) (uri-path base)) + (go :done)) + (when (and p (eq :absolute (car p))) (when (equal '(:absolute "") p) ;; Canonicalize the way parsing does: @@ -1185,6 +1221,7 @@ URI ~s contains illegal character ~s at position ~d." ;; bootstrapping (uri= changed from function to method): (when (fboundp 'uri=) (fmakunbound 'uri=)) +(defgeneric uri= (uri1 uri2)) (defmethod uri= ((uri1 uri) (uri2 uri)) (when (not (eq (uri-scheme uri1) (uri-scheme uri2))) (return-from uri= nil)) @@ -1221,8 +1258,8 @@ URI ~s contains illegal character ~s at position ~d." (state :char) c1 c2) ((= i len) t) - (setq c1 (schar nss1 i)) - (setq c2 (schar nss2 i)) + (setq c1 (char nss1 i)) + (setq c2 (char nss2 i)) (ecase state (:char (if* (and (char= #\% c1) (char= #\% c2)) @@ -1261,8 +1298,7 @@ Executes the forms once for each uri with var bound to the current uri" (let ((f (gensym)) (g-ignore (gensym)) (g-uri-space (gensym)) - (body #+allegro (third (excl::parse-body forms env)) - #-allegro forms)) + (body (third (parse-body forms env)))) `(let ((,g-uri-space (or ,uri-space *uris*))) (prog nil (flet ((,f (,var &optional ,g-ignore) @@ -1284,6 +1320,7 @@ Executes the forms once for each uri with var bound to the current uri" stream "#u takes a string or list argument: ~s" arg))))) + #+allegro excl:: #+allegro @@ -1301,7 +1338,17 @@ excl:: ;; timings ;; (don't run under emacs with M-x fi:common-lisp) -#+ignore +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'excl::gc)) + +#-allegro +(defun gc (&rest options) + (declare (ignore options)) + #+sbcl (sb-ext::gc) + #+cmu (ext::gc) + ) + (defun time-uri-module () (declare (optimize (speed 3) (safety 0) (debug 0))) (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo")