From f30daaf80f510e4de289b9f6cd2cc350f2c99b3f Mon Sep 17 00:00:00 2001 From: "Pierre R. Mai" Date: Sat, 22 Jul 2000 00:15:46 +0000 Subject: [PATCH] Changes that bring CLASH up to extended HTTP/1.0 support: Switched over to new, splay-tree based hierarchical namespaces. This is still a work in progress. --- src/main/namespace.cl | 214 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 208 insertions(+), 6 deletions(-) diff --git a/src/main/namespace.cl b/src/main/namespace.cl index f8c7b58..bb28a53 100644 --- a/src/main/namespace.cl +++ b/src/main/namespace.cl @@ -17,27 +17,229 @@ () (:documentation "A namespace defines a mapping from URLs to resources.")) -(defgeneric namespace-add-url (namespace url resource) - (:documentation "Add a url resource mapping to the given namespace.")) +(defgeneric namespace-add-url (namespace url handler &optional stripped) + (:documentation + "Add a url resource mapping to the given namespace. Returns the +given resource.")) (defgeneric namespace-remove-url (namespace url) (:documentation "Remove a url resource mapping from the given namespace.")) -(defgeneric namespace-lookup-url (namespace url) +(defgeneric namespace-lookup-url (namespace url &optional stripped) (:documentation "Lookup the resource mapped to the url by the given namespace.")) +#| (defclass simple-namespace (namespace) ((mapping :initform (make-hash-table :test #'equal) :reader namespace-mapping))) -(defmethod namespace-add-url ((ns simple-namespace) url resource) +(defmethod namespace-add-url ((ns simple-namespace) url handler) (setf (gethash (url-significant-string url) (namespace-mapping ns)) - resource)) + handler)) (defmethod namespace-remove-url ((ns simple-namespace) url) (remhash (url-significant-string url) (namespace-mapping ns))) (defmethod namespace-lookup-url ((ns simple-namespace) url) - (gethash (url-significant-string url) (namespace-mapping ns) nil)) + (let ((handler (gethash (url-significant-string url) + (namespace-mapping ns) nil))) + (if (typep handler 'namespace) + (namespace-lookup-url handler url) + handler))) +|# + +;;; splay-tree based hierarchical namespace + +(defstruct splay-node + (segment "" :type (or simple-string null)) + (handler nil :type (or null splay-node namespace resource)) + (left nil :type (or null splay-node)) + (right nil :type (or null splay-node))) + +(declaim (inline segment<)) +(defun segment< (a b) + (declare (type (or null simple-string) a b)) + (cond + ((null b) + nil) + ((null a) + t) + (t + (string< a b)))) + +(declaim (inline segment>)) +(defun segment> (a b) + (declare (type (or null simple-string) a b)) + (cond + ((null a) + nil) + ((null b) + t) + (t + (string> a b)))) + +(defun splay-tree-splay (tree segment) + (when tree + (let ((middle (make-splay-node :left nil :right nil))) + (declare (dynamic-extent middle)) + (let ((left middle) + (right middle) + (tmp nil)) + (loop for cur-seg = (splay-node-segment tree) + while (string/= segment cur-seg) + do + (cond + ((segment< segment cur-seg) + (when (and (splay-node-left tree) + (segment< segment + (splay-node-segment + (splay-node-left tree)))) + (setf tmp (splay-node-left tree) + (splay-node-left tree) (splay-node-right tmp) + (splay-node-right tmp) tree + tree tmp)) + (unless (splay-node-left tree) + (return)) + (setf (splay-node-left right) tree + right tree + tree (splay-node-left tree))) + (t + (when (and (splay-node-right tree) + (segment> segment + (splay-node-segment + (splay-node-right tree)))) + (setf tmp (splay-node-right tree) + (splay-node-right tree) (splay-node-left tmp) + (splay-node-left tmp) tree + tree tmp)) + (unless (splay-node-right tree) + (return)) + (setf (splay-node-right left) tree + left tree + tree (splay-node-right tree))))) + (setf (splay-node-right left) (splay-node-left tree) + (splay-node-left right) (splay-node-right tree) + (splay-node-left tree) (splay-node-right middle) + (splay-node-right tree) (splay-node-left middle)) + tree)))) + +(defun splay-tree-insert (tree segment handler) + (let ((new (make-splay-node :segment segment :handler handler))) + (if (null tree) + new + (let ((tree (splay-tree-splay tree segment))) + (cond + ((segment< segment (splay-node-segment tree)) + (setf (splay-node-left new) (splay-node-left tree) + (splay-node-right new) tree + (splay-node-left tree) nil) + new) + ((segment> segment (splay-node-segment tree)) + (setf (splay-node-right new) (splay-node-right tree) + (splay-node-left new) tree + (splay-node-right tree) nil) + new) + (t + (setf (splay-node-handler tree) handler) + tree)))))) + +(defun splay-tree-delete (tree segment) + (when tree + (let ((tree (splay-tree-splay tree segment))) + (cond + ((string= segment (splay-node-segment tree)) + (if (null (splay-node-left tree)) + (splay-node-right tree) + (let ((result (splay-tree-splay (splay-node-left tree) segment))) + (setf (splay-node-right result) (splay-node-right tree)) + result))) + (t + tree))))) + +(defun splay-tree-lookup-path (tree path name url stripped) + (cond + ((null path) + (let ((new-tree (splay-tree-splay tree name))) + (if (and new-tree (string= name (splay-node-segment new-tree))) + (let ((handler (splay-node-handler new-tree))) + (typecase handler + ((or splay-node null) + (values new-tree nil)) + (t + (values new-tree handler)))) + (values new-tree nil)))) + (t + (let ((new-tree (splay-tree-splay tree (first path)))) + (cond + ((and new-tree (string= (first path) (splay-node-segment new-tree))) + (typecase (splay-node-handler new-tree) + (splay-node + (multiple-value-bind (new-handler resource) + (splay-tree-lookup-path (splay-node-handler new-tree) + (rest path) name + url (1+ stripped)) + (setf (splay-node-handler new-tree) new-handler) + (values new-tree resource))) + (namespace + (values new-tree + (namespace-lookup-url (splay-node-handler new-tree) url + (1+ stripped)))) + (t + (values new-tree nil)))) + (t + (values new-tree nil))))))) + +(defun splay-tree-add-path (tree path name url stripped handler) + (cond + ((null path) + (splay-tree-insert tree name handler)) + (t + (let ((new-tree (splay-tree-splay tree (first path)))) + (cond + ((and new-tree (string= (first path) (splay-node-segment new-tree))) + (typecase (splay-node-handler new-tree) + ((or splay-node null) + (let ((new-handler + (splay-tree-add-path (splay-node-handler new-tree) + (rest path) name url (1+ stripped) + handler))) + (setf (splay-node-handler new-tree) new-handler) + new-tree)) + (namespace + (namespace-add-url (splay-node-handler new-tree) url handler + (1+ stripped)) + new-tree) + (t + (setf (splay-node-handler new-tree) + (splay-tree-add-path nil (rest path) name url (1+ stripped) + handler)) + new-tree))) + (t + (splay-tree-insert new-tree (first path) + (splay-tree-add-path nil (rest path) name url + (1+ stripped) handler)))))))) + +(defclass hierarchical-namespace (namespace) + ((tree :initform nil))) + +(defmethod namespace-add-url ((ns hierarchical-namespace) url handler &optional (stripped 0)) + (with-slots (tree) ns + (setf tree + (splay-tree-add-path tree (nthcdr (1+ stripped) (url-directory url)) + (url-name url) url stripped handler))) + handler) + +#+NIL +(defmethod namespace-remove-url ((ns simple-namespace) url) + (remhash (url-significant-string url) (namespace-mapping ns))) + +(defmethod namespace-lookup-url ((ns hierarchical-namespace) url &optional (stripped 0)) + (with-slots (tree) ns + (multiple-value-bind (new-tree result) + (splay-tree-lookup-path tree + (nthcdr (1+ stripped) (url-directory url)) + (url-name url) url stripped) + (setf tree new-tree) + result)))