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 
Switched over to new, splay-tree based hierarchical namespaces.  This
is still a work in progress.
This commit is contained in:
Pierre R. Mai
2000-07-22 00:15:46 +00:00
parent 00b1689a8d
commit f30daaf80f
1 changed files with 208 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

214
src/main/namespace.cl
View File

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