r11033: Automated commit for puri debian-version-1.5-1

[puri.git] / src.lisp

diff --git a/src.lisp b/src.lisp
index edb8afa5d8ef99b67eed37f8ac13283f9ca184ea..e6c1eda9e2b0d02686046eb064d8c40c161aa87f 100644 (file)
--- a/src.lisp
+++ b/src.lisp
@@ -1,31 +1,32 @@
 ;; -*- mode: common-lisp; package: puri -*-
 ;; -*- mode: common-lisp; package: puri -*-

-;; Support for URIs in Allegro.
+;; Support for URIs

 ;; For general URI information see RFC2396.
 ;;
 ;; For general URI information see RFC2396.
 ;;

-;; copyright (c) 1999-2001 Franz Inc, Berkeley, CA - All rights reserved.
-;; copyright (c) 2003 Kevin Rosenberg (porting changes)
+;; copyright (c) 1999-2002 Franz Inc, Berkeley, CA  - All rights reserved.
+;; copyright (c) 2002-2005 Franz Inc, Oakland, CA - All rights reserved.
+;; copyright (c) 2003-2006 Kevin Rosenberg (porting changes)

 ;;
 ;;

-;; The software, data and information contained herein are proprietary
-;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
-;; given in confidence by Franz, Inc. pursuant to a written license
-;; agreement, and may be stored and used only in accordance with the terms
-;; of such license.
+;; 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 Free Software Foundation, as clarified by the
+;; preamble found here:
+;;     http://opensource.franz.com/preamble.html

 ;;
 ;;

-;; Restricted Rights Legend
-;; ------------------------
-;; Use, duplication, and disclosure of the software, data and information
-;; contained herein by any agency, department or entity of the U.S.
-;; Government are subject to restrictions of Restricted Rights for
-;; Commercial Software developed at private expense as specified in
-;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
-;;
-;; Original version from ACL 6.1:
+;; Versions ported from Franz's opensource release

 ;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer
 ;; uri.cl,v 2.3.6.4.2.1 2001/08/09 17:42:39 layer

+;; uri.cl,v 2.9.84.1 2005/08/11 18:38:52 layer
+
+;; This code is distributed in the hope that it will be useful,
+;; but without any warranty; without even the implied warranty of
+;; merchantability or fitness for a particular purpose.  See the GNU
+;; Lesser General Public License for more details.

 ;;
 ;;

-;; $Id: src.lisp,v 1.8 2003/07/20 16:25:21 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,13 +56,14 @@
    #: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-toplevel)
-  (declaim (optimize (speed 3))))
+(in-package #:puri)

 
 

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

 
 
 #-allegro
 
 
 #-allegro


@@ -86,30 +88,30 @@
   #+allegro
   (excl::.primcall 'sys::shrink-svector str size)
   #+sbcl
   #+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 str 0 size))
-
-
-#-(or allegro lispworks)
-(define-condition parse-error (error)
-  ((fmt-control :initarg :fmt-control
-               :reader fmt-control)
-   (fmt-args :initarg :fmt-args
-                 :reader fmt-args))
+  #+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)
   (:report (lambda (c stream)

-            (format stream "Parse error: ")
-            (apply #'format stream (fmt-control c) (fmt-args c)))))
+            (format stream "Parse error:")
+            (apply #'format stream (fmt-control c) (fmt-arguments c)))))

 
 

-#-allegro

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

-  (error (make-condition 'parse-error :fmt-control fmt :fmt-args args)))
+  (error 'uri-parse-error :fmt-control fmt :fmt-arguments args))

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


@@ -119,23 +121,22 @@
 #+allegro (eval-when (:compile-toplevel :load-toplevel :execute)
            (import '(excl:*current-case-mode*
                      excl:delimited-string-to-list
 #+allegro (eval-when (:compile-toplevel :load-toplevel :execute)
            (import '(excl:*current-case-mode*
                      excl:delimited-string-to-list

-                     excl::.parse-error

                      excl::parse-body
                      excl::internal-reader-error
                      excl:if*)))
 
 #-allegro
                      excl::parse-body
                      excl::internal-reader-error
                      excl:if*)))
 
 #-allegro

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

   (declare (optimize (speed 3) (safety 0) (space 0))
   (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)


@@ -148,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)


@@ -382,19 +383,7 @@
 ;;;;The rfc says this should be here, but it doesn't make sense.
               ;; #\=
               #\/ #\?))))
 ;;;;The rfc says this should be here, but it doesn't make sense.
               ;; #\=
               #\/ #\?))))

-(defparameter *reserved-path-characters2*
-    ;; These are the same characters that are in
-    ;; *reserved-path-characters*, minus #\/.  Why?  Because the parsed
-    ;; representation of the path can contain the %2f converted into a /.
-    ;; That's the whole point of having the parsed representation, so that
-    ;; lisp programs can deal with the path element data in the most
-    ;; convenient form.
-    (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*)))
 
 (defparameter *reserved-fragment-characters*
     (reserved-char-vector (remove #\# *excluded-characters*)))
 


@@ -548,7 +537,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 #\:))


@@ -655,7 +644,13 @@ URI ~s contains illegal character ~s at position ~d."
             (:colon (failure))
             (:question (failure))
             (:hash (failure))
             (:colon (failure))
             (:question (failure))
             (:hash (failure))

-            (:slash (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))))
             (:string (setq host tokval)
                      (setq state 11))
             (:end (failure))))


@@ -725,7 +720,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


@@ -754,7 +749,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)


@@ -768,19 +763,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


@@ -794,26 +793,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)

+                      (> ci 127)       ; bug11527

                       (= 0 (sbit reserved-chars ci)))
                 then ;; ok as is
                       (= 0 (sbit reserved-chars ci)))
                 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


@@ -829,14 +829,14 @@ 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
              (symbol-name scheme))
             *reserved-characters* escape))
          (when scheme ":")
          (when scheme
            (encode-escaped-encoding
             (string-downcase ;; for upper case lisps
              (symbol-name scheme))
             *reserved-characters* escape))
          (when scheme ":")

-         (when host "//")
+         (when (or host (eq :file scheme)) "//")

          (when host
            (encode-escaped-encoding
             host *reserved-authority-characters* escape))
          (when host
            (encode-escaped-encoding
             host *reserved-authority-characters* escape))


@@ -865,7 +865,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)))


@@ -890,7 +890,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)))


@@ -910,18 +910,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)


@@ -946,12 +946,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


@@ -967,7 +965,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


@@ -982,6 +980,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:


@@ -1242,8 +1252,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))