From 798edd89b0cd907407cbd4d24a2b976036fd53b2 Mon Sep 17 00:00:00 2001 From: "Pierre R. Mai" Date: Sat, 22 Jul 2000 01:01:56 +0000 Subject: [PATCH] Changes that bring CLASH up to extended HTTP/1.0 support: 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. --- src/main/url.cl | 165 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 137 insertions(+), 28 deletions(-) diff --git a/src/main/url.cl b/src/main/url.cl index e95df90..3d05546 100644 --- a/src/main/url.cl +++ b/src/main/url.cl @@ -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))))