[elephant-cvs] CVS elephant/src/contrib/rread/dcm
rread
rread at common-lisp.net
Thu Apr 27 02:00:02 UTC 2006
Update of /project/elephant/cvsroot/elephant/src/contrib/rread/dcm
In directory clnet:/tmp/cvs-serv9657/rread/dcm
Added Files:
dcm-macros.lisp dcm-package.lisp dcm-tests.lisp dcm.asd
dcm.lisp gdcm.lisp
Log Message:
Adding "Data Collection Management".
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2006/04/27 02:00:02 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2006/04/27 02:00:02 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; dcm-macros
;;;
;;; Initial version by Robert L. Read
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
(in-package "DCM")
(defmacro init-director (cls dirclass &rest x)
`(let ((dir (make-instance ,cls , at x)))
(initialize dir ,cls ,dirclass)
(setf (gethash ,cls *director-class-map*) dir)
(load-all dir)
dir))
(defmacro init-director-noload (cls dirclass &rest x)
`(let ((dir (make-instance ,cls , at x)))
(initialize dir ,cls ,dirclass)
(setf (gethash ,cls *director-class-map*) dir)
;; (load-all dir)
dir))
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2006/04/27 02:00:02 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2006/04/27 02:00:02 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; dcm-package.lisp
;;;
;;; Initial version by Robert L. Read
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
(defpackage dcm
(:documentation
"DCM is a very simple in-memory object prevalence system.")
(:nicknames dcm :dcm)
;; (:use common-lisp elephant ele-clsql)
(:use common-lisp elephant)
(:export
;; These parameters are used to tell DCM how to connect
;; to repositories
#:*SLEEPYCAT-HOME*
#:*POSTGRES-SPEC*
#:*DCM-DEFAULT*
#:*ELEPHANT-CAT*
#:*DEF-STORE-NAME*
#:key
#:key-equal
#:dcm-equal
#:max-key-value
#:max-key
#:managed-object
#:mid
#:k
#:owner
#:ownr
#:tstamp
#:dcm-tstmp
#:mo-equal
#:get-values
#:randomize-slot-value
#:get-user-defined-slots
#:randomize-managed-object
#:ExObject
#:managed-handle
#:test-randomize-managed-object
#:max-key-value
#:*DIR-CAT*
#:director
#:load-all
#:delete-all-objects-from-director
#:*HASH-CAT*
#:hash-director
#:get-all-objects
#:get-all-objects-type
#:get-all-objects-owned-by
#:get-unused-key-value
#:hash-values-reduce
#:hash-keys-reduce
#:register-obj
#:lookup-obj
#:delete-obj
#:hash-dir-test
#:*ELEPHANT-CAT*
#:*basic-store-controller*
#:init-elephant-controllers
#:release-elephant-controllers
#:elephant-director
#:initialize-btree
#:initialize
#:register-many-random
#:elephant-dir-test
#:hash-ele-director
#:hash-ele-dir-test
#:*DIR-STRATEGIES*
#:directory-factory
#:init-director
#:dir-test
#:test-get-unused-key-value
#:unused-key
#:tm-register-then-lookup
#:tm-get-all-objects
#:tm-test-elephant
#:run-all-dcm-tests
#:test-ex-director
#:get-director-by-class
#:get-all-cur-objects
#:get-all-objects-gen
#:retire
#:find-generation
#:GenDir
)
)
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2006/04/27 02:00:02 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2006/04/27 02:00:02 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; dcm-tests.lisp
;;;
;;; Initial version by Robert L. Read
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
(in-package "DCM")
(defclass ExObjectDirector (hash-ele-director)
((mtype :initform 'ExObject
:accessor :mtype)))
(defun test-ex-director ()
(let ((k1 nil)
(k2 nil))
(let* ((o1 (make-instance 'ExObject))
(ed (init-director 'ExObjectDirector 'ExObjectDirector))
(o2 (make-instance 'ExObject)))
(setf (slot-value o1 'username) "spud")
(setf (slot-value o2 'username) "mud")
(setf k1 (k (mid (register-obj ed o1))))
(setf k2 (k (mid (register-obj ed o2))))
)
(let* (
(ed (init-director 'ExObjectDirector 'ExObjectDirector)))
(format t "K1 ~A~%" (slot-value (lookup-obj ed (make-instance 'key :id k1)) 'username))
(format t "K2 ~A~%" (slot-value (lookup-obj ed (make-instance 'key :id k2)) 'username))
(and (equal (slot-value (lookup-obj ed (make-instance 'key :id k1)) 'username)
"spud")
(equal (slot-value (lookup-obj ed (make-instance 'key :id k2)) 'username)
"mud")
))))
;; Create 10 objects, retire them, and make sure that they can
;; still be found.
(defclass TestGenDir (GenDir)
((mtype :initform 'ExObject))
)
(defun test-retirement ()
(let ((g (init-director 'TestGenDir 'TestGenDir))
(r (randomize-managed-object
(make-instance 'ExObject))))
(setf (slot-value r 'number) 0)
(setf (slot-value r 'username) "username")
(setf (slot-value r 'password) "password")
(register-obj g r)
(assert (= 0 (find-generation g (mid r))))
(retire g (mid r))
(assert (= 1 (find-generation g (mid r))))
)
)
(defun test-deletion-from-gen ()
(let ((g (init-director 'TestGenDir 'TestGenDir))
(r (randomize-managed-object
(make-instance 'ExObject))))
(setf (slot-value r 'number) 0)
(setf (slot-value r 'username) "username")
(setf (slot-value r 'password) "password")
(register-obj g r)
(retire g (mid r))
(let ((id (mid r)))
(assert (= 1 (find-generation g (mid r))))
(delete-all-objects-from-director g 'ExObject)
(lookup-obj-aux g id)
(let ((gp (init-director 'TestGenDir 'TestGenDir)))
(assert (null (get-all-objects gp)))
)
)
))
(defun test-naming-uniqueness ()
(let ((g (init-director 'TestGenDir 'TestGenDir))
(r (randomize-managed-object
(make-instance 'ExObject)))
(s 0))
(setf (slot-value r 'number) 0)
(setf (slot-value r 'username) "username")
(setf (slot-value r 'password) "password")
(register-obj g r)
(do ((i 0 (1+ i))
(dirs (subdirs g) (rest dirs)))
((null dirs))
(setf s (+ s (length (get-all-objects (car dirs))))))
(assert (= s 1))))
;; This command should test everything so far....
(defun run-all-dcm-tests ()
(let ((dt (make-instance 'dir-test)))
(unused-key dt)
(tm-register-then-lookup dt)
(tm-get-all-objects dt)
(tm-test-elephant dt)
))
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 02:00:02 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 02:00:02 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; dcm.asd -- ASDF system definition for DCM
;;;
;;; Initial version by Robert L. Read
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
(defsystem dcm
:name "dcm"
:author "Robert L. Read <read at robertlread.net>"
:version "0.1"
:maintainer "Robert L. Read <read at robertlread.net"
:licence "All Rights Reserverd"
:description "A simple object prevalence system with strategies"
:long-description "An object prevalence system with strategies built on Elephant"
:depends-on (:elephant)
:components
((:file "dcm-package")
(:file "dcm-macros")
(:file "dcm" :depends-on ("dcm-package" "dcm-macros"))
(:file "gdcm" :depends-on ("dcm" "dcm-macros"))
(:file "dcm-tests" :depends-on ("dcm" "gdcm" "dcm-macros"))
)
:serial t
)
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2006/04/27 02:00:02 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2006/04/27 02:00:02 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; dcm-tests.lisp
;;;
;;; Initial version by Robert L. Read
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net>
(in-package "DCM")
(defparameter *SLEEPYCAT-HOME* "/home/read/testdb")
(defparameter *POSTGRES-SPEC* '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" "")))
(defparameter *DCM-DEFAULT* *POSTGRES-SPEC*)
(defparameter *ELEPHANT-CAT* "elephant director")
(defparameter *DEF-STORE-NAME* "DefaultStoreX")
(asdf:operate 'asdf:load-op :elephant)
(use-package "ELEPHANT")
;; (asdf:operate 'asdf:load-op :ele-bdb)
(asdf:operate 'asdf:load-op :ele-clsql)
(defclass key ()
((id :type 'integer
:initform -1
:initarg :id
:accessor k)))
(defmethod max-key-value ((a key) (b key))
(max (k a)
(k b)))
(defmethod max-key ((a key) (b key))
(if (< (k a) (k b))
b
a))
;; I think perhas we could use a better type specifier for this
;; than integer.
(defclass managed-object ()
((mid :type 'key
:initform nil
:initarg :mid
:accessor mid)
(owner :type 'key
;; This is basically saying that the key 0 had better specify a legitimate
;; owner --- but that is the responsibility of the clients of this package.
:initform (make-instance 'key :id 0)
:initarg :owner
:accessor :ownr)
(tstamp :type 'number
;; This is basically saying that the key 0 had better specify a legitimate
;; owner --- but that is the responsibility of the clients of this package.
:initform (get-universal-time)
:initarg :tstamp
:accessor :dcm-tstmp)
)
)
(defmethod mo-equal ((a managed-object) (b managed-object))
(equal (get-values a) (get-values b)))
(defmethod key-equal ((a key) (b key))
(= (k a) (k b)))
(defmethod dcm-equal (a b)
(let ((ka
(if (typep a 'managed-object)
(k (mid a))
(if (typep a 'key)
(k a)
a)))
(kb
(if (typep b 'managed-object)
(k (mid b))
(if (typep b 'key)
(k b)
b))))
(and ka kb
(= ka kb))
)
)
(defmethod get-values ((a managed-object))
(mapcar #'(lambda (x)
(let* ((name (sb-pcl:slot-definition-name x))
(value (if (slot-boundp a name)
(slot-value a name)
nil)))
(cons name value)))
(sb-mop:class-slots (class-of a))))
;; This will make red tests for now...
(defun randomize-slot-value (s mo)
(let ((ltype (sb-pcl:slot-definition-type s))
(name (sb-pcl:slot-definition-name s)))
(let ((crazy (cadr ltype)))
(let ((v
(cond
[548 lines skipped]
--- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2006/04/27 02:00:02 NONE
+++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2006/04/27 02:00:02 1.1
[751 lines skipped]
More information about the Elephant-cvs
mailing list