From feebbfdc402097d14c9a4cd27bf1a7a12120f7c9 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 31 Aug 2007 18:04:31 +0000 Subject: [PATCH] r11859: Canonicalize whitespace --- src.lisp | 1392 ++++++++++++++++++++++++++-------------------------- tests.lisp | 532 ++++++++++---------- 2 files changed, 962 insertions(+), 962 deletions(-) diff --git a/src.lisp b/src.lisp index f231793..6ba0417 100644 --- a/src.lisp +++ b/src.lisp @@ -8,7 +8,7 @@ ;; ;; This code is free software; you can redistribute it and/or ;; modify it under the terms of the version 2.1 of -;; the GNU Lesser General Public License as published by +;; the GNU Lesser General Public License as published by ;; the Free Software Foundation, as clarified by the ;; preamble found here: ;; http://opensource.franz.com/preamble.html @@ -28,22 +28,22 @@ (:use #:cl) #-allegro (:nicknames #:net.uri) (:export - #:uri ; the type and a function + #:uri ; the type and a function #:uri-p #:copy-uri - #:uri-scheme ; and slots + #:uri-scheme ; and slots #:uri-host #:uri-port #:uri-path #:uri-query #:uri-fragment #:uri-plist - #:uri-authority ; pseudo-slot accessor + #:uri-authority ; pseudo-slot accessor + + #:urn ; class + #:urn-nid ; pseudo-slot accessor + #:urn-nss ; pseudo-slot accessor - #:urn ; class - #:urn-nid ; pseudo-slot accessor - #:urn-nss ; pseudo-slot accessor - #:*strict-parse* #:parse-uri #:merge-uris @@ -51,7 +51,7 @@ #:uri-parsed-path #:render-uri - #:make-uri-space ; interning... + #:make-uri-space ; interning... #:uri-space #:uri= #:intern-uri @@ -76,14 +76,14 @@ (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)))) + (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) @@ -107,8 +107,8 @@ ((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))))) + (format stream "Parse error:") + (apply #'format stream (fmt-control c) (fmt-arguments c))))) (defun .parse-error (fmt &rest args) (error 'uri-parse-error :fmt-control fmt :fmt-arguments args)) @@ -119,41 +119,41 @@ #-allegro (defvar *current-case-mode* :case-insensitive-upper) #+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*))) + (import '(excl:*current-case-mode* + excl:delimited-string-to-list + excl::parse-body + excl::internal-reader-error + excl:if*))) #-allegro (defmethod position-char (char (string string) start max) (declare (optimize (speed 3) (safety 0) (space 0)) - (fixnum start max) (string string)) + (fixnum start max) (string string)) (do* ((i start (1+ i))) ((= i max) nil) (declare (fixnum i)) (when (char= char (char string i)) (return i)))) -#-allegro -(defun delimited-string-to-list (string &optional (separator #\space) +#-allegro +(defun delimited-string-to-list (string &optional (separator #\space) skip-terminal) (declare (optimize (speed 3) (safety 0) (space 0) - (compilation-speed 0)) - (type string string) - (type character separator)) + (compilation-speed 0)) + (type string string) + (type character separator)) (do* ((len (length string)) - (output '()) - (pos 0) - (end (position-char separator string pos len) - (position-char separator string pos len))) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) ((null end) - (if (< pos len) - (push (subseq string pos) output) + (if (< pos len) + (push (subseq string pos) output) (when (and (plusp len) (not skip-terminal)) (push "" output))) (nreverse output)) (declare (type fixnum pos len) - (type (or null fixnum) end)) + (type (or null fixnum) end)) (push (subseq string pos end) output) (setq pos (1+ end)))) @@ -163,54 +163,54 @@ (defmacro if* (&rest args) (do ((xx (reverse args) (cdr xx)) - (state :init) - (elseseen nil) - (totalcol nil) - (lookat nil nil) - (col nil)) - ((null xx) - (cond ((eq state :compl) - `(cond ,@totalcol)) - (t (error "if*: illegal form ~s" args)))) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) (cond ((and (symbolp (car xx)) - (member (symbol-name (car xx)) - if*-keyword-list - :test #'string-equal)) - (setq lookat (symbol-name (car xx))))) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) (cond ((eq state :init) - (cond (lookat (cond ((string-equal lookat "thenret") - (setq col nil - state :then)) - (t (error - "if*: bad keyword ~a" lookat)))) - (t (setq state :col - col nil) - (push (car xx) col)))) - ((eq state :col) - (cond (lookat - (cond ((string-equal lookat "else") - (cond (elseseen - (error - "if*: multiples elses"))) - (setq elseseen t) - (setq state :init) - (push `(t ,@col) totalcol)) - ((string-equal lookat "then") - (setq state :then)) - (t (error "if*: bad keyword ~s" - lookat)))) - (t (push (car xx) col)))) - ((eq state :then) - (cond (lookat - (error - "if*: keyword ~s at the wrong place " (car xx))) - (t (setq state :compl) - (push `(,(car xx) ,@col) totalcol)))) - ((eq state :compl) - (cond ((not (string-equal lookat "elseif")) - (error "if*: missing elseif clause "))) - (setq state :init)))))) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init)))))) (defclass uri () @@ -253,9 +253,9 @@ `(defmethod (setf ,name) :around (new-value (self uri)) (declare (ignore new-value)) (prog1 (call-next-method) - (setf (uri-string self) nil) - ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil))) - (setf (uri-hashcode self) nil)))) + (setf (uri-string self) nil) + ,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil))) + (setf (uri-hashcode self) nil)))) ) (clear-caching-on-slot-change uri-scheme) @@ -283,55 +283,55 @@ (defmethod uri-p ((thing t)) nil) (defun copy-uri (uri - &key place - (scheme (when uri (uri-scheme uri))) - (host (when uri (uri-host uri))) - (port (when uri (uri-port uri))) - (path (when uri (uri-path uri))) - (parsed-path - (when uri (copy-list (.uri-parsed-path uri)))) - (query (when uri (uri-query uri))) - (fragment (when uri (uri-fragment uri))) - (plist (when uri (copy-list (uri-plist uri)))) - (class (when uri (class-of uri))) - &aux (escaped (when uri (uri-escaped uri)))) + &key place + (scheme (when uri (uri-scheme uri))) + (host (when uri (uri-host uri))) + (port (when uri (uri-port uri))) + (path (when uri (uri-path uri))) + (parsed-path + (when uri (copy-list (.uri-parsed-path uri)))) + (query (when uri (uri-query uri))) + (fragment (when uri (uri-fragment uri))) + (plist (when uri (copy-list (uri-plist uri)))) + (class (when uri (class-of uri))) + &aux (escaped (when uri (uri-escaped uri)))) (if* place then (setf (uri-scheme place) scheme) - (setf (uri-host place) host) - (setf (uri-port place) port) - (setf (uri-path place) path) - (setf (.uri-parsed-path place) parsed-path) - (setf (uri-query place) query) - (setf (uri-fragment place) fragment) - (setf (uri-plist place) plist) - (setf (uri-escaped place) escaped) - (setf (uri-string place) nil) - (setf (uri-hashcode place) nil) - place + (setf (uri-host place) host) + (setf (uri-port place) port) + (setf (uri-path place) path) + (setf (.uri-parsed-path place) parsed-path) + (setf (uri-query place) query) + (setf (uri-fragment place) fragment) + (setf (uri-plist place) plist) + (setf (uri-escaped place) escaped) + (setf (uri-string place) nil) + (setf (uri-hashcode place) nil) + place elseif (eq 'uri class) then ;; allow the compiler to optimize the call to make-instance: - (make-instance 'uri - :scheme scheme :host host :port port :path path - :parsed-path parsed-path - :query query :fragment fragment :plist plist - :escaped escaped :string nil :hashcode nil) + (make-instance 'uri + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil) else (make-instance class - :scheme scheme :host host :port port :path path - :parsed-path parsed-path - :query query :fragment fragment :plist plist - :escaped escaped :string nil :hashcode nil))) + :scheme scheme :host host :port port :path path + :parsed-path parsed-path + :query query :fragment fragment :plist plist + :escaped escaped :string nil :hashcode nil))) (defmethod uri-parsed-path ((uri uri)) (when (uri-path uri) (when (null (.uri-parsed-path uri)) (setf (.uri-parsed-path uri) - (parse-path (uri-path uri) (uri-escaped uri)))) + (parse-path (uri-path uri) (uri-escaped uri)))) (.uri-parsed-path uri))) (defmethod (setf uri-parsed-path) (path-list (uri uri)) (assert (and (consp path-list) - (or (member (car path-list) '(:absolute :relative) - :test #'eq)))) + (or (member (car path-list) '(:absolute :relative) + :test #'eq)))) (setf (uri-path uri) (render-parsed-path path-list t)) (setf (.uri-parsed-path uri) path-list) path-list) @@ -362,8 +362,8 @@ (defun reserved-char-vector (chars &key except) (do* ((a (make-array 127 :element-type 'bit :initial-element 0)) - (chars chars (cdr chars)) - (c (car chars) (car chars))) + (chars chars (cdr chars)) + (c (car chars) (car chars))) ((null chars) a) (if* (and except (member c except :test #'char=)) thenret @@ -372,17 +372,17 @@ (defparameter *reserved-characters* (reserved-char-vector (append *excluded-characters* - '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%)))) + '(#\; #\/ #\? #\: #\@ #\& #\= #\+ #\$ #\, #\%)))) (defparameter *reserved-authority-characters* (reserved-char-vector (append *excluded-characters* '(#\; #\/ #\? #\: #\@)))) (defparameter *reserved-path-characters* (reserved-char-vector (append *excluded-characters* - '(#\; + '(#\; ;;;;The rfc says this should be here, but it doesn't make sense. - ;; #\= - #\/ #\?)))) + ;; #\= + #\/ #\?)))) (defparameter *reserved-fragment-characters* (reserved-char-vector (remove #\# *excluded-characters*))) @@ -390,17 +390,17 @@ (eval-when (:compile-toplevel :execute) (defun gen-char-range-list (start end) (do* ((res '()) - (endcode (1+ (char-int end))) - (chcode (char-int start) - (1+ chcode)) - (hyphen nil)) + (endcode (1+ (char-int end))) + (chcode (char-int start) + (1+ chcode)) + (hyphen nil)) ((= chcode endcode) ;; - has to be first, otherwise it signifies a range! (if* hyphen - then (setq res (nreverse res)) - (push #\- res) - res - else (nreverse res))) + then (setq res (nreverse res)) + (push #\- res) + res + else (nreverse res))) (if* (= #.(char-int #\-) chcode) then (setq hyphen t) else (push (code-char chcode) res)))) @@ -409,9 +409,9 @@ (defparameter *valid-nid-characters* (reserved-char-vector '#.(nconc (gen-char-range-list #\a #\z) - (gen-char-range-list #\A #\Z) - (gen-char-range-list #\0 #\9) - '(#\- #\. #\+)))) + (gen-char-range-list #\A #\Z) + (gen-char-range-list #\0 #\9) + '(#\- #\. #\+)))) (defparameter *reserved-nss-characters* (reserved-char-vector (append *excluded-characters* '(#\& #\~ #\/ #\?)))) @@ -427,70 +427,70 @@ (defun parse-uri (thing &key (class 'uri) &aux escape) (when (uri-p thing) (return-from parse-uri thing)) - + (setq escape (escape-p thing)) (multiple-value-bind (scheme host port path query fragment) (parse-uri-string thing) (when scheme (setq scheme - (intern (funcall - (case *current-case-mode* - ((:case-insensitive-upper :case-sensitive-upper) - #'string-upcase) - ((:case-insensitive-lower :case-sensitive-lower) - #'string-downcase)) - (decode-escaped-encoding scheme escape)) - (find-package :keyword)))) - + (intern (funcall + (case *current-case-mode* + ((:case-insensitive-upper :case-sensitive-upper) + #'string-upcase) + ((:case-insensitive-lower :case-sensitive-lower) + #'string-downcase)) + (decode-escaped-encoding scheme escape)) + (find-package :keyword)))) + (when (and scheme (eq :urn scheme)) (return-from parse-uri - (make-instance 'urn :scheme scheme :nid host :nss path))) - + (make-instance 'urn :scheme scheme :nid host :nss path))) + (when host (setq host (decode-escaped-encoding host escape))) (when port (setq port (read-from-string port)) (when (not (numberp port)) (error "port is not a number: ~s." port)) (when (not (plusp port)) - (error "port is not a positive integer: ~d." port)) + (error "port is not a positive integer: ~d." port)) (when (eql port (case scheme - (:http 80) - (:https 443) - (:ftp 21) - (:telnet 23))) - (setq port nil))) + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23))) + (setq port nil))) (when (or (string= "" path) - (and ;; we canonicalize away a reference to just /: - scheme - (member scheme '(:http :https :ftp) :test #'eq) - (string= "/" path))) + (and ;; we canonicalize away a reference to just /: + scheme + (member scheme '(:http :https :ftp) :test #'eq) + (string= "/" path))) (setq path nil)) (when path (setq path - (decode-escaped-encoding path escape *reserved-path-characters*))) + (decode-escaped-encoding path escape *reserved-path-characters*))) (when query (setq query (decode-escaped-encoding query escape))) (when fragment (setq fragment - (decode-escaped-encoding fragment escape - *reserved-fragment-characters*))) + (decode-escaped-encoding fragment escape + *reserved-fragment-characters*))) (if* (eq 'uri class) then ;; allow the compiler to optimize the make-instance call: - (make-instance 'uri - :scheme scheme - :host host - :port port - :path path - :query query - :fragment fragment - :escaped escape) + (make-instance 'uri + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape) else ;; do it the slow way: - (make-instance class - :scheme scheme - :host host - :port port - :path path - :query query - :fragment fragment - :escaped escape)))) + (make-instance class + :scheme scheme + :host host + :port port + :path path + :query query + :fragment fragment + :escaped escape)))) (defmethod uri ((thing uri)) thing) @@ -514,239 +514,239 @@ ;; (\?([^#]*))? ;; (#(.*))? (let* ((state 0) - (start 0) - (end (length string)) - (tokval nil) - (scheme nil) - (host nil) - (port nil) - (path-components '()) - (query nil) - (fragment nil) - ;; namespace identifier, for urn parsing only: - (nid nil)) + (start 0) + (end (length string)) + (tokval nil) + (scheme nil) + (host nil) + (port nil) + (path-components '()) + (query nil) + (fragment nil) + ;; namespace identifier, for urn parsing only: + (nid nil)) (declare (fixnum state start end)) (flet ((read-token (kind &optional legal-chars) - (setq tokval nil) - (if* (>= start end) - then :end - else (let ((sindex start) - (res nil) - c) - (declare (fixnum sindex)) - (setq res - (loop - (when (>= start end) (return nil)) - (setq c (char string start)) - (let ((ci (char-int c))) - (if* legal-chars - then (if* (and (eq :colon kind) (eq c #\:)) - then (return :colon) - elseif (= 0 (sbit legal-chars ci)) - then (.parse-error - "~ + (setq tokval nil) + (if* (>= start end) + then :end + else (let ((sindex start) + (res nil) + c) + (declare (fixnum sindex)) + (setq res + (loop + (when (>= start end) (return nil)) + (setq c (char string start)) + (let ((ci (char-int c))) + (if* legal-chars + then (if* (and (eq :colon kind) (eq c #\:)) + then (return :colon) + elseif (= 0 (sbit legal-chars ci)) + then (.parse-error + "~ URI ~s contains illegal character ~s at position ~d." - string c start)) - elseif (and (< ci 128) - *strict-parse* - (= 1 (sbit illegal-chars ci))) - then (.parse-error "~ + string c start)) + elseif (and (< ci 128) + *strict-parse* + (= 1 (sbit illegal-chars ci))) + then (.parse-error "~ URI ~s contains illegal character ~s at position ~d." - string c start))) - (case kind - (:path (case c - (#\? (return :question)) - (#\# (return :hash)))) - (:query (case c (#\# (return :hash)))) - (:rest) - (t (case c - (#\: (return :colon)) - (#\? (return :question)) - (#\# (return :hash)) - (#\/ (return :slash))))) - (incf start))) - (if* (> start sindex) - then ;; we found some chars - ;; before we stopped the parse - (setq tokval (subseq string sindex start)) - :string - else ;; immediately stopped at a special char - (incf start) - res)))) - (failure (&optional why) - (.parse-error "illegal URI: ~s [~d]~@[: ~a~]" - string state why)) - (impossible () - (.parse-error "impossible state: ~d [~s]" state string))) + string c start))) + (case kind + (:path (case c + (#\? (return :question)) + (#\# (return :hash)))) + (:query (case c (#\# (return :hash)))) + (:rest) + (t (case c + (#\: (return :colon)) + (#\? (return :question)) + (#\# (return :hash)) + (#\/ (return :slash))))) + (incf start))) + (if* (> start sindex) + then ;; we found some chars + ;; before we stopped the parse + (setq tokval (subseq string sindex start)) + :string + else ;; immediately stopped at a special char + (incf start) + res)))) + (failure (&optional why) + (.parse-error "illegal URI: ~s [~d]~@[: ~a~]" + string state why)) + (impossible () + (.parse-error "impossible state: ~d [~s]" state string))) (loop - (case state - (0 ;; starting to parse - (ecase (read-token t) - (:colon (failure)) - (:question (setq state 7)) - (:hash (setq state 8)) - (:slash (setq state 3)) - (:string (setq state 1)) - (:end (setq state 9)))) - (1 ;; seen - (let ((token tokval)) - (ecase (read-token t) - (:colon (setq scheme token) - (if* (equalp "urn" scheme) - then (setq state 15) - else (setq state 2))) - (:question (push token path-components) - (setq state 7)) - (:hash (push token path-components) - (setq state 8)) - (:slash (push token path-components) - (push "/" path-components) - (setq state 6)) - (:string (failure)) - (:end (push token path-components) - (setq state 9))))) - (2 ;; seen : - (ecase (read-token t) - (:colon (failure)) - (:question (setq state 7)) - (:hash (setq state 8)) - (:slash (setq state 3)) - (:string (setq state 10)) - (:end (setq state 9)))) - (10 ;; seen : - (let ((token tokval)) - (ecase (read-token t) - (:colon (failure)) - (:question (push token path-components) - (setq state 7)) - (:hash (push token path-components) - (setq state 8)) - (:slash (push token path-components) - (setq state 6)) - (:string (failure)) - (:end (push token path-components) - (setq state 9))))) - (3 ;; seen / or :/ - (ecase (read-token t) - (:colon (failure)) - (:question (push "/" path-components) - (setq state 7)) - (:hash (push "/" path-components) - (setq state 8)) - (:slash (setq state 4)) - (:string (push "/" path-components) - (push tokval path-components) - (setq state 6)) - (:end (push "/" path-components) - (setq state 9)))) - (4 ;; seen [:]// - (ecase (read-token t) - (:colon (failure)) - (:question (failure)) - (:hash (failure)) - (:slash - (if* (and (equalp "file" scheme) - (null host)) - then ;; file:///... - (push "/" path-components) - (setq state 6) - else (failure))) - (:string (setq host tokval) - (setq state 11)) - (:end (failure)))) - (11 ;; seen [:]// - (ecase (read-token t) - (:colon (setq state 5)) - (:question (setq state 7)) - (:hash (setq state 8)) - (:slash (push "/" path-components) - (setq state 6)) - (:string (impossible)) - (:end (setq state 9)))) - (5 ;; seen [:]//: - (ecase (read-token t) - (:colon (failure)) - (:question (failure)) - (:hash (failure)) - (:slash (push "/" path-components) - (setq state 6)) - (:string (setq port tokval) - (setq state 12)) - (:end (failure)))) - (12 ;; seen [:]//:[] - (ecase (read-token t) - (:colon (failure)) - (:question (setq state 7)) - (:hash (setq state 8)) - (:slash (push "/" path-components) - (setq state 6)) - (:string (impossible)) - (:end (setq state 9)))) - (6 ;; seen / - (ecase (read-token :path) - (:question (setq state 7)) - (:hash (setq state 8)) - (:string (push tokval path-components) - (setq state 13)) - (:end (setq state 9)))) - (13 ;; seen path - (ecase (read-token :path) - (:question (setq state 7)) - (:hash (setq state 8)) - (:string (impossible)) - (:end (setq state 9)))) - (7 ;; seen ? - (setq illegal-chars - (if* *strict-parse* - then *strict-illegal-query-characters* - else *illegal-query-characters*)) - (ecase (prog1 (read-token :query) - (setq illegal-chars *illegal-characters*)) - (:hash (setq state 8)) - (:string (setq query tokval) - (setq state 14)) - (:end (setq state 9)))) - (14 ;; query - (ecase (read-token :query) - (:hash (setq state 8)) - (:string (impossible)) - (:end (setq state 9)))) - (8 ;; seen # - (ecase (read-token :rest) - (:string (setq fragment tokval) - (setq state 9)) - (:end (setq state 9)))) - (9 ;; done - (return - (values - scheme host port - (apply #'concatenate 'string (nreverse path-components)) - query fragment))) - ;; URN parsing: - (15 ;; seen urn:, read nid now - (case (read-token :colon *valid-nid-characters*) - (:string (setq nid tokval) - (setq state 16)) - (t (failure "missing namespace identifier")))) - (16 ;; seen urn: - (case (read-token t) - (:colon (setq state 17)) - (t (failure "missing namespace specific string")))) - (17 ;; seen urn::, rest is nss - (return (values scheme - nid - nil - (progn - (setq illegal-chars *reserved-nss-characters*) - (read-token :rest) - tokval)))) - (t (.parse-error - "internal error in parse engine, wrong state: ~s." state))))))) + (case state + (0 ;; starting to parse + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 1)) + (:end (setq state 9)))) + (1 ;; seen + (let ((token tokval)) + (ecase (read-token t) + (:colon (setq scheme token) + (if* (equalp "urn" scheme) + then (setq state 15) + else (setq state 2))) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (push "/" path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (2 ;; seen : + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (setq state 3)) + (:string (setq state 10)) + (:end (setq state 9)))) + (10 ;; seen : + (let ((token tokval)) + (ecase (read-token t) + (:colon (failure)) + (:question (push token path-components) + (setq state 7)) + (:hash (push token path-components) + (setq state 8)) + (:slash (push token path-components) + (setq state 6)) + (:string (failure)) + (:end (push token path-components) + (setq state 9))))) + (3 ;; seen / or :/ + (ecase (read-token t) + (:colon (failure)) + (:question (push "/" path-components) + (setq state 7)) + (:hash (push "/" path-components) + (setq state 8)) + (:slash (setq state 4)) + (:string (push "/" path-components) + (push tokval path-components) + (setq state 6)) + (:end (push "/" path-components) + (setq state 9)))) + (4 ;; seen [:]// + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash + (if* (and (equalp "file" scheme) + (null host)) + then ;; file:///... + (push "/" path-components) + (setq state 6) + else (failure))) + (:string (setq host tokval) + (setq state 11)) + (:end (failure)))) + (11 ;; seen [:]// + (ecase (read-token t) + (:colon (setq state 5)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (5 ;; seen [:]//: + (ecase (read-token t) + (:colon (failure)) + (:question (failure)) + (:hash (failure)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (setq port tokval) + (setq state 12)) + (:end (failure)))) + (12 ;; seen [:]//:[] + (ecase (read-token t) + (:colon (failure)) + (:question (setq state 7)) + (:hash (setq state 8)) + (:slash (push "/" path-components) + (setq state 6)) + (:string (impossible)) + (:end (setq state 9)))) + (6 ;; seen / + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (push tokval path-components) + (setq state 13)) + (:end (setq state 9)))) + (13 ;; seen path + (ecase (read-token :path) + (:question (setq state 7)) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (7 ;; seen ? + (setq illegal-chars + (if* *strict-parse* + then *strict-illegal-query-characters* + else *illegal-query-characters*)) + (ecase (prog1 (read-token :query) + (setq illegal-chars *illegal-characters*)) + (:hash (setq state 8)) + (:string (setq query tokval) + (setq state 14)) + (:end (setq state 9)))) + (14 ;; query + (ecase (read-token :query) + (:hash (setq state 8)) + (:string (impossible)) + (:end (setq state 9)))) + (8 ;; seen # + (ecase (read-token :rest) + (:string (setq fragment tokval) + (setq state 9)) + (:end (setq state 9)))) + (9 ;; done + (return + (values + scheme host port + (apply #'concatenate 'string (nreverse path-components)) + query fragment))) + ;; URN parsing: + (15 ;; seen urn:, read nid now + (case (read-token :colon *valid-nid-characters*) + (:string (setq nid tokval) + (setq state 16)) + (t (failure "missing namespace identifier")))) + (16 ;; seen urn: + (case (read-token t) + (:colon (setq state 17)) + (t (failure "missing namespace specific string")))) + (17 ;; seen urn::, rest is nss + (return (values scheme + nid + nil + (progn + (setq illegal-chars *reserved-nss-characters*) + (read-token :rest) + tokval)))) + (t (.parse-error + "internal error in parse engine, wrong state: ~s." state))))))) (defun escape-p (string) (declare (optimize (speed 3))) (do* ((i 0 (1+ i)) - (max (the fixnum (length string)))) + (max (the fixnum (length string)))) ((= i max) nil) (declare (fixnum i max)) (when (char= #\% (char string i)) @@ -754,143 +754,143 @@ URI ~s contains illegal character ~s at position ~d." (defun parse-path (path-string escape) (do* ((xpath-list (delimited-string-to-list path-string #\/)) - (path-list - (progn - (if* (string= "" (car xpath-list)) - then (setf (car xpath-list) :absolute) - else (push :relative xpath-list)) - xpath-list)) - (pl (cdr path-list) (cdr pl)) - segments) + (path-list + (progn + (if* (string= "" (car xpath-list)) + then (setf (car xpath-list) :absolute) + else (push :relative xpath-list)) + xpath-list)) + (pl (cdr path-list) (cdr pl)) + segments) ((null pl) path-list) - + (if* (cdr (setq segments - (if* (string= "" (car pl)) - then '("") - else (delimited-string-to-list (car pl) #\;)))) + (if* (string= "" (car pl)) + then '("") + else (delimited-string-to-list (car pl) #\;)))) then ;; there is a param - (setf (car pl) - (mapcar #'(lambda (s) - (decode-escaped-encoding s escape - ;; decode all %xx: - nil)) - segments)) + (setf (car pl) + (mapcar #'(lambda (s) + (decode-escaped-encoding s escape + ;; decode all %xx: + nil)) + segments)) else ;; no param - (setf (car pl) - (decode-escaped-encoding (car segments) escape - ;; decode all %xx: - nil))))) + (setf (car pl) + (decode-escaped-encoding (car segments) escape + ;; decode all %xx: + nil))))) (defun decode-escaped-encoding (string escape - &optional (reserved-chars - *reserved-characters*)) + &optional (reserved-chars + *reserved-characters*)) ;; Return a string with the real characters. (when (null escape) (return-from decode-escaped-encoding string)) (do* ((i 0 (1+ i)) - (max (length string)) - (new-string (copy-seq string)) - (new-i 0 (1+ new-i)) - ch ch2 chc chc2) + (max (length string)) + (new-string (copy-seq string)) + (new-i 0 (1+ new-i)) + ch ch2 chc chc2) ((= i max) (shrink-vector new-string new-i)) (if* (char= #\% (setq ch (char string i))) then (when (> (+ i 3) max) - (.parse-error - "Unsyntactic escaped encoding in ~s." string)) - (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) - (> ci 127) ; bug11527 - (= 0 (sbit reserved-chars ci))) - then ;; ok as is - (setf (char new-string new-i) - (code-char ci)) - else (setf (char new-string new-i) #\%) - (setf (char new-string (incf new-i)) ch) - (setf (char new-string (incf new-i)) ch2))) + (.parse-error + "Unsyntactic escaped encoding in ~s." string)) + (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) + (> ci 127) ; bug11527 + (= 0 (sbit reserved-chars ci))) + then ;; ok as is + (setf (char new-string new-i) + (code-char ci)) + 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 (defun render-uri (uri stream - &aux (escape (uri-escaped uri)) - (*print-pretty* nil)) + &aux (escape (uri-escaped uri)) + (*print-pretty* nil)) (when (null (uri-string uri)) (setf (uri-string uri) (let ((scheme (uri-scheme uri)) - (host (uri-host uri)) - (port (uri-port uri)) - (path (uri-path uri)) - (query (uri-query uri)) - (fragment (uri-fragment uri))) - (concatenate 'string - (when scheme - (encode-escaped-encoding - (string-downcase ;; for upper case lisps - (symbol-name scheme)) - *reserved-characters* escape)) - (when scheme ":") - (when (or host (eq :file scheme)) "//") - (when host - (encode-escaped-encoding - host *reserved-authority-characters* escape)) - (when port ":") - (when port - #-allegro (format nil "~D" port) - #+allegro (with-output-to-string (s) - (excl::maybe-print-fast s port)) - ) - (when path - (encode-escaped-encoding path - nil - ;;*reserved-path-characters* - escape)) - (when query "?") - (when query (encode-escaped-encoding query nil escape)) - (when fragment "#") - (when fragment (encode-escaped-encoding fragment nil escape)))))) + (host (uri-host uri)) + (port (uri-port uri)) + (path (uri-path uri)) + (query (uri-query uri)) + (fragment (uri-fragment uri))) + (concatenate 'string + (when scheme + (encode-escaped-encoding + (string-downcase ;; for upper case lisps + (symbol-name scheme)) + *reserved-characters* escape)) + (when scheme ":") + (when (or host (eq :file scheme)) "//") + (when host + (encode-escaped-encoding + host *reserved-authority-characters* escape)) + (when port ":") + (when port + #-allegro (format nil "~D" port) + #+allegro (with-output-to-string (s) + (excl::maybe-print-fast s port)) + ) + (when path + (encode-escaped-encoding path + nil + ;;*reserved-path-characters* + escape)) + (when query "?") + (when query (encode-escaped-encoding query nil escape)) + (when fragment "#") + (when fragment (encode-escaped-encoding fragment nil escape)))))) (if* stream then (format stream "~a" (uri-string uri)) else (uri-string uri))) (defun render-parsed-path (path-list escape) (do* ((res '()) - (first (car path-list)) - (pl (cdr path-list) (cdr pl)) - (pe (car pl) (car pl))) + (first (car path-list)) + (pl (cdr path-list) (cdr pl)) + (pe (car pl) (car pl))) ((null pl) (when res (apply #'concatenate 'string (nreverse res)))) (when (or (null first) - (prog1 (eq :absolute first) - (setq first nil))) + (prog1 (eq :absolute first) + (setq first nil))) (push "/" res)) (if* (atom pe) then (push - (encode-escaped-encoding pe *reserved-path-characters* escape) - res) + (encode-escaped-encoding pe *reserved-path-characters* escape) + res) else ;; contains params - (push (encode-escaped-encoding - (car pe) *reserved-path-characters* escape) - res) - (dolist (item (cdr pe)) - (push ";" res) - (push (encode-escaped-encoding - item *reserved-path-characters* escape) - res))))) + (push (encode-escaped-encoding + (car pe) *reserved-path-characters* escape) + res) + (dolist (item (cdr pe)) + (push ";" res) + (push (encode-escaped-encoding + item *reserved-path-characters* escape) + res))))) (defun render-urn (urn stream - &aux (*print-pretty* nil)) + &aux (*print-pretty* nil)) (when (null (uri-string urn)) (setf (uri-string urn) (let ((nid (urn-nid urn)) - (nss (urn-nss urn))) - (concatenate 'string "urn:" nid ":" nss)))) + (nss (urn-nss urn))) + (concatenate 'string "urn:" nid ":" nss)))) (if* stream then (format stream "~a" (uri-string urn)) else (uri-string urn))) @@ -903,26 +903,26 @@ URI ~s contains illegal character ~s at position ~d." ;; Make a string as big as it possibly needs to be (3 times the original ;; size), and truncate it at the end. (do* ((max (length string)) - (new-max (* 3 max)) ;; worst case new size - (new-string (make-string new-max)) - (i 0 (1+ i)) - (new-i -1) - c ci) + (new-max (* 3 max)) ;; worst case new size + (new-string (make-string new-max)) + (i 0 (1+ i)) + (new-i -1) + c ci) ((= i max) (shrink-vector new-string (incf new-i))) (setq ci (char-int (setq c (char string i)))) (if* (or (null reserved-chars) - (> ci 127) - (= 0 (sbit reserved-chars ci))) + (> ci 127) + (= 0 (sbit reserved-chars ci))) then ;; ok as is - (incf new-i) - (setf (char new-string new-i) c) + (incf new-i) + (setf (char new-string new-i) c) else ;; need to escape it - (multiple-value-bind (q r) (truncate ci 16) - (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)))))) + (multiple-value-bind (q r) (truncate ci 16) + (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) (if* *print-escape* @@ -954,33 +954,33 @@ URI ~s contains illegal character ~s at position ~d." (tagbody ;;;; step 2 (when (and (null (uri-parsed-path uri)) - (null (uri-scheme uri)) - (null (uri-host uri)) - (null (uri-port uri)) - (null (uri-query uri))) + (null (uri-scheme uri)) + (null (uri-host uri)) + (null (uri-port uri)) + (null (uri-query uri))) (return-from merge-uris - (let ((new (copy-uri base :place place))) - (when (uri-query uri) - (setf (uri-query new) (uri-query uri))) - (when (uri-fragment uri) - (setf (uri-fragment new) (uri-fragment uri))) - new))) - + (let ((new (copy-uri base :place place))) + (when (uri-query uri) + (setf (uri-query new) (uri-query uri))) + (when (uri-fragment uri) + (setf (uri-fragment new) (uri-fragment uri))) + new))) + (setq uri (copy-uri uri :place place)) ;;;; step 3 (when (uri-scheme uri) (return-from merge-uris uri)) (setf (uri-scheme uri) (uri-scheme base)) - + ;;;; step 4 (when (uri-host uri) (go :done)) (setf (uri-host uri) (uri-host base)) (setf (uri-port uri) (uri-port base)) - + ;;;; 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 @@ -989,76 +989,76 @@ URI ~s contains illegal character ~s at position ~d." ;; 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)) - + (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: - (setf (uri-path uri) nil)) - (go :done))) - + (when (equal '(:absolute "") p) + ;; Canonicalize the way parsing does: + (setf (uri-path uri) nil)) + (go :done))) + ;;;; step 6 (let* ((base-path - (or (uri-parsed-path base) - ;; needed because we canonicalize away a path of just `/': - '(:absolute ""))) - (path (uri-parsed-path uri)) - new-path-list) + (or (uri-parsed-path base) + ;; needed because we canonicalize away a path of just `/': + '(:absolute ""))) + (path (uri-parsed-path uri)) + new-path-list) (when (not (eq :absolute (car base-path))) - (error "Cannot merge ~a and ~a, since latter is not absolute." - uri base)) + (error "Cannot merge ~a and ~a, since latter is not absolute." + uri base)) ;; steps 6a and 6b: (setq new-path-list - (append (butlast base-path) - (if* path then (cdr path) else '("")))) + (append (butlast base-path) + (if* path then (cdr path) else '("")))) ;; steps 6c and 6d: (let ((last (last new-path-list))) - (if* (atom (car last)) - then (when (string= "." (car last)) - (setf (car last) "")) - else (when (string= "." (caar last)) - (setf (caar last) "")))) + (if* (atom (car last)) + then (when (string= "." (car last)) + (setf (car last) "")) + else (when (string= "." (caar last)) + (setf (caar last) "")))) (setq new-path-list - (delete "." new-path-list :test #'(lambda (a b) - (if* (atom b) - then (string= a b) - else nil)))) + (delete "." new-path-list :test #'(lambda (a b) + (if* (atom b) + then (string= a b) + else nil)))) ;; steps 6e and 6f: (let ((npl (cdr new-path-list)) - index tmp fix-tail) - (setq fix-tail - (string= ".." (let ((l (car (last npl)))) - (if* (atom l) - then l - else (car l))))) - (loop - (setq index - (position ".." npl - :test #'(lambda (a b) - (string= a - (if* (atom b) - then b - else (car b)))))) - (when (null index) (return)) - (when (= 0 index) - ;; The RFC says, in 6g, "that the implementation may handle - ;; this error by retaining these components in the resolved - ;; path, by removing them from the resolved path, or by - ;; avoiding traversal of the reference." The examples in C.2 - ;; imply that we should do the first thing (retain them), so - ;; that's what we'll do. - (return)) - (if* (= 1 index) - then (setq npl (cddr npl)) - else (setq tmp npl) - (dotimes (x (- index 2)) (setq tmp (cdr tmp))) - (setf (cdr tmp) (cdddr tmp)))) - (setf (cdr new-path-list) npl) - (when fix-tail (setq new-path-list (nconc new-path-list '(""))))) + index tmp fix-tail) + (setq fix-tail + (string= ".." (let ((l (car (last npl)))) + (if* (atom l) + then l + else (car l))))) + (loop + (setq index + (position ".." npl + :test #'(lambda (a b) + (string= a + (if* (atom b) + then b + else (car b)))))) + (when (null index) (return)) + (when (= 0 index) + ;; The RFC says, in 6g, "that the implementation may handle + ;; this error by retaining these components in the resolved + ;; path, by removing them from the resolved path, or by + ;; avoiding traversal of the reference." The examples in C.2 + ;; imply that we should do the first thing (retain them), so + ;; that's what we'll do. + (return)) + (if* (= 1 index) + then (setq npl (cddr npl)) + else (setq tmp npl) + (dotimes (x (- index 2)) (setq tmp (cdr tmp))) + (setf (cdr tmp) (cdddr tmp)))) + (setf (cdr new-path-list) npl) + (when fix-tail (setq new-path-list (nconc new-path-list '(""))))) ;; step 6g: ;; don't complain if new-path-list starts with `..'. See comment @@ -1066,12 +1066,12 @@ URI ~s contains illegal character ~s at position ~d." ;; step 6h: (when (or (equal '(:absolute "") new-path-list) - (equal '(:absolute) new-path-list)) - (setq new-path-list nil)) + (equal '(:absolute) new-path-list)) + (setq new-path-list nil)) (setf (uri-path uri) - (render-parsed-path new-path-list - ;; don't know, so have to assume: - t))) + (render-parsed-path new-path-list + ;; don't know, so have to assume: + t))) ;;;; step 7 :done @@ -1088,78 +1088,78 @@ URI ~s contains illegal character ~s at position ~d." (defmethod enough-uri ((uri uri) (base uri) &optional place) (let ((new-scheme nil) - (new-host nil) - (new-port nil) - (new-parsed-path nil)) + (new-host nil) + (new-port nil) + (new-parsed-path nil)) (when (or (and (uri-scheme uri) - (not (equalp (uri-scheme uri) (uri-scheme base)))) - (and (uri-host uri) - (not (equalp (uri-host uri) (uri-host base)))) - (not (equalp (uri-port uri) (uri-port base)))) + (not (equalp (uri-scheme uri) (uri-scheme base)))) + (and (uri-host uri) + (not (equalp (uri-host uri) (uri-host base)))) + (not (equalp (uri-port uri) (uri-port base)))) (return-from enough-uri uri)) (when (null (uri-host uri)) (setq new-host (uri-host base))) (when (null (uri-port uri)) (setq new-port (uri-port base))) - + (when (null (uri-scheme uri)) (setq new-scheme (uri-scheme base))) ;; Now, for the hard one, path. ;; We essentially do here what enough-namestring does. (do* ((base-path (uri-parsed-path base)) - (path (uri-parsed-path uri)) - (bp base-path (cdr bp)) - (p path (cdr p))) - ((or (null bp) (null p)) - ;; If p is nil, that means we have something like - ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so - ;; new-parsed-path will be nil. - (when (null bp) - (setq new-parsed-path (copy-list p)) - (when (not (symbolp (car new-parsed-path))) - (push :relative new-parsed-path)))) + (path (uri-parsed-path uri)) + (bp base-path (cdr bp)) + (p path (cdr p))) + ((or (null bp) (null p)) + ;; If p is nil, that means we have something like + ;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so + ;; new-parsed-path will be nil. + (when (null bp) + (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)))) (if* (equal (car bp) (car p)) - thenret ;; skip it - else (setq new-parsed-path (copy-list p)) - (when (not (symbolp (car new-parsed-path))) - (push :relative new-parsed-path)) - (return))) - - (let ((new-path - (when new-parsed-path - (render-parsed-path new-parsed-path - ;; don't know, so have to assume: - t))) - (new-query (uri-query uri)) - (new-fragment (uri-fragment uri)) - (new-plist (copy-list (uri-plist uri)))) + thenret ;; skip it + else (setq new-parsed-path (copy-list p)) + (when (not (symbolp (car new-parsed-path))) + (push :relative new-parsed-path)) + (return))) + + (let ((new-path + (when new-parsed-path + (render-parsed-path new-parsed-path + ;; don't know, so have to assume: + t))) + (new-query (uri-query uri)) + (new-fragment (uri-fragment uri)) + (new-plist (copy-list (uri-plist uri)))) (if* (and (null new-scheme) - (null new-host) - (null new-port) - (null new-path) - (null new-parsed-path) - (null new-query) - (null new-fragment)) - then ;; can't have a completely empty uri! - (copy-uri nil - :class (class-of uri) - :place place - :path "/" - :plist new-plist) - else (copy-uri nil - :class (class-of uri) - :place place - :scheme new-scheme - :host new-host - :port new-port - :path new-path - :parsed-path new-parsed-path - :query new-query - :fragment new-fragment - :plist new-plist))))) + (null new-host) + (null new-port) + (null new-path) + (null new-parsed-path) + (null new-query) + (null new-fragment)) + then ;; can't have a completely empty uri! + (copy-uri nil + :class (class-of uri) + :place place + :path "/" + :plist new-plist) + else (copy-uri nil + :class (class-of uri) + :place place + :scheme new-scheme + :host new-host + :port new-port + :path new-path + :parsed-path new-parsed-path + :query new-query + :fragment new-fragment + :plist new-plist))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; support for interning URIs @@ -1167,28 +1167,28 @@ URI ~s contains illegal character ~s at position ~d." (defun make-uri-space (&rest keys &key (size 777) &allow-other-keys) #+allegro (apply #'make-hash-table :size size - :hash-function 'uri-hash - :test 'uri= :values nil keys) + :hash-function 'uri-hash + :test 'uri= :values nil keys) #-allegro (apply #'make-hash-table :size size keys)) (defun gethash-uri (uri table) #+allegro (gethash uri table) - #-allegro + #-allegro (let* ((hash (uri-hash uri)) - (existing (gethash hash table))) + (existing (gethash hash table))) (dolist (u existing) (when (uri= u uri) - (return-from gethash-uri (values u t)))) + (return-from gethash-uri (values u t)))) (values nil nil))) (defun puthash-uri (uri table) #+allegro (excl:puthash-key uri table) - #-allegro + #-allegro (let ((existing (gethash (uri-hash uri) table))) (dolist (u existing) (when (uri= u uri) - (return-from puthash-uri u))) + (return-from puthash-uri u))) (setf (gethash (uri-hash uri) table) (cons uri existing)) uri)) @@ -1198,12 +1198,12 @@ URI ~s contains illegal character ~s at position ~d." (if* (uri-hashcode uri) thenret else (setf (uri-hashcode uri) - (sxhash - #+allegro - (render-uri uri nil) - #-allegro - (string-downcase - (render-uri uri nil)))))) + (sxhash + #+allegro + (render-uri uri nil) + #-allegro + (string-downcase + (render-uri uri nil)))))) (defvar *uris* (make-uri-space)) @@ -1224,16 +1224,16 @@ URI ~s contains illegal character ~s at position ~d." ;; port is elided. Hmmmm. This means that this function has to be ;; scheme dependent. Grrrr. (let ((default-port (case (uri-scheme uri1) - (:http 80) - (:https 443) - (:ftp 21) - (:telnet 23)))) + (:http 80) + (:https 443) + (:ftp 21) + (:telnet 23)))) (and (equalp (uri-host uri1) (uri-host uri2)) - (eql (or (uri-port uri1) default-port) - (or (uri-port uri2) default-port)) - (string= (uri-path uri1) (uri-path uri2)) - (string= (uri-query uri1) (uri-query uri2)) - (string= (uri-fragment uri1) (uri-fragment uri2))))) + (eql (or (uri-port uri1) default-port) + (or (uri-port uri2) default-port)) + (string= (uri-path uri1) (uri-path uri2)) + (string= (uri-query uri1) (uri-query uri2)) + (string= (uri-fragment uri1) (uri-fragment uri2))))) (defmethod uri= ((urn1 urn) (urn2 urn)) (when (not (eq (uri-scheme urn1) (uri-scheme urn2))) @@ -1245,21 +1245,21 @@ URI ~s contains illegal character ~s at position ~d." ;; Return t iff the nss values are the same. ;; %2c and %2C are equivalent. (when (or (null nss1) (null nss2) - (not (= (setq len (length nss1)) - (length nss2)))) + (not (= (setq len (length nss1)) + (length nss2)))) (return-from urn-nss-equal nil)) (do* ((i 0 (1+ i)) - (state :char) - c1 c2) + (state :char) + c1 c2) ((= i len) t) (setq c1 (char nss1 i)) (setq c2 (char nss2 i)) (ecase state (:char (if* (and (char= #\% c1) (char= #\% c2)) - then (setq state :percent+1) - elseif (char/= c1 c2) - then (return nil))) + then (setq state :percent+1) + elseif (char/= c1 c2) + then (return nil))) (:percent+1 (when (char-not-equal c1 c2) (return nil)) (setq state :percent+2)) @@ -1284,35 +1284,35 @@ URI ~s contains illegal character ~s at position ~d." else (error "bad uri: ~s." uri))) (defmacro do-all-uris ((var &optional uri-space result-form) - &rest forms - &environment env) + &rest forms + &environment env) "do-all-uris (var [[uri-space] result-form]) - {declaration}* {tag | statement}* + {declaration}* {tag | statement}* 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 (third (parse-body forms env)))) + (g-ignore (gensym)) + (g-uri-space (gensym)) + (body (third (parse-body forms env)))) `(let ((,g-uri-space (or ,uri-space *uris*))) (prog nil - (flet ((,f (,var &optional ,g-ignore) - (declare (ignore-if-unused ,var ,g-ignore)) - (tagbody ,@body))) - (maphash #',f ,g-uri-space)) - (return ,result-form))))) + (flet ((,f (,var &optional ,g-ignore) + (declare (ignore-if-unused ,var ,g-ignore)) + (tagbody ,@body))) + (maphash #',f ,g-uri-space)) + (return ,result-form))))) (defun sharp-u (stream chr arg) (declare (ignore chr arg)) (let ((arg (read stream nil nil t))) (if *read-suppress* - nil + nil (if* (stringp arg) - then (parse-uri arg) - else + then (parse-uri arg) + else - (internal-reader-error - stream - "#u takes a string or list argument: ~s" arg))))) + (internal-reader-error + stream + "#u takes a string or list argument: ~s" arg))))) #+allegro @@ -1346,29 +1346,29 @@ excl:: (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") - (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo")) + (uri2 "http://www.franz.com/a/b;x;y;z/c/%2ffoo?bar=baz&xxx#foo")) (gc t) (gc :tenure) (gc :tenure) (gc :tenure) (format t "~&;;; starting timing testing 1...~%") (time (dotimes (i 100000) (parse-uri uri))) - + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) (format t "~&;;; starting timing testing 2...~%") (let ((uri (parse-uri uri))) (time (dotimes (i 100000) - ;; forces no caching of the printed representation: - (setf (uri-string uri) nil) - (format nil "~a" uri)))) - + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri)))) + (gc t) (gc :tenure) (gc :tenure) (gc :tenure) (format t "~&;;; starting timing testing 3...~%") (time (progn (dotimes (i 100000) (parse-uri uri2)) (let ((uri (parse-uri uri))) - (dotimes (i 100000) - ;; forces no caching of the printed representation: - (setf (uri-string uri) nil) - (format nil "~a" uri))))))) + (dotimes (i 100000) + ;; forces no caching of the printed representation: + (setf (uri-string uri) nil) + (format nil "~a" uri))))))) ;;******** reference output (ultra, modified 5.0.1): ;;; starting timing testing 1... diff --git a/tests.lisp b/tests.lisp index 076b546..b5cbe37 100644 --- a/tests.lisp +++ b/tests.lisp @@ -30,122 +30,122 @@ (defmacro gen-test-forms () (let ((res '()) - (base-uri "http://a/b/c/d;p?q")) + (base-uri "http://a/b/c/d;p?q")) (dolist (x `(;; (relative-uri result base-uri compare-function) ;;;; RFC Appendix C.1 (normal examples) - ("g:h" "g:h" ,base-uri) - ("g" "http://a/b/c/g" ,base-uri) - ("./g" "http://a/b/c/g" ,base-uri) - ("g/" "http://a/b/c/g/" ,base-uri) - ("/g" "http://a/g" ,base-uri) - ("//g" "http://g" ,base-uri) + ("g:h" "g:h" ,base-uri) + ("g" "http://a/b/c/g" ,base-uri) + ("./g" "http://a/b/c/g" ,base-uri) + ("g/" "http://a/b/c/g/" ,base-uri) + ("/g" "http://a/g" ,base-uri) + ("//g" "http://g" ,base-uri) ;; Following was changed from appendix C of RFC 2396 ;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query - #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri) - #+ignore ("?y" "http://a/b/c/?y" ,base-uri) - ("g?y" "http://a/b/c/g?y" ,base-uri) - ("#s" "http://a/b/c/d;p?q#s" ,base-uri) - ("g#s" "http://a/b/c/g#s" ,base-uri) - ("g?y#s" "http://a/b/c/g?y#s" ,base-uri) - (";x" "http://a/b/c/;x" ,base-uri) - ("g;x" "http://a/b/c/g;x" ,base-uri) - ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri) - ("." "http://a/b/c/" ,base-uri) - ("./" "http://a/b/c/" ,base-uri) - (".." "http://a/b/" ,base-uri) - ("../" "http://a/b/" ,base-uri) - ("../g" "http://a/b/g" ,base-uri) - ("../.." "http://a/" ,base-uri) - ("../../" "http://a/" ,base-uri) - ("../../g" "http://a/g" ,base-uri) + #-ignore ("?y" "http://a/b/c/d;p?y" ,base-uri) + #+ignore ("?y" "http://a/b/c/?y" ,base-uri) + ("g?y" "http://a/b/c/g?y" ,base-uri) + ("#s" "http://a/b/c/d;p?q#s" ,base-uri) + ("g#s" "http://a/b/c/g#s" ,base-uri) + ("g?y#s" "http://a/b/c/g?y#s" ,base-uri) + (";x" "http://a/b/c/;x" ,base-uri) + ("g;x" "http://a/b/c/g;x" ,base-uri) + ("g;x?y#s" "http://a/b/c/g;x?y#s" ,base-uri) + ("." "http://a/b/c/" ,base-uri) + ("./" "http://a/b/c/" ,base-uri) + (".." "http://a/b/" ,base-uri) + ("../" "http://a/b/" ,base-uri) + ("../g" "http://a/b/g" ,base-uri) + ("../.." "http://a/" ,base-uri) + ("../../" "http://a/" ,base-uri) + ("../../g" "http://a/g" ,base-uri) ;;;; RFC Appendix C.2 (abnormal examples) - ("" "http://a/b/c/d;p?q" ,base-uri) - ("../../../g" "http://a/../g" ,base-uri) - ("../../../../g" "http://a/../../g" ,base-uri) - ("/./g" "http://a/./g" ,base-uri) - ("/../g" "http://a/../g" ,base-uri) - ("g." "http://a/b/c/g." ,base-uri) - (".g" "http://a/b/c/.g" ,base-uri) - ("g.." "http://a/b/c/g.." ,base-uri) - ("..g" "http://a/b/c/..g" ,base-uri) - ("./../g" "http://a/b/g" ,base-uri) - ("./g/." "http://a/b/c/g/" ,base-uri) - ("g/./h" "http://a/b/c/g/h" ,base-uri) - ("g/../h" "http://a/b/c/h" ,base-uri) - ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri) - ("g;x=1/../y" "http://a/b/c/y" ,base-uri) - ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri) - ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri) - ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri) - ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri) - ("http:g" "http:g" ,base-uri) + ("" "http://a/b/c/d;p?q" ,base-uri) + ("../../../g" "http://a/../g" ,base-uri) + ("../../../../g" "http://a/../../g" ,base-uri) + ("/./g" "http://a/./g" ,base-uri) + ("/../g" "http://a/../g" ,base-uri) + ("g." "http://a/b/c/g." ,base-uri) + (".g" "http://a/b/c/.g" ,base-uri) + ("g.." "http://a/b/c/g.." ,base-uri) + ("..g" "http://a/b/c/..g" ,base-uri) + ("./../g" "http://a/b/g" ,base-uri) + ("./g/." "http://a/b/c/g/" ,base-uri) + ("g/./h" "http://a/b/c/g/h" ,base-uri) + ("g/../h" "http://a/b/c/h" ,base-uri) + ("g;x=1/./y" "http://a/b/c/g;x=1/y" ,base-uri) + ("g;x=1/../y" "http://a/b/c/y" ,base-uri) + ("g?y/./x" "http://a/b/c/g?y/./x" ,base-uri) + ("g?y/../x" "http://a/b/c/g?y/../x" ,base-uri) + ("g#s/./x" "http://a/b/c/g#s/./x" ,base-uri) + ("g#s/../x" "http://a/b/c/g#s/../x" ,base-uri) + ("http:g" "http:g" ,base-uri) - ("foo/bar/baz.htm#foo" - "http://a/b/foo/bar/baz.htm#foo" - "http://a/b/c.htm") - ("foo/bar/baz.htm#foo" - "http://a/b/foo/bar/baz.htm#foo" - "http://a/b/") - ("foo/bar/baz.htm#foo" - "http://a/foo/bar/baz.htm#foo" - "http://a/b") - ("foo/bar;x;y/bam.htm" - "http://a/b/c/foo/bar;x;y/bam.htm" - "http://a/b/c/"))) + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/c.htm") + ("foo/bar/baz.htm#foo" + "http://a/b/foo/bar/baz.htm#foo" + "http://a/b/") + ("foo/bar/baz.htm#foo" + "http://a/foo/bar/baz.htm#foo" + "http://a/b") + ("foo/bar;x;y/bam.htm" + "http://a/b/c/foo/bar;x;y/bam.htm" + "http://a/b/c/"))) (push `(test (intern-uri ,(second x)) - (intern-uri (merge-uris (intern-uri ,(first x)) - (intern-uri ,(third x)))) - :test 'uri=) - res)) + (intern-uri (merge-uris (intern-uri ,(first x)) + (intern-uri ,(third x)))) + :test 'uri=) + res)) ;;;; intern tests (dolist (x '(;; default port and specifying the default port are - ;; supposed to compare the same: - ("http://www.franz.com:80" "http://www.franz.com") - ("http://www.franz.com:80" "http://www.franz.com" eq) - ;; make sure they're `eq': - ("http://www.franz.com:80" "http://www.franz.com" eq) - ("http://www.franz.com" "http://www.franz.com" eq) - ("http://www.franz.com/foo" "http://www.franz.com/foo" eq) - ("http://www.franz.com/foo?bar" - "http://www.franz.com/foo?bar" eq) - ("http://www.franz.com/foo?bar#baz" - "http://www.franz.com/foo?bar#baz" eq) - ("http://WWW.FRANZ.COM" "http://www.franz.com" eq) - ("http://www.FRANZ.com" "http://www.franz.com" eq) - ("http://www.franz.com" "http://www.franz.com/" eq) - (;; %72 is "r", %2f is "/", %3b is ";" - "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/" - "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq))) + ;; supposed to compare the same: + ("http://www.franz.com:80" "http://www.franz.com") + ("http://www.franz.com:80" "http://www.franz.com" eq) + ;; make sure they're `eq': + ("http://www.franz.com:80" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com" eq) + ("http://www.franz.com/foo" "http://www.franz.com/foo" eq) + ("http://www.franz.com/foo?bar" + "http://www.franz.com/foo?bar" eq) + ("http://www.franz.com/foo?bar#baz" + "http://www.franz.com/foo?bar#baz" eq) + ("http://WWW.FRANZ.COM" "http://www.franz.com" eq) + ("http://www.FRANZ.com" "http://www.franz.com" eq) + ("http://www.franz.com" "http://www.franz.com/" eq) + (;; %72 is "r", %2f is "/", %3b is ";" + "http://www.franz.com/ba%72%2f%3b;x;y;z/baz/" + "http://www.franz.com/bar%2f%3b;x;y;z/baz/" eq))) (push `(test (intern-uri ,(second x)) - (intern-uri ,(first x)) - :test ',(if (third x) - (third x) - 'uri=)) - res)) + (intern-uri ,(first x)) + :test ',(if (third x) + (third x) + 'uri=)) + res)) ;;;; parsing and equivalence tests (push `(test - (parse-uri "http://foo+bar?baz=b%26lob+bof") - (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof")) - :test 'uri=) - res) + (parse-uri "http://foo+bar?baz=b%26lob+bof") + (parse-uri (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'uri=) + res) (push '(test - (parse-uri "http://www.foo.com") - (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end - :test 'uri=) - res) + (parse-uri "http://www.foo.com") + (parse-uri (parse-uri "http://www.foo.com?")) ; allow ? at end + :test 'uri=) + res) (push `(test - "baz=b%26lob+bof" - (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof")) - :test 'string=) - res) + "baz=b%26lob+bof" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof")) + :test 'string=) + res) (push `(test - "baz=b%26lob+bof%3d" - (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d")) - :test 'string=) - res) + "baz=b%26lob+bof%3d" + (uri-query (parse-uri "http://foo+bar?baz=b%26lob+bof%3d")) + :test 'string=) + res) (push `(test (parse-uri "xxx?%41") (parse-uri "xxx?A") :test 'uri=) res) @@ -154,260 +154,260 @@ res) (push `(test-error (parse-uri " ") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "foo ") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri " foo ") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "%") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "foo%xyr") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "\"foo\"") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test "%20" (format nil "~a" (parse-uri "%20")) - :test 'string=) - res) + :test 'string=) + res) (push `(test "&" (format nil "~a" (parse-uri "%26")) - :test 'string=) - res) + :test 'string=) + res) (push `(test "foo%23bar" (format nil "~a" (parse-uri "foo%23bar")) - :test 'string=) + :test 'string=) res) (push `(test "foo%23bar#foobar" - (format nil "~a" (parse-uri "foo%23bar#foobar")) - :test 'string=) + (format nil "~a" (parse-uri "foo%23bar#foobar")) + :test 'string=) res) (push `(test "foo%23bar#foobar#baz" - (format nil "~a" (parse-uri "foo%23bar#foobar#baz")) - :test 'string=) + (format nil "~a" (parse-uri "foo%23bar#foobar#baz")) + :test 'string=) res) (push `(test "foo%23bar#foobar#baz" - (format nil "~a" (parse-uri "foo%23bar#foobar%23baz")) - :test 'string=) + (format nil "~a" (parse-uri "foo%23bar#foobar%23baz")) + :test 'string=) res) (push `(test "foo%23bar#foobar/baz" - (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz")) - :test 'string=) + (format nil "~a" (parse-uri "foo%23bar#foobar%2fbaz")) + :test 'string=) res) (push `(test-error (parse-uri "foobar??") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "foobar?foo?") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test "foobar?%3f" - (format nil "~a" (parse-uri "foobar?%3f")) - :test 'string=) - res) + (format nil "~a" (parse-uri "foobar?%3f")) + :test 'string=) + res) (push `(test - "http://foo/bAr;3/baz?baf=3" - (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3")) - :test 'string=) - res) + "http://foo/bAr;3/baz?baf=3" + (format nil "~a" (parse-uri "http://foo/b%41r;3/baz?baf=3")) + :test 'string=) + res) (push `(test - '(:absolute ("/bAr" "3") "baz") - (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")) - :test 'equal) - res) + '(:absolute ("/bAr" "3") "baz") + (uri-parsed-path (parse-uri "http://foo/%2fb%41r;3/baz?baf=3")) + :test 'equal) + res) (push `(test - "/%2fbAr;3/baz" - (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))) - (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz")) - (uri-path u)) - :test 'string=) - res) + "/%2fbAr;3/baz" + (let ((u (parse-uri "http://foo/%2fb%41r;3/baz?baf=3"))) + (setf (uri-parsed-path u) '(:absolute ("/bAr" "3") "baz")) + (uri-path u)) + :test 'string=) + res) (push `(test - "http://www.verada.com:8010/kapow?name=foo%3Dbar%25" - (format nil "~a" - (parse-uri - "http://www.verada.com:8010/kapow?name=foo%3Dbar%25")) - :test 'string=) - res) + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25" + (format nil "~a" + (parse-uri + "http://www.verada.com:8010/kapow?name=foo%3Dbar%25")) + :test 'string=) + res) (push `(test - "ftp://parcftp.xerox.com/pub/pcl/mop/" - (format nil "~a" - (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/")) - :test 'string=) - res) + "ftp://parcftp.xerox.com/pub/pcl/mop/" + (format nil "~a" + (parse-uri "ftp://parcftp.xerox.com:/pub/pcl/mop/")) + :test 'string=) + res) ;;;; enough-uri tests (dolist (x `(("http://www.franz.com/foo/bar/baz.htm" - "http://www.franz.com/foo/bar/" - "baz.htm") - ("http://www.franz.com/foo/bar/baz.htm" - "http://www.franz.com/foo/bar" - "baz.htm") - ("http://www.franz.com:80/foo/bar/baz.htm" - "http://www.franz.com:80/foo/bar" - "baz.htm") - ("http:/foo/bar/baz.htm" "http:/foo/bar" "baz.htm") - ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm") - ("/foo/bar/baz.htm" "/foo/bar" "baz.htm") - ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm") - ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo") - ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo") - - ("http://www.dnai.com/~layer/foo.htm" - "http://www.known.net" - "http://www.dnai.com/~layer/foo.htm") - ("http://www.dnai.com/~layer/foo.htm" - "http://www.dnai.com:8000/~layer/" - "http://www.dnai.com/~layer/foo.htm") - ("http://www.dnai.com:8000/~layer/foo.htm" - "http://www.dnai.com/~layer/" - "http://www.dnai.com:8000/~layer/foo.htm") - ("http://www.franz.com" - "http://www.franz.com" - "/"))) + "http://www.franz.com/foo/bar/" + "baz.htm") + ("http://www.franz.com/foo/bar/baz.htm" + "http://www.franz.com/foo/bar" + "baz.htm") + ("http://www.franz.com:80/foo/bar/baz.htm" + "http://www.franz.com:80/foo/bar" + "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar" "baz.htm") + ("http:/foo/bar/baz.htm" "http:/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar" "baz.htm") + ("/foo/bar/baz.htm" "/foo/bar/" "baz.htm") + ("/foo/bar/baz.htm#foo" "/foo/bar/" "baz.htm#foo") + ("/foo/bar/baz.htm?bar#foo" "/foo/bar/" "baz.htm?bar#foo") + + ("http://www.dnai.com/~layer/foo.htm" + "http://www.known.net" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com/~layer/foo.htm" + "http://www.dnai.com:8000/~layer/" + "http://www.dnai.com/~layer/foo.htm") + ("http://www.dnai.com:8000/~layer/foo.htm" + "http://www.dnai.com/~layer/" + "http://www.dnai.com:8000/~layer/foo.htm") + ("http://www.franz.com" + "http://www.franz.com" + "/"))) (push `(test (parse-uri ,(third x)) - (enough-uri (parse-uri ,(first x)) - (parse-uri ,(second x))) - :test 'uri=) - res)) - + (enough-uri (parse-uri ,(first x)) + (parse-uri ,(second x))) + :test 'uri=) + res)) + ;;;; urn tests, ideas of which are from rfc2141 (let ((urn "urn:com:foo-the-bar")) (push `(test "com" (urn-nid (parse-uri ,urn)) - :test #'string=) - res) + :test #'string=) + res) (push `(test "foo-the-bar" (urn-nss (parse-uri ,urn)) - :test #'string=) - res)) + :test #'string=) + res)) (push `(test-error (parse-uri "urn:") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "urn:foo") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "urn:foo$") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "urn:foo_") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test-error (parse-uri "urn:foo:foo&bar") - :condition-type 'uri-parse-error) - res) + :condition-type 'uri-parse-error) + res) (push `(test (parse-uri "URN:foo:a123,456") - (parse-uri "urn:foo:a123,456") - :test #'uri=) - res) + (parse-uri "urn:foo:a123,456") + :test #'uri=) + res) (push `(test (parse-uri "URN:foo:a123,456") - (parse-uri "urn:FOO:a123,456") - :test #'uri=) - res) + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) (push `(test (parse-uri "urn:foo:a123,456") - (parse-uri "urn:FOO:a123,456") - :test #'uri=) - res) + (parse-uri "urn:FOO:a123,456") + :test #'uri=) + res) (push `(test (parse-uri "URN:FOO:a123%2c456") - (parse-uri "urn:foo:a123%2C456") - :test #'uri=) - res) + (parse-uri "urn:foo:a123%2C456") + :test #'uri=) + res) (push `(test - nil - (uri= (parse-uri "urn:foo:A123,456") - (parse-uri "urn:FOO:a123,456"))) - res) + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:FOO:a123,456"))) + res) (push `(test - nil - (uri= (parse-uri "urn:foo:A123,456") - (parse-uri "urn:foo:a123,456"))) - res) + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "urn:foo:a123,456"))) + res) (push `(test - nil - (uri= (parse-uri "urn:foo:A123,456") - (parse-uri "URN:foo:a123,456"))) - res) + nil + (uri= (parse-uri "urn:foo:A123,456") + (parse-uri "URN:foo:a123,456"))) + res) (push `(test - nil - (uri= (parse-uri "urn:foo:a123%2C456") - (parse-uri "urn:FOO:a123,456"))) - res) + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:FOO:a123,456"))) + res) (push `(test - nil - (uri= (parse-uri "urn:foo:a123%2C456") - (parse-uri "urn:foo:a123,456"))) - res) + nil + (uri= (parse-uri "urn:foo:a123%2C456") + (parse-uri "urn:foo:a123,456"))) + res) (push `(test - nil - (uri= (parse-uri "URN:FOO:a123%2c456") - (parse-uri "urn:foo:a123,456"))) - res) + nil + (uri= (parse-uri "URN:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) (push `(test - nil - (uri= (parse-uri "urn:FOO:a123%2c456") - (parse-uri "urn:foo:a123,456"))) - res) + nil + (uri= (parse-uri "urn:FOO:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) (push `(test - nil - (uri= (parse-uri "urn:foo:a123%2c456") - (parse-uri "urn:foo:a123,456"))) - res) - + nil + (uri= (parse-uri "urn:foo:a123%2c456") + (parse-uri "urn:foo:a123,456"))) + res) + (push `(test t - (uri= (parse-uri "foo") (parse-uri "foo#"))) - res) - + (uri= (parse-uri "foo") (parse-uri "foo#"))) + res) + (push '(let ((puri::*strict-parse* nil)) (test-no-error - (puri:parse-uri - "http://foo.com/bar?a=zip|zop"))) + (puri:parse-uri + "http://foo.com/bar?a=zip|zop"))) res) (push '(test-error (puri:parse-uri "http://foo.com/bar?a=zip|zop") :condition-type 'uri-parse-error) res) - + (push '(let ((puri::*strict-parse* nil)) (test-no-error - (puri:parse-uri - "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041"))) + (puri:parse-uri + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041"))) res) (push '(test-error (puri:parse-uri - "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041") + "http://arc3.msn.com/ADSAdClient31.dll?GetAd?PG=NBCSBU?SC=D2?AN=1.0586041") :condition-type 'uri-parse-error) res) - + (push '(let ((puri::*strict-parse* nil)) (test-no-error - (puri:parse-uri - "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843"))) + (puri:parse-uri + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843"))) res) (push '(test-error (puri:parse-uri - "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843") + "http://scbc.booksonline.com/cgi-bin/ndCGI.exe/Develop/pagClubHome.hrfTIOLI_onWebEvent(hrfTIOLI)?selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&selGetClubOffer.TB_OFFER_ID_ITEM=34487%2e0&selGetClubOffer.TB_OFFER_ID_OFFER=344879%2e0&^CSpCommand.currRowNumber=5&hrfTIOLI=The+Visual+Basic+6+Programmer%27s+Toolkit&SPIDERSESSION=%3f%3f%3f%3f%3f%5f%3f%3f%3f%40%5b%3f%3f%3f%3fBOs%5cH%3f%3f%3f%3f%3f%3f%3f%3f%3fMMpXO%5f%40JG%7d%40%5c%5f%3f%3f%3fECK%5dt%3fLDT%3fTBD%3fDDTxPEToBS%40%5f%5dBDgXVoKBSDs%7cDT%3fK%3fd%3fTIb%7ceHbkeMfh%60LRpO%5cact%5eUC%7bMu%5fyWUGzLUhP%5ebpdWRka%5dFO%3f%5dBopW%3f%40HMrxbMRd%60LOpuMVga%3fv%3fTS%3fpODT%40O&%5euniqueValue=977933764843") :condition-type 'uri-parse-error) res) - + `(progn ,@(nreverse res)))) (defun do-tests () -- 2.34.1