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 ,@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 ,@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@robertlread.net" :version "0.1" :maintainer "Robert L. Read <read@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]