r10883: update policy

[puri.git] / src.lisp

diff --git a/src.lisp b/src.lisp
index e824ef4acff11d39d84e9467225596118f3e87d8..b886986a7a3a4c5d3aead501ec201f48c6c504bc 100644 (file)
--- a/src.lisp
+++ b/src.lisp
@@ -22,10 +22,11 @@
 ;; Original version from ACL 6.1:
 ;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer
 ;;
 ;; Original version from ACL 6.1:
 ;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer
 ;;

-;; $Id: src.lisp,v 1.5 2003/07/19 13:34:12 kevin Exp $
+;; $Id$

 
 (defpackage #:puri
   (:use #:cl)
 
 (defpackage #:puri
   (:use #:cl)

+  #-allegro (:nicknames #:net.uri)

   (:export
    #:uri                               ; the type and a function
    #:uri-p
   (:export
    #:uri                               ; the type and a function
    #:uri-p


@@ -55,63 +56,87 @@
    #:uri=
    #:intern-uri
    #:unintern-uri
    #:uri=
    #:intern-uri
    #:unintern-uri

-   #:do-all-uris))
+   #:do-all-uris

 
 

-(in-package #:puri)
+   #:uri-parse-error ;; Added by KMR
+   ))

 
 

-(eval-when (compile) (declaim (optimize (speed 3))))
+(in-package #:puri)

 
 

+(eval-when (:compile-toplevel) (declaim (optimize (speed 3))))

 
 
 
 

-#-(or allegro lispworks)
-(define-condition parse-error (error)  ())
+#-allegro
+(defun parse-body (forms &optional env)
+  "Parses a body, returns (VALUES docstring declarations forms)"
+  (declare (ignore env))
+  ;; fixme -- need to add parsing of multiple declarations
+  (let (docstring declarations)
+    (when (stringp (car forms))
+      (setq docstring (car forms))
+      (setq forms (cdr forms)))
+    (when (and (listp (car forms))
+              (symbolp (caar forms))
+              (string-equal (symbol-name '#:declare)
+                            (symbol-name (caar forms))))
+      (setq declarations (car forms))
+      (setq forms (cdr forms)))
+    (values docstring declarations forms)))

 
 

+  

 (defun shrink-vector (str size)
   #+allegro
   (excl::.primcall 'sys::shrink-svector str size)
   #+sbcl
 (defun shrink-vector (str size)
   #+allegro
   (excl::.primcall 'sys::shrink-svector str size)
   #+sbcl

-  (sb-kernel:shrink-vector str size)
+  (setq str (sb-kernel:shrink-vector str size))

   #+cmu
   (lisp::shrink-vector str size)
   #+lispworks
   (system::shrink-vector$vector str size)
   #+cmu
   (lisp::shrink-vector str size)
   #+lispworks
   (system::shrink-vector$vector str size)

-  #+(or allegro cmu sbcl lispworks)
-  str
-  #-(or allegro cmu sbcl lispworks)
-  (subseq new-string 0 (incf new-i)))
+  #+scl
+  (common-lisp::shrink-vector str size)
+  #-(or allegro cmu lispworks sbcl scl)
+  (setq str (subseq str 0 size))
+  str)
+

 
 

+;; KMR: Added new condition to handle cross-implementation variances
+;; in the parse-error condition many implementations define
+
+(define-condition uri-parse-error (parse-error)
+  ((fmt-control :initarg :fmt-control :accessor fmt-control)
+   (fmt-arguments :initarg :fmt-arguments :accessor fmt-arguments ))
+  (:report (lambda (c stream)
+            (format stream "Parse error:")
+            (apply #'format stream (fmt-control c) (fmt-arguments c)))))

 
 (defun .parse-error (fmt &rest args)
 
 (defun .parse-error (fmt &rest args)

-  #+allegro (apply #'excl::.parse-error fmt args)
-  #-allegro (error 
-            (make-condition 'parse-error :format-control fmt
-                            :format-arguments args)))
+  (error 'uri-parse-error :fmt-control fmt :fmt-arguments args))

 
 

+#-allegro

 (defun internal-reader-error (stream fmt &rest args)
 (defun internal-reader-error (stream fmt &rest args)

-  #+allegro
-  (apply #'excl::internal-reader-error stream fmt args)
-  #-allegro
-  (apply #'format stream
-        "#u takes a string or list argument: ~s" args))
+  (apply #'format stream fmt args))

 
 #-allegro (defvar *current-case-mode* :case-insensitive-upper)
 
 #-allegro (defvar *current-case-mode* :case-insensitive-upper)

-#+allegro (eval-when (compile load eval)
+#+allegro (eval-when (:compile-toplevel :load-toplevel :execute)

            (import '(excl:*current-case-mode*
                      excl:delimited-string-to-list
            (import '(excl:*current-case-mode*
                      excl:delimited-string-to-list

+                     excl::parse-body
+                     excl::internal-reader-error

                      excl:if*)))
 
 #-allegro
                      excl:if*)))
 
 #-allegro

-(defun position-char (char string start max)
+(defmethod position-char (char (string string) start max)

   (declare (optimize (speed 3) (safety 0) (space 0))
   (declare (optimize (speed 3) (safety 0) (space 0))

-          (fixnum start max) (simple-string string))
+          (fixnum start max) (string string))

   (do* ((i start (1+ i)))
        ((= i max) nil)
     (declare (fixnum i))
   (do* ((i start (1+ i)))
        ((= i max) nil)
     (declare (fixnum i))

-    (when (char= char (schar string i)) (return i))))
+    (when (char= char (char string i)) (return i))))

 
 #-allegro 
 (defun delimited-string-to-list (string &optional (separator #\space) 
 
 #-allegro 
 (defun delimited-string-to-list (string &optional (separator #\space) 

-                                skip-terminal)
+                                        skip-terminal)

   (declare (optimize (speed 3) (safety 0) (space 0)
                     (compilation-speed 0))
           (type string string)
   (declare (optimize (speed 3) (safety 0) (space 0)
                     (compilation-speed 0))
           (type string string)


@@ -124,9 +149,9 @@
        ((null end)
        (if (< pos len)
            (push (subseq string pos) output)
        ((null end)
        (if (< pos len)
            (push (subseq string pos) output)

-           (when (or (not skip-terminal) (zerop len))
-             (push "" output)))
-       (nreverse output))
+          (when (and (plusp len) (not skip-terminal))
+            (push "" output)))
+        (nreverse output))

     (declare (type fixnum pos len)
             (type (or null fixnum) end))
     (push (subseq string pos end) output)
     (declare (type fixnum pos len)
             (type (or null fixnum) end))
     (push (subseq string pos end) output)


@@ -223,7 +248,7 @@
   ((nid :initarg :nid :initform nil :accessor urn-nid)
    (nss :initarg :nss :initform nil :accessor urn-nss)))
 
   ((nid :initarg :nid :initform nil :accessor urn-nid)
    (nss :initarg :nss :initform nil :accessor urn-nss)))
 

-(eval-when (compile eval)
+(eval-when (:compile-toplevel :execute)

   (defmacro clear-caching-on-slot-change (name)
     `(defmethod (setf ,name) :around (new-value (self uri))
        (declare (ignore new-value))
   (defmacro clear-caching-on-slot-change (name)
     `(defmethod (setf ,name) :around (new-value (self uri))
        (declare (ignore new-value))


@@ -374,7 +399,7 @@
 (defparameter *reserved-fragment-characters*
     (reserved-char-vector (remove #\# *excluded-characters*)))
 
 (defparameter *reserved-fragment-characters*
     (reserved-char-vector (remove #\# *excluded-characters*)))
 

-(eval-when (compile eval)
+(eval-when (:compile-toplevel :execute)

 (defun gen-char-range-list (start end)
   (do* ((res '())
        (endcode (1+ (char-int end)))
 (defun gen-char-range-list (start end)
   (do* ((res '())
        (endcode (1+ (char-int end)))


@@ -524,7 +549,7 @@
                       (setq res
                         (loop
                           (when (>= start end) (return nil))
                       (setq res
                         (loop
                           (when (>= start end) (return nil))

-                          (setq c (schar string start))
+                          (setq c (char string start))

                           (let ((ci (char-int c)))
                             (if* legal-chars
                                then (if* (and (eq :colon kind) (eq c #\:))
                           (let ((ci (char-int c)))
                             (if* legal-chars
                                then (if* (and (eq :colon kind) (eq c #\:))


@@ -701,7 +726,7 @@ URI ~s contains illegal character ~s at position ~d."
           (return
             (values
              scheme host port
           (return
             (values
              scheme host port

-             (apply #'concatenate 'simple-string (nreverse path-components))
+             (apply #'concatenate 'string (nreverse path-components))

              query fragment)))
          ;; URN parsing:
          (15 ;; seen urn:, read nid now
              query fragment)))
          ;; URN parsing:
          (15 ;; seen urn:, read nid now


@@ -730,7 +755,7 @@ URI ~s contains illegal character ~s at position ~d."
        (max (the fixnum (length string))))
       ((= i max) nil)
     (declare (fixnum i max))
        (max (the fixnum (length string))))
       ((= i max) nil)
     (declare (fixnum i max))

-    (when (char= #\% (schar string i))
+    (when (char= #\% (char string i))

       (return t))))
 
 (defun parse-path (path-string escape)
       (return t))))
 
 (defun parse-path (path-string escape)


@@ -744,19 +769,23 @@ URI ~s contains illegal character ~s at position ~d."
        (pl (cdr path-list) (cdr pl))
        segments)
       ((null pl) path-list)
        (pl (cdr path-list) (cdr pl))
        segments)
       ((null pl) path-list)

-    (if* (cdr (setq segments (delimited-string-to-list (car pl) #\;)))
+    
+    (if* (cdr (setq segments
+               (if* (string= "" (car pl))
+                  then '("")
+                  else (delimited-string-to-list (car pl) #\;))))

        then ;; there is a param
        then ;; there is a param

-;;;        (setf (car pl) segments)

            (setf (car pl)
              (mapcar #'(lambda (s)
            (setf (car pl)
              (mapcar #'(lambda (s)

-                         (decode-escaped-encoding
-                          s escape *reserved-path-characters2*))
-              segments))
+                         (decode-escaped-encoding s escape
+                                                  ;; decode all %xx:
+                                                  nil))
+                     segments))

        else ;; no param
        else ;; no param

-;;;        (setf (car pl) (car segments))

            (setf (car pl)
            (setf (car pl)

-             (decode-escaped-encoding
-              (car segments) escape *reserved-path-characters2*)))))
+             (decode-escaped-encoding (car segments) escape
+                                      ;; decode all %xx:
+                                      nil)))))

 
 (defun decode-escaped-encoding (string escape
                                &optional (reserved-chars
 
 (defun decode-escaped-encoding (string escape
                                &optional (reserved-chars


@@ -770,26 +799,27 @@ URI ~s contains illegal character ~s at position ~d."
        ch ch2 chc chc2)
       ((= i max)
        (shrink-vector new-string new-i))
        ch ch2 chc chc2)
       ((= i max)
        (shrink-vector new-string new-i))

-    (if* (char= #\% (setq ch (schar string i)))
+    (if* (char= #\% (setq ch (char string i)))

        then (when (> (+ i 3) max)
              (.parse-error
               "Unsyntactic escaped encoding in ~s." string))
        then (when (> (+ i 3) max)
              (.parse-error
               "Unsyntactic escaped encoding in ~s." string))

-           (setq ch (schar string (incf i)))
-           (setq ch2 (schar string (incf i)))
+           (setq ch (char string (incf i)))
+           (setq ch2 (char string (incf i)))

            (when (not (and (setq chc (digit-char-p ch 16))
                            (setq chc2 (digit-char-p ch2 16))))
              (.parse-error
               "Non-hexidecimal digits after %: %c%c." ch ch2))
            (let ((ci (+ (* 16 chc) chc2)))
              (if* (or (null reserved-chars)
            (when (not (and (setq chc (digit-char-p ch 16))
                            (setq chc2 (digit-char-p ch2 16))))
              (.parse-error
               "Non-hexidecimal digits after %: %c%c." ch ch2))
            (let ((ci (+ (* 16 chc) chc2)))
              (if* (or (null reserved-chars)

-                      (= 0 (sbit reserved-chars ci)))
+                       (and (< ci (length reserved-chars))
+                            (= 0 (sbit reserved-chars ci))))

                 then ;; ok as is
                 then ;; ok as is

-                     (setf (schar new-string new-i)
+                     (setf (char new-string new-i)

                        (code-char ci))
                        (code-char ci))

-                else (setf (schar new-string new-i) #\%)
-                     (setf (schar new-string (incf new-i)) ch)
-                     (setf (schar new-string (incf new-i)) ch2)))
-       else (setf (schar new-string new-i) ch))))
+                else (setf (char new-string new-i) #\%)
+                     (setf (char new-string (incf new-i)) ch)
+                     (setf (char new-string (incf new-i)) ch2)))
+       else (setf (char new-string new-i) ch))))

 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; Printing
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; Printing


@@ -805,7 +835,7 @@ URI ~s contains illegal character ~s at position ~d."
            (path (uri-path uri))
            (query (uri-query uri))
            (fragment (uri-fragment uri)))
            (path (uri-path uri))
            (query (uri-query uri))
            (fragment (uri-fragment uri)))

-       (concatenate 'simple-string
+       (concatenate 'string

          (when scheme
            (encode-escaped-encoding
             (string-downcase ;; for upper case lisps
          (when scheme
            (encode-escaped-encoding
             (string-downcase ;; for upper case lisps


@@ -818,13 +848,9 @@ URI ~s contains illegal character ~s at position ~d."
             host *reserved-authority-characters* escape))
          (when port ":")
          (when port
             host *reserved-authority-characters* escape))
          (when port ":")
          (when port

-;;;; too slow until ACL 6.0:
-;;;        (format nil "~d" port)
-;;;        (princ-to-string port)
-           #-allegro (princ-to-string port)
-           #+allegro
-           (with-output-to-string (s)
-             (excl::maybe-print-fast s port))
+           #-allegro (format nil "~D" port)
+           #+allegro (with-output-to-string (s)
+                       (excl::maybe-print-fast s port))

            )
          (when path
            (encode-escaped-encoding path
            )
          (when path
            (encode-escaped-encoding path


@@ -845,7 +871,7 @@ URI ~s contains illegal character ~s at position ~d."
        (pl (cdr path-list) (cdr pl))
        (pe (car pl) (car pl)))
       ((null pl)
        (pl (cdr path-list) (cdr pl))
        (pe (car pl) (car pl)))
       ((null pl)

-       (when res (apply #'concatenate 'simple-string (nreverse res))))
+       (when res (apply #'concatenate 'string (nreverse res))))

     (when (or (null first)
              (prog1 (eq :absolute first)
                (setq first nil)))
     (when (or (null first)
              (prog1 (eq :absolute first)
                (setq first nil)))


@@ -870,7 +896,7 @@ URI ~s contains illegal character ~s at position ~d."
     (setf (uri-string urn)
       (let ((nid (urn-nid urn))
            (nss (urn-nss urn)))
     (setf (uri-string urn)
       (let ((nid (urn-nid urn))
            (nss (urn-nss urn)))

-       (concatenate 'simple-string "urn:" nid ":" nss))))
+       (concatenate 'string "urn:" nid ":" nss))))

   (if* stream
      then (format stream "~a" (uri-string urn))
      else (uri-string urn)))
   (if* stream
      then (format stream "~a" (uri-string urn))
      else (uri-string urn)))


@@ -890,18 +916,18 @@ URI ~s contains illegal character ~s at position ~d."
        c ci)
       ((= i max)
        (shrink-vector new-string (incf new-i)))
        c ci)
       ((= i max)
        (shrink-vector new-string (incf new-i)))

-    (setq ci (char-int (setq c (schar string i))))
+    (setq ci (char-int (setq c (char string i))))

     (if* (or (null reserved-chars)
             (> ci 127)
             (= 0 (sbit reserved-chars ci)))
        then ;; ok as is
            (incf new-i)
     (if* (or (null reserved-chars)
             (> ci 127)
             (= 0 (sbit reserved-chars ci)))
        then ;; ok as is
            (incf new-i)

-           (setf (schar new-string new-i) c)
+           (setf (char new-string new-i) c)

        else ;; need to escape it
            (multiple-value-bind (q r) (truncate ci 16)
        else ;; need to escape it
            (multiple-value-bind (q r) (truncate ci 16)

-             (setf (schar new-string (incf new-i)) #\%)
-             (setf (schar new-string (incf new-i)) (elt *escaped-encoding* q))
-             (setf (schar new-string (incf new-i))
+             (setf (char new-string (incf new-i)) #\%)
+             (setf (char new-string (incf new-i)) (elt *escaped-encoding* q))
+             (setf (char new-string (incf new-i))

                (elt *escaped-encoding* r))))))
 
 (defmethod print-object ((uri uri) stream)
                (elt *escaped-encoding* r))))))
 
 (defmethod print-object ((uri uri) stream)


@@ -926,12 +952,10 @@ URI ~s contains illegal character ~s at position ~d."
 (defmethod merge-uris ((uri string) (base uri) &optional place)
   (merge-uris (parse-uri uri) base place))
 
 (defmethod merge-uris ((uri string) (base uri) &optional place)
   (merge-uris (parse-uri uri) base place))
 

+

 (defmethod merge-uris ((uri uri) (base uri) &optional place)
 (defmethod merge-uris ((uri uri) (base uri) &optional place)

-  ;; The following is from
-  ;; http://info.internet.isi.edu/in-notes/rfc/files/rfc2396.txt
-  ;; and is algorithm we use to merge URIs.
-  ;;
-  ;; For more information, see section 5.2 of the RFC.
+  ;; See ../doc/rfc2396.txt for info on the algorithm we use to merge
+  ;; URIs.

   ;;
   (tagbody
 ;;;; step 2
   ;;
   (tagbody
 ;;;; step 2


@@ -947,7 +971,7 @@ URI ~s contains illegal character ~s at position ~d."
          (when (uri-fragment uri)
            (setf (uri-fragment new) (uri-fragment uri)))
          new)))
          (when (uri-fragment uri)
            (setf (uri-fragment new) (uri-fragment uri)))
          new)))

-
+    

     (setq uri (copy-uri uri :place place))
 
 ;;;; step 3
     (setq uri (copy-uri uri :place place))
 
 ;;;; step 3


@@ -962,6 +986,18 @@ URI ~s contains illegal character ~s at position ~d."
     
 ;;;; step 5
     (let ((p (uri-parsed-path uri)))
     
 ;;;; step 5
     (let ((p (uri-parsed-path uri)))

+      
+      ;; bug13133:
+      ;; The following form causes our implementation to be at odds with
+      ;; RFC 2396, however this is apparently what was intended by the
+      ;; authors of the RFC.  Specifically, (merge-uris "?y" "/foo")
+      ;; should return #<uri /foo?y> instead of #<uri ?y>, according to
+      ;; this:
+;;; http://www.apache.org/~fielding/uri/rev-2002/issues.html#003-relative-query
+      (when (null p)
+       (setf (uri-path uri) (uri-path base))
+       (go :done))
+      

       (when (and p (eq :absolute (car p)))
        (when (equal '(:absolute "") p)
          ;; Canonicalize the way parsing does:
       (when (and p (eq :absolute (car p)))
        (when (equal '(:absolute "") p)
          ;; Canonicalize the way parsing does:


@@ -1185,6 +1221,7 @@ URI ~s contains illegal character ~s at position ~d."
 ;; bootstrapping (uri= changed from function to method):
 (when (fboundp 'uri=) (fmakunbound 'uri=))
 
 ;; bootstrapping (uri= changed from function to method):
 (when (fboundp 'uri=) (fmakunbound 'uri=))
 

+(defgeneric uri= (uri1 uri2))

 (defmethod uri= ((uri1 uri) (uri2 uri))
   (when (not (eq (uri-scheme uri1) (uri-scheme uri2)))
     (return-from uri= nil))
 (defmethod uri= ((uri1 uri) (uri2 uri))
   (when (not (eq (uri-scheme uri1) (uri-scheme uri2)))
     (return-from uri= nil))


@@ -1221,8 +1258,8 @@ URI ~s contains illegal character ~s at position ~d."
        (state :char)
        c1 c2)
       ((= i len) t)
        (state :char)
        c1 c2)
       ((= i len) t)

-    (setq c1 (schar nss1 i))
-    (setq c2 (schar nss2 i))
+    (setq c1 (char nss1 i))
+    (setq c2 (char nss2 i))

     (ecase state
       (:char
        (if* (and (char= #\% c1) (char= #\% c2))
     (ecase state
       (:char
        (if* (and (char= #\% c1) (char= #\% c2))


@@ -1261,8 +1298,7 @@ Executes the forms once for each uri with var bound to the current uri"
   (let ((f (gensym))
        (g-ignore (gensym))
        (g-uri-space (gensym))
   (let ((f (gensym))
        (g-ignore (gensym))
        (g-uri-space (gensym))

-       (body #+allegro (third (excl::parse-body forms env))
-             #-allegro forms))
+       (body (third (parse-body forms env))))

     `(let ((,g-uri-space (or ,uri-space *uris*)))
        (prog nil
         (flet ((,f (,var &optional ,g-ignore)
     `(let ((,g-uri-space (or ,uri-space *uris*)))
        (prog nil
         (flet ((,f (,var &optional ,g-ignore)


@@ -1284,6 +1320,7 @@ Executes the forms once for each uri with var bound to the current uri"
          stream
          "#u takes a string or list argument: ~s" arg)))))
 
          stream
          "#u takes a string or list argument: ~s" arg)))))
 

+

 #+allegro
 excl::
 #+allegro
 #+allegro
 excl::
 #+allegro


@@ -1301,7 +1338,17 @@ excl::
 ;; timings
 ;; (don't run under emacs with M-x fi:common-lisp)
 
 ;; timings
 ;; (don't run under emacs with M-x fi:common-lisp)
 

-#+ignore
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (import 'excl::gc))
+
+#-allegro
+(defun gc (&rest options)
+  (declare (ignore options))
+  #+sbcl (sb-ext::gc)
+  #+cmu (ext::gc)
+  )
+

 (defun time-uri-module ()
   (declare (optimize (speed 3) (safety 0) (debug 0)))
   (let ((uri "http://www.franz.com/a/b;x;y;z/c/foo?bar=baz&xxx#foo")
 (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")