X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src.lisp;h=b886986a7a3a4c5d3aead501ec201f48c6c504bc;hb=e84aacb8c1e71b332b0ba703b7771be9db1f8bef;hp=426270158992aa6587abb94a12769452991f319f;hpb=59760539abefec1794539a587e007870670811ce;p=puri.git diff --git a/src.lisp b/src.lisp index 4262701..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.7 2003/07/19 20:32:48 kevin Exp $ +;; $Id$ (defpackage #:puri (:use #:cl) + #-allegro (:nicknames #:net.uri) (:export #:uri ; the type and a function #:uri-p @@ -55,16 +56,15 @@ #:uri= #:intern-uri #:unintern-uri - #:do-all-uris)) + #:do-all-uris -(in-package #:puri) + #:uri-parse-error ;; Added by KMR + )) -(eval-when (:compile-toplevel) - (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) @@ -88,21 +88,30 @@ #+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 str 0 size)) + #+scl + (common-lisp::shrink-vector str size) + #-(or allegro cmu lispworks sbcl scl) + (setq str (subseq str 0 size)) + str) -#-allegro +;; 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) - (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) @@ -112,23 +121,22 @@ #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (import '(excl:*current-case-mode* excl:delimited-string-to-list - excl::.parse-error 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) @@ -141,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) @@ -541,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 #\:)) @@ -718,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 @@ -747,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) @@ -761,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 @@ -787,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 @@ -822,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 @@ -858,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))) @@ -883,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))) @@ -903,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) @@ -939,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 @@ -960,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 @@ -975,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: @@ -1235,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))