OSCL/CLASH
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Changes that bring CLASH up to extended HTTP/1.0 support:

Browse Source 
Fixed various bugs in query-argument parsing (don't you just love
ambiguous standards?),  and added functionality to default url slots
from another url object, to copy url objects and to externalize them.
This commit is contained in:
Pierre R. Mai
2000-07-22 01:01:56 +00:00
parent f8834bce21
commit 798edd89b0
1 changed files with 137 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files

165
src/main/url.cl
View File

@ -19,6 +19,29 @@
;;;; useful, and is therefore preferred.
;;;;
;;; Utility macro
(defmacro with-defaulted-arguments
((instance args defaults type) &body clauses)
(loop with missing-sym = (gensym)
with instance-var = (gensym)
with args-var = (gensym)
with defaults-var = (gensym)
for (slot key) in clauses
collect
`(when (eql (getf ,args-var ',key ',missing-sym) ',missing-sym)
(when (slot-boundp ,defaults-var ',slot)
(setf (slot-value ,instance-var ',slot)
(slot-value ,defaults-var ',slot))))
into setters
finally
(return
`(let ((,instance-var ,instance)
(,args-var ,args)
(,defaults-var ,defaults))
(when (and ,defaults-var (typep ,defaults-var ',type))
,@setters)))))
;;; Conditions
(define-condition url-error (clash-error)
((url-string :initarg :url-string :reader url-error-url-string))
@ -93,6 +116,9 @@
(defconstant +url-query-pair-separator+ #\&
"Separator of query pairs.")
(defconstant +url-query-space-replacement+ #\+
"Replacement character for spaces in query values.")
(defconstant +url-authority-indicator+ "//"
"String that when present at the beginning of some scheme-specific parts
indicates the presence of authority information.")
@ -175,6 +201,13 @@ indicates the presence of authority information.")
:initform nil)
(scheme :initarg :scheme :reader url-scheme)))
(defmethod initialize-instance :after ((instance url) &rest args &key defaults)
(with-defaulted-arguments (instance args defaults url)
(scheme :scheme)))
(defmethod make-load-form ((object url) &optional env)
(make-load-form-saving-slots object :environment env))
(defgeneric url-string (url)
(:documentation
"Renders the given URL object into a new string and returns that."))
@ -184,6 +217,10 @@ indicates the presence of authority information.")
(defgeneric url-significant-string (url))
(defgeneric copy-url (url)
(:documentation
"Makes and returns a shallow copy of the given URL."))
(defgeneric merge-urls (url-a url-b)
(:documentation
"Merges two URLs into a new URL which is returned. Merging is done
@ -197,15 +234,19 @@ part of the same scheme."))
(url-specific-string url)))
(defmethod print-object ((obj url) stream)
(print-unreadable-object (obj stream :type t :identity nil)
(write-string (url-string obj) stream)))
(cond
((or *print-readably* *print-escape*)
(print-unreadable-object (obj stream :type t :identity nil)
(format stream "~S" (url-string obj))))
(t
(write-string (url-string obj) stream))))
;;; Schemes and Parsers
(defvar *scheme-parser-map* nil
"Mapping from schemes to parsers.")
(defun register-scheme (scheme parser-function)
(defun register-url-scheme (scheme parser-function)
"Registers a new URL scheme."
(let ((scheme (string-downcase scheme)))
(let ((present (assoc scheme *scheme-parser-map* :test #'string=)))
@ -214,7 +255,7 @@ part of the same scheme."))
(push (cons scheme parser-function) *scheme-parser-map*)))
scheme))
(defun unregister-scheme (scheme)
(defun unregister-url-scheme (scheme)
"Unregisters an URL scheme."
(let ((scheme (string-downcase scheme)))
(let ((present (assoc scheme *scheme-parser-map* :test #'string=)))
@ -224,11 +265,11 @@ part of the same scheme."))
(error "URL scheme ~A is not defined." scheme))
present)))
(defun lookup-scheme-parser (string)
(defun lookup-url-scheme-parser (string)
(cdr
(assoc string *scheme-parser-map* :test #'string-equal)))
(defun reset-schemes ()
(defun reset-url-schemes ()
"Clear the list of recognized schemes."
(setq *scheme-parser-map* nil))
@ -274,7 +315,7 @@ failure results from a syntactic error in the URI string passed."
(uri-alpha-char-p (schar string 0))
(char= +url-scheme-separator+ (schar string scheme-end)))
(let* ((scheme (nstring-downcase (subseq string 0 scheme-end)))
(parser (lookup-scheme-parser scheme)))
(parser (lookup-url-scheme-parser scheme)))
(unless parser
(error 'url-unknown-scheme-error
:scheme scheme :url-string string))
@ -284,7 +325,7 @@ failure results from a syntactic error in the URI string passed."
;; A relative URI, check if we are allowed to parse relative-URIs
(unless base-scheme
(error 'url-error :url-string string))
(let ((parser (lookup-scheme-parser base-scheme)))
(let ((parser (lookup-url-scheme-parser base-scheme)))
(unless parser
(error 'url-unknown-scheme-error
:scheme base-scheme :url-string string))
@ -372,12 +413,21 @@ failure results from a syntactic error in the URI string passed."
(unescaped-char source-pos))
(incf source-pos 2)))))))
(defun unescape-url-string (string)
(unescape-url-subseq string 0 (length string)))
;;; The following are some commonly used mix-ins for URLs.
(defclass url-host-port-mixin ()
((host :initarg :host :initform nil :reader url-host)
(port :initarg :port :initform nil :reader url-port)))
(defmethod initialize-instance :after
((instance url-host-port-mixin) &rest args &key defaults)
(with-defaulted-arguments (instance args defaults url-host-port-mixin)
(host :host)
(port :port)))
(defgeneric url-authority-p (url)
(:documentation
"Returns true if the given url supplies an authority component.")
@ -422,6 +472,14 @@ failure results from a syntactic error in the URI string passed."
(name :initarg :name :initform nil :reader url-name)
(name-param :initarg :name-param :initform nil :reader url-name-param)))
(defmethod initialize-instance :after
((instance url-path-mixin) &rest args &key defaults)
(with-defaulted-arguments (instance args defaults url-path-mixin)
(directory :directory)
(params :params)
(name :name)
(name-param :name-param)))
(defgeneric url-path-p (url)
(:documentation
"Returns true if the given url supplies a path component.")
@ -514,29 +572,70 @@ failure results from a syntactic error in the URI string passed."
((query-arguments :initarg :query-arguments :initform nil
:reader url-query-arguments)))
(defmethod initialize-instance :after
((instance url-query-mixin) &rest args &key defaults)
(with-defaulted-arguments (instance args defaults url-query-mixin)
(query-arguments :query-arguments)))
(defgeneric url-query-string (url))
(defun escape-query-string (string)
(substitute +url-query-space-replacement+ #\Space string))
(defun unescape-query-string (string)
(substitute #\Space +url-query-space-replacement+ string))
(defmethod url-query-string ((url url-query-mixin))
(format nil "~@[?~{~A=~A~^&~}~]"
(loop for (key . value) in (url-query-arguments url)
collect (escape-url-string key)
collect (escape-url-string value))))
(with-output-to-string (stream)
(let ((entries nil))
(flet ((put-key-value (key value)
(write-char (if (null entries)
+url-query-separator+
+url-query-pair-separator+)
stream)
(setq entries t)
(write-string
(escape-query-string (escape-url-string key " "))
stream)
(write-char +url-query-key-separator+ stream)
(write-string
(escape-query-string (escape-url-string value " "))
stream)))
(loop for (key . value) in (url-query-arguments url)
do
(if (consp value)
(dolist (val value)
(put-key-value key val))
(put-key-value key value)))))))
(defun parse-query-part (url start end)
(loop for key-start = start then (min end (1+ pair-end))
for pair-end = (or (position +url-query-pair-separator+ url
:start key-start :end end)
end)
for key-end = (position +url-query-key-separator+ url
:start key-start :end pair-end)
while (< key-start end)
do
(unless key-end
(error 'url-simple-syntax-error :url-string url
:reason "Malformed query key-value pair"))
collect
(cons (unescape-url-subseq url key-start key-end)
(unescape-url-subseq url (1+ key-end) pair-end))))
(merge-multiple-keys
(loop for key-start = start then (min end (1+ pair-end))
for pair-end = (or (position +url-query-pair-separator+ url
:start key-start :end end)
end)
for key-end = (position +url-query-key-separator+ url
:start key-start :end pair-end)
while (< key-start end)
do
(unless key-end
(error 'url-simple-syntax-error :url-string url
:reason "Malformed query key-value pair"))
collect
(cons (unescape-url-string
(unescape-query-string (subseq url key-start key-end)))
(unescape-url-string
(unescape-query-string (subseq url (1+ key-end) pair-end)))))
:test #'string=))
;;; Access functions
(defun url-query-argument (url argname &key multiple default)
(let ((entry (assoc argname (url-query-arguments url) :test #'string=)))
(if entry
(if multiple
(if (listp (cdr entry)) (cdr entry) (list (cdr entry)))
(if (listp (cdr entry)) (cadr entry) (cdr entry)))
default)))
;;; The specific URL schemes:
@ -594,7 +693,16 @@ failure results from a syntactic error in the URI string passed."
(merge-urls result base-url)
result))))
(register-scheme "http" #'url-http-parser)
(register-url-scheme "http" #'url-http-parser)
(defmethod copy-url ((url url-http))
(make-instance 'url-http :source-string (url-source-string url)
:scheme (url-scheme url)
:host (url-host url)
:port (url-port url)
:directory (url-directory url)
:name (url-name url)
:query-arguments (url-query-arguments url)))
(defmethod merge-urls ((a url-http) (b url-http))
(let* ((new-scheme (or (url-scheme a) (url-scheme b)))
@ -627,4 +735,5 @@ failure results from a syntactic error in the URI string passed."
:scheme new-scheme
:host new-host :port new-port
:directory new-directory
:name new-name)))
:name new-name
:query-arguments (url-query-arguments a))))