;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File - hashy-urlpath.lisp
;; Description - Hashy urlpaths
;; Author - Tim Bradshaw (tfb at lostwithiel)
;; Created On - Sun Feb 20 15:28:48 2000
;; Last Modified On - Mon Jun 25 12:56:06 2001
;; Last Modified By - Gail Anderson (ga at lostwithiel)
;; Update Count - 9
;; Status - Unknown
;;
;; $Id: hashy-urlpath.lisp,v 1.1 2003/01/23 22:19:15 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (C) 2000, 2001 Cley Limited
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;; USA.
;;;
;;; You can contact Cley Limited by emailing cley@cley.com.
(in-package :upt)
;;; This code demonstrates some alternative implementations of
;;; UPT-DIR-NODEs with different tradeoffs.
;;; Hashy dir nodes store their children in a hashtable. They will
;;; have very fast lookup performance, but will be larger than alist
;;; nodes. They would be suitable for large directories.
;;;
;;; (NOW FIXED) This code exposes a weakness in the UPT protocol: when
;;; making a child directory for a node there should be some exposed
;;; mechanism for specifying what the class of this child should be.
;;; The code in urlpath.lisp has the names of the child classes wired
;;; in. This code arranges to make the child class be the same class
;;; as the parent for directories, which is better as it allows
;;; subclassing. Ideally we would like to be able to specify what the
;;; child should be without rewriting STORE-URLPATH-LOOP each time.
;;; This would allow things like hashy directories all of whose
;;; children were alist directories, which would be useful.
;;;
(defclass hashy-upt-dir-node (upt-node)
((table :initform (make-hash-table :test #'equal))))
(let ((hashy (assoc ':hashy *upt-type-map*)))
(if hashy
(setf (cdr hashy) 'hashy-upt-dir-node)
(push '(:hashy . hashy-upt-dir-node)
*upt-type-map*)))
(defmethod upt-dir-node-p ((node hashy-upt-dir-node))
t)
(defmethod map-upt-node-children (fn (node hashy-upt-dir-node))
(maphash fn (slot-value node 'table))
node)
(defmethod find-upt-node-child ((node hashy-upt-dir-node) string)
(values (gethash string (slot-value node 'table) nil)))
(defmethod store-urlpath-loop ((node hashy-upt-dir-node) tail
name value)
(let ((table (slot-value node 'table)))
(if (null tail)
(let ((found (gethash name table)))
(if (null found)
(setf (gethash name table)
(make-instance (upt-file-class-for-node node)
:value value))
(if (upt-file-node-p found)
;; is it a bug that we know that file-nodes have a
;; VALUE slot?
(setf (slot-value found 'value) value)
(error "Trying to store a file on a directory"))))
;; more tail left.
(store-urlpath-loop (or (gethash (first tail) table)
(setf (gethash (first tail) table)
(make-instance (upt-dir-class-for-node
node))))
(rest tail) name value))))
;;; Another useful thing would be a directory node which can
;;; dynamically change its representation -- so small directories
;;; could be alist based but larger ones would become hashtable based,
;;; thus making the best use of the space/speed tradeoffs.
;;;
;;; Here is one way of having a directory node which is willing to
;;; change its representation from an alist to a hashy node. This is
;;; a fairly `extreme CLOS' solution as it makes use of objects whose
;;; class changes at runtime.
;;;
;;; A more conventional solution would be to use a proxy node which
;;; had a slot which was the real node, and have all methods on this
;;; forward to the real object. When the real object got full enough
;;; the proxy would create a new one.
;;;;
;;; Changing the class of an object may also be slow in many
;;; implementations and possibly result in many method caches being
;;; flushed with resultant performance problems.
;;;
;;; This stuff also exposes a slight weakness in the design -- you
;;; have to do a somewhat obscure thing to keep count of the children
;;; of a node. It would probably better to decompose the
;;; STORE-URLPATH-LOOP method into something that had an explicit
;;; child-adding GF where you could intercede.
;;;
(defmethod update-instance-for-different-class :after ((old upt-dir-node)
(new hashy-upt-dir-node)
&key)
;; how to change an alist node to a hashy node
(let ((table (slot-value new 'table)))
(dolist (map (slot-value old 'children-alist))
(setf (gethash (car map) table) (cdr map)))))
(defclass smart-upt-dir-node (upt-dir-node)
((fullness :initform 0)
(trigger :initform 32
:accessor upt-alist->hash-trigger
:allocation :class)))
(let ((smart (assoc ':smart *upt-type-map*)))
(if smart
(setf (cdr smart) 'smart-upt-dir-node)
(push '(:smart . smart-upt-dir-node)
*upt-type-map*)))
(defgeneric upt-hashy-class-for-node (o))
(defmethod upt-hashy-class-for-node ((o smart-upt-dir-node))
(find-class 'hashy-upt-dir-node))
(defmethod store-urlpath-loop :around ((node smart-upt-dir-node) tail
name value)
;; this is a bit devious, and relies on the fact that we always push
;; onto the front of the alist.
(with-slots (children-alist fullness) node
(let ((old-alist children-alist))
(call-next-method node tail name value)
(when (and (not (eq old-alist children-alist))
(>= (incf fullness) (upt-alist->hash-trigger node)))
(change-class node (upt-hashy-class-for-node node))))))