- elephant-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 16 Feb '07

16 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv26996/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Latest changes to launching deadlock processes, all lisps supported (but not tested) except lispworks --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 17:41:29 1.24 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/16 03:43:47 1.25 @@ -232,29 +232,29 @@ (cdr result))) (defmethod start-deadlock-detector ((ctrl bdb-store-controller) &key (type :oldest) (time 0.1) log) - (multiple-value-bind (str errstr pid) - (launch-background-program - (second (controller-spec ctrl)) - (namestring - (make-pathname :defaults (get-user-configuration-parameter :berkeley-db-deadlock))) - :args `("-a" ,(lookup-deadlock-type type) - "-t" ,(format nil "~D" time) - ,@(when log (list "-L" (format nil "~A" log))))) + (let ((process-handle + (launch-background-program + (second (controller-spec ctrl)) + (namestring + (make-pathname :defaults (get-user-configuration-parameter :berkeley-db-deadlock))) + :args `("-a" ,(lookup-deadlock-type type) + "-t" ,(format nil "~D" time) + ,@(when log (list "-L" (format nil "~A" log))))))) (declare (ignore str errstr)) - (setf (controller-deadlock-pid ctrl) pid))) + (setf (controller-deadlock-pid ctrl) process-handle))) (defmethod stop-deadlock-detector ((ctrl bdb-store-controller)) (when (controller-deadlock-pid ctrl) (kill-background-program (controller-deadlock-pid ctrl)))) ;; -;; Take advantage of release 4.4's compact storage feature. Hidden features of BDB only +;; Take advantage of release 4.4's compact storage feature. Feature of BDB only ;; (defmethod optimize-storage ((ctrl bdb-store-controller) &key start-key stop-key (freelist-only nil) (free-space t) &allow-other-keys) - "Tell the backend to optimize storage between key values" + "Tell the backend to optimize and reclaim storage between key values" (with-buffer-streams (start stop end) (if (null start) (progn

1 0

[elephant-cvs] CVS elephant/src/utils
by ieslick 16 Feb '07

16 Feb '07

Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv26996/src/utils Modified Files: os.lisp Log Message: Latest changes to launching deadlock processes, all lisps supported (but not tested) except lispworks --- /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/14 04:38:56 1.1 +++ /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/16 03:43:48 1.2 @@ -1,26 +1,54 @@ (in-package :elephant-utils) +(defmacro in-directory ((dir) &body body) + `(progn + (#+sbcl sb-posix:chdir + #+cmu unix:unix-chdir + #+allegro excl:chdir + #+lispworks hcl:change-directory + #+openmcl ccl:cwd + ,dir) + ,@body)) + (defun launch-background-program (directory program &key (args nil)) "Launch a program in a specified directory - not all shell interfaces or OS's support this" #+(and allegro (not mswindows)) - (excl:run-shell-command (concat-separated-strings " " (list program) args) - :wait nil - :directory directory) -;; #+(and allegro mswindows) -;; #+(and sbcl unix) -;; (sb-ext:start-process ... -;; #+(and openmcl unix) -;; #+lispworks + (multiple-value-bind (in out pid) + (excl:run-shell-command (concat-separated-strings " " (list program) args) + :wait nil + :directory directory) + (declare (ignore in out)) + pid) + #+(and sbcl unix) + (in-directory (directory) + (sb-ext:run-program program args :wait nil)) + #+cmu + (in-directory (directory) + (ext:run-program program args :wait nil)) + #+openmcl + (in-directory (directory) + (ccl:run-program program args :wait nil)) + #+lispworks + (apply #'sys::call-system + (format nil "~a~{ '~a'~}~@[ &~]" prog args) + :current-directory directory + :wait nil) ) -(defun kill-background-program (pid) +(defun kill-background-program (process-handle) #+(and allegro (not mswindows)) - (progn (excl.osi:kill pid 9) - (system:reap-os-subprocess :pid pid)) -;; #+(and allegro mswindows) + (progn (excl.osi:kill process-handle 9) + (system:reap-os-subprocess :pid process-handle)) #+(and sbcl unix) - (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid))) + (sb-ext:process-kill process-handle 9) + #+openmcl + (ccl:signal-external-process process-handle 9) +;; #+lispworks +;; (apply #'sys::call-system +;; (format nil "kill ~A -9" process-handle) +;; :current-directory directory +;; :wait t) )

1 0

[elephant-cvs] CVS elephant
by ieslick 16 Feb '07

16 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv26996 Modified Files: TODO elephant.asd Log Message: Latest changes to launching deadlock processes, all lisps supported (but not tested) except lispworks --- /project/elephant/cvsroot/elephant/TODO 2007/02/14 04:36:08 1.48 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/16 03:43:47 1.49 @@ -227,6 +227,8 @@ (ala AllegroCache) - Support for cheap persistent sets (medium? can do on SQL?) - Native persistent hashes (easy for BDB; can do on SQL backends?) + - Persistent aggregates for better conceptual integration with lisp? + - pcons, parray, pstruct, etc - Support a simple object query language over the database - Repository browser - a simple REPL tool like the Slime inspector to see what classes are in a repository and what state they're in...useful --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/14 04:36:08 1.29 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/16 03:43:47 1.30 @@ -161,7 +161,8 @@ ((:file "package") (:file "convenience") (:file "locks") - (:file "os"))) + (:file "os")) + :serial t) (:module memutil :components ((:elephant-c-source "libmemutil")

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by rread 14 Feb '07

14 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv3373 Modified Files: sql-controller.lisp Log Message: Changes to make sqlite3 work --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/08 22:33:35 1.18 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/14 22:39:10 1.19 @@ -41,6 +41,13 @@ creation, counters, locks, the root (for garbage collection,) et cetera. This is the Postgresql-specific subclass of store-controller.")) +(defmethod supports-sequence ((sc sql-store-controller)) + (not (equal + (car (cadr (controller-spec sc))) + :sqlite3) + ) +) + ;; This should be much more elegant --- but as of Feb. 6, SBCL 1.0.2 has a weird, ;; unpleasant bug when ASDF tries to load this stuff. ;; (defvar *thread-table-lock* nil) @@ -52,13 +59,13 @@ (if (null *thread-table-lock*) ;; nil ;; (setq *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock")) - (setq *thread-table-lock* (elephant::ele-make-lock)) + (setq *thread-table-lock* (elephant-utils::ele-make-lock)) ) ) (defun thread-hash () - (elephant::ele-thread-hash-key) + (elephant-utils::ele-thread-hash-key) ) @@ -284,14 +291,26 @@ (clsql:table-exists-p [version] :database con :owner :all) ) -(defun create-version-table (con) - ;; ALL OF THIS needs to be inside a transaction. - (clsql::create-table [version] +(defun create-version-table (sc) + (let ((con (controller-db sc))) + (clsql::create-table [version] '( ([dbversion] text :not-null) ) :database con ) - ) + (if (and (clsql:table-exists-p [keyvlaue] :database con :owner :all) + (= 0 (caar (clsql:query "select count(*) from keyvalue")))) + (clsql::insert-records :into [version] + :attributes '(dbversion) + :values (list (format nil "~A" *elephant-code-version*)) + :database con) + (clsql::insert-records :into [version] + :attributes '(dbversion) + :values (list (format nil "~A" '(0 6 0))) + :database con) + ) + ) + ) ;; These functions are probably not cross-database portable... (defun keyvalue-table-exists (con) @@ -320,7 +339,7 @@ ;; storing blobs now in the Berkeley-db and we meed to make sure ;; we are properly testing that. However, blobs are awkward to ;; handle, so I am going to do this first... -(defun create-keyvalue-table (con) +(defun create-keyvalue-table (sc) ;; the "serial" specifiation here does not seem to work, ( ;; apparently not supported by clsql, so I have to execute these ;; commands specifically. This may be a database-dependent way of doing @@ -334,25 +353,29 @@ ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem! ;; ALL OF THIS needs to be inside a transaction. - + (let* ((con (controller-db sc))) ;; At one time this was conditional, but all NEW repositories should have this. - (clsql::create-sequence [serial] :database con) - (clsql::query - (format nil "create table keyvalue ( + (if (supports-sequence sc) + (progn + (clsql::create-sequence [serial] :database con) + (clsql::query + (format nil "create table keyvalue ( pk integer PRIMARY KEY DEFAULT nextval('serial'), clctn_id integer NOT NULL, key varchar NOT NULL, value varchar )") - :database con) -;; (clsql::create-table [keyvalue] -;; ;; This is most likely to work with any database system.. -;; '( -;; ([clctn_id] integer :not-null) -;; ([key] text :not-null) -;; ([value] text) -;; ) -;; :database con) + :database con) + ) + (clsql::create-table [keyvalue] + ;; This is most likely to work with any database system.. + '( + ([clctn_id] integer :not-null) + ([key] text :not-null) + ([value] text) + ) + :database con) + ) ;; :constraints '("PRIMARY KEY (clctn_id key)" ;; "UNIQUE (clctn_id,key)") @@ -380,7 +403,7 @@ :attributes '([clctn_id] [key]) :database con) ;;) - ) + )) (defmethod database-version ((sc sql-store-controller)) "A version determination for a given store @@ -397,13 +420,6 @@ (read-from-string (caar tuples)) nil)))) -(defun set-database-version (sc) - (let ((con (controller-db sc))) - (clsql::insert-records :into [version] - :attributes '(dbversion) - :values (list (format nil "~A" *elephant-code-version*)) - :database con))) - (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning @@ -427,13 +443,11 @@ ;; it does not, we need to create it.. (unless (keyvalue-table-exists con) (with-transaction (:store-controller sc) - (create-keyvalue-table con))) + (create-keyvalue-table sc))) (setf (uses-pk-of sc) (query-uses-pk con)) (unless (version-table-exists con) (with-transaction (:store-controller sc) - (create-version-table con))) - ;; Set elephant version if new - (when new-p (set-database-version sc)) + (create-version-table sc))) (initialize-serializer sc) ;; These should get oid 0 and 1 respectively (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0))

1 0

[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp
by ieslick 14 Feb '07

14 Feb '07

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv23445/src/contrib/eslick/db-lisp Added Files: tests.lisp Log Message: Missing files for in-development backends --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/tests.lisp 2007/02/14 17:42:23 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/tests.lisp 2007/02/14 17:42:23 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; test.lisp -- Internal tests for elephant lisp backend ;;; ;;; part of ;;; ;;; Elephant Object Oriented Database: Common Lisp Backend ;;; ;;; Copyright (c) 2007 by Ian Eslick ;;; <ieslick at common-lisp.net> ;;; ;;; Elephant Lisp Backend 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. (in-package :db-lisp) (defparameter *btree-file* "btree-test-file.db") (defvar btree nil) (defvar root nil) (defvar idx1 nil) (defvar idx2 nil) (defvar leaf1 nil) (defvar leaf2 nil) (defun initialize-btree-tests () (setf btree (open-lisp-btree *btree-file* :if-exists :overwrite)) (setf root (btree-root btree)) btree) (defun cleanup-btree-tests () (close-lisp-btree btree) (setf root nil idx1 nil idx2 nil leaf1 nil leaf2 nil)) (defun dump-keys (page) (with-buffer-streams (k) (scan-page-keys (k pointer position btree page) (format t "k: ~A ptr: ~A pos: ~A~%" (elephant-serializer2::deserialize k nil) pointer position)))) (defmacro with-key ((bs num) &body body) `(with-buffer-stream (,bs) (elephant-serializer2::serialize ,num ,bs) ,@body))

1 0

[elephant-cvs] CVS elephant/src/contrib/eslick/db-acache
by ieslick 14 Feb '07

14 Feb '07

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache In directory clnet:/tmp/cvs-serv23445/src/contrib/eslick/db-acache Added Files: ele-acache.asd Log Message: Missing files for in-development backends --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/ele-acache.asd 2007/02/14 17:42:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/ele-acache.asd 2007/02/14 17:42:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-acache.asd -- ASDF file for allegrocache backend ;;; ;;; Initial version 2/18/2006 by Ian Eslick ;;; <ieslick(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net> ;;; ;;; 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. (defsystem ele-acache :name "elephant" :author "Ben Lee <blee(a)common-lisp.net>" :version "0.6.0" :maintainer "Ben Lee <blee(a)common-lisp.net>" :licence "LLGPL" :description "Allegro cache backend for elephant" :components ((:module :src :components ((:module :db-acache :components ((:file "package") (:file "acache-controller") (:file "acache-transactions") (:file "acache-collections")) :serial t)))) :depends-on (:elephant))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 14 Feb '07

14 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv23282/src/db-bdb Modified Files: bdb-controller.lisp Log Message: User parameter if; deadlock detector param support --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 04:36:10 1.23 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 17:41:29 1.24 @@ -236,8 +236,7 @@ (launch-background-program (second (controller-spec ctrl)) (namestring - (make-pathname :directory '(:ABSOLUTE "opt" "local" "bin" "db45_deadlock") - :name "db_deadlock")) + (make-pathname :defaults (get-user-configuration-parameter :berkeley-db-deadlock))) :args `("-a" ,(lookup-deadlock-type type) "-t" ,(format nil "~D" time) ,@(when log (list "-L" (format nil "~A" log)))))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 14 Feb '07

14 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv23282/src/elephant Modified Files: controller.lisp package.lisp Log Message: User parameter if; deadlock detector param support --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/14 04:36:10 1.32 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/14 17:41:29 1.33 @@ -99,6 +99,15 @@ dep-list)) ;; +;; PER-USER INSTALLATION PARAMETERS +;; + +(defun get-user-configuration-parameter (name) + (elephant-system::get-config-option + name + (asdf:find-system :elephant))) + +;; ;; COMMON STORE CONTROLLER FUNCTIONALITY ;; @@ -128,6 +137,35 @@ (for garbage collection,) et cetera.")) ;; +;; Per-controller instance caching +;; + +(defun cache-instance (sc obj) + "Cache a persistent object with the controller." + (declare (type store-controller sc)) + (ele-with-lock ((instance-cache-lock sc)) + (setf (get-cache (oid obj) (instance-cache sc)) obj))) + +(defun get-cached-instance (sc oid class-name) + "Get a cached instance, or instantiate!" + (declare (type store-controller sc) + (type fixnum oid)) + (let ((obj (get-cache oid (instance-cache sc)))) + (if obj obj + ;; Should get cached since make-instance calls cache-instance + (make-instance (handle-legacy-classes class-name nil) + :from-oid oid :sc sc)))) + +(defmethod flush-instance-cache ((sc store-controller)) + "Reset the instance cache (flush object lookups). Useful + for testing. Does not reclaim existing objects so there + will be duplicate instances with identical functionality" + (ele-with-lock ((instance-cache-lock sc)) + (setf (instance-cache sc) + (make-cache-table :test 'eql)))) + + +;; ;; Database versioning ;; @@ -240,35 +278,6 @@ (defun string-pair->symbol (name) (intern (string-upcase (cdr name)) (car name))) -;; -;; Per-controller instance caching -;; - -(defun cache-instance (sc obj) - "Cache a persistent object with the controller." - (declare (type store-controller sc)) - (ele-with-lock ((instance-cache-lock sc)) - (setf (get-cache (oid obj) (instance-cache sc)) obj))) - -(defun get-cached-instance (sc oid class-name) - "Get a cached instance, or instantiate!" - (declare (type store-controller sc) - (type fixnum oid)) - (let ((obj (get-cache oid (instance-cache sc)))) - (if obj obj - ;; Should get cached since make-instance calls cache-instance - (make-instance (handle-legacy-classes class-name nil) - :from-oid oid :sc sc)))) - -(defmethod flush-instance-cache ((sc store-controller)) - "Reset the instance cache (flush object lookups). Useful - for testing. Does not reclaim existing objects so there - will be duplicate instances with identical functionality" - (ele-with-lock ((instance-cache-lock sc)) - (setf (instance-cache sc) - (make-cache-table :test 'eql)))) - - ;; ================================================================================ ;; ;; BACKEND STORE CONTROLLER PROTOCOL --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/08 23:07:19 1.12 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/14 17:41:29 1.13 @@ -36,6 +36,7 @@ #:controller-symbol-cache #:controller-symbol-id-cache #:controller-fast-symbols-p #:optimize-storage + #:get-user-configuration-parameter #:upgrade

1 0

[elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp
by ieslick 14 Feb '07

14 Feb '07

Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv2473 Removed Files: binary-data.lisp binary-types.lisp Log Message: Moving old files to archive

1 0

[elephant-cvs] CVS elephant/src/utils
by ieslick 14 Feb '07

14 Feb '07

Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv697 Added Files: convenience.lisp os.lisp Log Message: Missing files from last checkin --- /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/14 04:38:56 NONE +++ /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/14 04:38:56 1.1 ;; Copyright Ian Eslick ;; License: LGPL ;; ;; A collection of handy utilities for compacting code complexity in elephant ;; (in-package :elephant-utils) (defmacro do-subsets ((subset subset-size list) &body body) "Look over subsets of the list" `(loop for ,subset in (subsets ,subset-size ,list) do ,@body)) (defun subsets (size list) "Generate subsets of size n from the list; the last subset has the remaining elements if size does not represent an equal division" (let ((subsets nil)) (loop for elt in list for i from 0 do (when (= 0 (mod i size)) (setf (car subsets) (nreverse (car subsets))) (push nil subsets)) (push elt (car subsets))) (setf (car subsets) (nreverse (car subsets))) (nreverse subsets))) (defun remove-keywords (key-names args) (loop for ( name val ) on args by #'cddr unless (member name key-names) append (list name val))) (defun concat-separated-strings (separator &rest lists) (format nil (concatenate 'string "~{~A~^" (string separator) "~}") (append-sublists lists))) (defun append-sublists (list) "Takes a list of lists and appends all sublists" (let ((results (car list))) (dolist (elem (cdr list) results) (setq results (append results elem))))) --- /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/14 04:38:56 NONE +++ /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/14 04:38:56 1.1 (in-package :elephant-utils) (defun launch-background-program (directory program &key (args nil)) "Launch a program in a specified directory - not all shell interfaces or OS's support this" #+(and allegro (not mswindows)) (excl:run-shell-command (concat-separated-strings " " (list program) args) :wait nil :directory directory) ;; #+(and allegro mswindows) ;; #+(and sbcl unix) ;; (sb-ext:start-process ... ;; #+(and openmcl unix) ;; #+lispworks ) (defun kill-background-program (pid) #+(and allegro (not mswindows)) (progn (excl.osi:kill pid 9) (system:reap-os-subprocess :pid pid)) ;; #+(and allegro mswindows) #+(and sbcl unix) (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid))) )

1 0