;; $Id$
(defpackage #:puri
- (:use #:cl)
+ (:use #:cl #:idna)
#-allegro (:nicknames #:net.uri)
(:export
#:uri ; the type and a function
#:merge-uris
#:enough-uri
#:uri-parsed-path
+ #:uri-parsed-host
#:render-uri
#:make-uri-space ; interning...
:initarg :parsed-path
:initform nil
:accessor .uri-parsed-path)
+ (parsed-host
+ :initarg :parsed-host
+ :initform nil
+ :accessor .uri-parsed-host)
(hashcode
;; cached sxhash, so we don't have to compute it more than once.
:initarg :hashcode :initform nil :accessor uri-hashcode)))
+(defmethod initialize-instance :after ((uri puri:uri) &key &allow-other-keys)
+ (let ((parsed-path (puri:uri-parsed-path uri))
+ (parsed-host (puri:uri-parsed-host uri)))
+ (when parsed-path
+ (setf (puri:uri-parsed-path uri)
+ parsed-path))
+ (when parsed-host
+ (setf (puri:uri-parsed-host uri)
+ parsed-host))))
+
(defclass urn (uri)
((nid :initarg :nid :initform nil :accessor urn-nid)
(nss :initarg :nss :initform nil :accessor urn-nss)))
(prog1 (call-next-method)
(setf (uri-string self) nil)
,@(when (eq name 'uri-path) `((setf (.uri-parsed-path self) nil)))
+ ,@(when (eq name 'uri-host) `((setf (.uri-parsed-host self) nil)))
(setf (uri-hashcode self) nil))))
)
(clear-caching-on-slot-change uri-scheme)
-(clear-caching-on-slot-change uri-host)
(clear-caching-on-slot-change uri-port)
(clear-caching-on-slot-change uri-path)
(clear-caching-on-slot-change uri-query)
`(make-instance ',(class-name (class-of self))
:scheme ,(uri-scheme self)
:host ,(uri-host self)
+ :parsed-host ',(.uri-parsed-host self)
:port ,(uri-port self)
:path ',(uri-path self)
:query ,(uri-query self)
&key place
(scheme (when uri (uri-scheme uri)))
(host (when uri (uri-host uri)))
+ (parsed-host
+ (when uri (copy-seq (.uri-parsed-host uri))))
(port (when uri (uri-port uri)))
(path (when uri (uri-path uri)))
(parsed-path
(if* place
then (setf (uri-scheme place) scheme)
(setf (uri-host place) host)
+ (setf (.uri-parsed-host place) parsed-host)
(setf (uri-port place) port)
(setf (uri-path place) path)
(setf (.uri-parsed-path place) parsed-path)
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
+ :parsed-path parsed-path :parsed-host parsed-host
: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
+ :parsed-path parsed-path :parsed-host parsed-host
:query query :fragment fragment :plist plist
:escaped escaped :string nil :hashcode nil)))
(setf (.uri-parsed-path uri) path-list)
path-list)
+(defmethod uri-parsed-host ((uri uri))
+ (when (uri-host uri)
+ (when (null (.uri-parsed-host uri))
+ (setf (.uri-parsed-host uri)
+ (to-unicode (uri-host uri))))
+ (.uri-parsed-host uri)))
+
+(defmethod (setf uri-parsed-host) (host (uri uri))
+ (setf (uri-host uri) (to-ascii host))
+ (setf (.uri-parsed-host uri) (to-unicode host)))
+
(defun uri-authority (uri)
(when (uri-host uri)
(let ((*print-pretty* nil))
;; Parsing
(defparameter *excluded-characters*
- '(;; `delims' (except #\%, because it's handled specially):
+ (append
+ ;; exclude control characters
+ (loop for i from 0 to #x1f
+ collect (code-char i))
+ '(;; `delims' (except #\%, because it's handled specially):
#\< #\> #\" #\space #\#
+ #\Rubout ;; (code-char #x7f)
;; `unwise':
#\{ #\} #\| #\\ #\^ #\[ #\] #\`))
+ "Excluded charcters from RFC2369 (http://www.ietf.org/rfc/rfc2396.txt 2.4.3)")
(defun reserved-char-vector (chars &key except)
- (do* ((a (make-array 127 :element-type 'bit :initial-element 0))
+ (do* ((a (make-array 128 :element-type 'bit :initial-element 0))
(chars chars (cdr chars))
(c (car chars) (car chars)))
((null chars) a)
(defparameter *reserved-path-characters*
(reserved-char-vector
(append *excluded-characters*
- '(#\;
+ '(#\; #\%
;;;;The rfc says this should be here, but it doesn't make sense.
;; #\=
#\/ #\?))))
(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 (to-ascii path))))
- (when host (setq host (decode-escaped-encoding host escape)))
+ (when host (setq host (to-ascii (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))
(with-output-to-string (out)
(loop for ch across decoded-string
with i = curpos
- do (let ((octet (char-code ch)))
+ do (let ((code (char-code ch)))
(cond
((or (null reserved-chars)
- (> octet 127)
- (= (sbit reserved-chars octet) 0))
+ (> code 127)
+ (= (sbit reserved-chars code) 0))
(write-char ch out)
(incf i
- (* (if (> octet 127) 2 1)
+ (* (cond
+ ((< code #x80) 1)
+ ((< code #x800) 2)
+ ((< code #x10000) 3)
+ ((< code #x200000) 4)
+ ((< code #x4000000) 5)
+ (t 6))
3)))
(t (write-string (subseq string i (+ i 3)) out)
- (incf i 3)
- )))))
+ (incf i 3))))))
decoded-string)
strs))))
(setf curpos pos))))