;;
;; 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
(: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
#:uri-parsed-path
#:render-uri
- #:make-uri-space ; interning...
+ #:make-uri-space ; interning...
#:uri-space
#:uri=
#:intern-uri
(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)
((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))
#-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))))
(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 ()
`(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)
(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)
(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
(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*)))
(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))))
(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* '(#\& #\~ #\/ #\?))))
(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)
;; (\?([^#]*))?
;; (#(.*))?
(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 <token><special char>
- (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 <scheme>:
- (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 <scheme>:<token>
- (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 <scheme>:/
- (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 [<scheme>:]//
- (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 [<scheme>:]//<host>
- (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 [<scheme>:]//<host>:
- (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 [<scheme>:]//<host>:[<port>]
- (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:<nid>
- (case (read-token t)
- (:colon (setq state 17))
- (t (failure "missing namespace specific string"))))
- (17 ;; seen urn:<nid>:, 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 <token><special char>
+ (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 <scheme>:
+ (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 <scheme>:<token>
+ (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 <scheme>:/
+ (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 [<scheme>:]//
+ (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 [<scheme>:]//<host>
+ (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 [<scheme>:]//<host>:
+ (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 [<scheme>:]//<host>:[<port>]
+ (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:<nid>
+ (case (read-token t)
+ (:colon (setq state 17))
+ (t (failure "missing namespace specific string"))))
+ (17 ;; seen urn:<nid>:, 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))
(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)))
;; 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*
(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
;; 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
;; 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
(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
(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))
(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))
;; 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)))
;; 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))
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
(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...
(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)
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 "<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 "<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 "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 ()
projects / puri-unicode.git / commitdiff