From blee at common-lisp.net Thu Feb 24 01:04:17 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:04:17 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/src/libsleepycat.c Message-ID: <20050224010417.241AA884E2@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv4315/src Modified Files: libsleepycat.c Log Message: updates for wide char strings, etc Date: Thu Feb 24 02:04:14 2005 Author: blee Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.10 elephant/src/libsleepycat.c:1.11 --- elephant/src/libsleepycat.c:1.10 Fri Oct 8 02:53:04 2004 +++ elephant/src/libsleepycat.c Thu Feb 24 02:04:13 2005 @@ -56,6 +56,7 @@ */ #include +#include /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ @@ -227,9 +228,9 @@ double read_num(char *buf); int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2); +int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2); int utf16_cmp(const char *s1, int32_t length1, const char *s2, int32_t length2); -int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2); /* Inspired by the Sleepycat docs. We have to memcpy to insure memory alignment. */ @@ -279,6 +280,10 @@ case 13: /* 16-bit string */ case 14: /* 16-bit pathname */ return utf16_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); + case 20: + case 21: + case 22: + return wcs_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); default: return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); } @@ -387,6 +392,16 @@ return diff; } +int wcs_cmp(const wchar_t *a, int32_t length1, + const wchar_t *b, int32_t length2) { + int min, sizediff, diff; + sizediff = length1 - length2; + min = sizediff > 0 ? length2 : length1; + diff = wcsncmp(a, b, min /4); + if (diff == 0) return sizediff; + return diff; +} + int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { int min, sizediff, diff; sizediff = length1 - length2; @@ -724,6 +739,99 @@ int db_txnp_begin(DB_ENV *env, DB_TXN *parent, DB_TXN **txnp, u_int32_t flags) { return env->txn_begin(env, parent, txnp, flags); +} + +/* Sequences */ + +DB_SEQUENCE * db_sequence_create2(DB *db, u_int32_t flags, int *errno) { + DB_SEQUENCE * seq; + *errno = db_sequence_create(&seq, db, flags); + return seq; +} + +int db_sequence_open(DB_SEQUENCE *seq, DB_TXN *txnid, + char *key, u_int32_t key_size, u_int32_t flags) { + DBT DBTKey; + memset(&DBTKey, 0, sizeof(DBT)); + DBTKey.data = key; + DBTKey.size = key_size; + + return seq->open(seq, txnid, &DBTKey, flags); +} + +int db_sequence_close(DB_SEQUENCE *seq, u_int32_t flags) { + return seq->close(seq, flags); +} + +/* db_seq_t = int64_t */ +const unsigned int bitmask_32bits = 0xFFFFFFFF; +#define lower_u32bits(int64) ((unsigned int) int64 & bitmask_32bits) +#define upper_u32bits(int64) ((unsigned int) (int64 >> 32)) +#define UUto64(low, high) ((((u_int64_t)high) << 32) | (u_int64_t)low) +#define lower_32bits(int64) ((int) int64 & bitmask_32bits) +#define upper_32bits(int64) ((int) (int64 >> 32)) +#define USto64(low, high) ((((int64_t)high) << 32) | (u_int64_t)low) + +int db_sequence_get(DB_SEQUENCE *seq, DB_TXN *txnid, int32_t delta, + u_int32_t *lowp, int32_t *highp, u_int32_t flags) { + db_seq_t next; + int ret; + + ret = seq->get(seq, txnid, delta, &next, flags); + *lowp = lower_u32bits(next); + *highp = upper_32bits(next); + return ret; +} + +int db_sequence_get_lower(DB_SEQUENCE *seq, DB_TXN *txnid, int32_t delta, + int32_t *lowp, u_int32_t flags) { + db_seq_t next; + int ret; + + ret = seq->get(seq, txnid, delta, &next, flags); + *lowp = (int)lower_32bits(next); + return ret; +} + +/* Typo in the sleepycat docs! */ +int db_sequence_initial_value(DB_SEQUENCE *seq, u_int32_t low, + int32_t high) { + return seq->initial_value(seq, USto64(low, high)); +} + +int db_sequence_remove(DB_SEQUENCE *seq, DB_TXN *txnid, u_int32_t flags) { + return seq->remove(seq, txnid, flags); +} + +int db_sequence_set_cachesize(DB_SEQUENCE *seq, int32_t size) { + return seq->set_cachesize(seq, size); +} + +int db_sequence_get_cachesize(DB_SEQUENCE *seq, int32_t *sizep) { + return seq->get_cachesize(seq, sizep); +} + +int db_sequence_set_flags(DB_SEQUENCE *seq, u_int32_t flags) { + return seq->set_flags(seq, flags); +} + +int db_sequence_set_range(DB_SEQUENCE *seq, u_int32_t minlow, + int32_t minhigh, u_int32_t maxlow, + int32_t maxhigh) { + return seq->set_range(seq, USto64(minlow, minhigh), USto64(maxlow, maxhigh)); +} + +int db_sequence_get_range(DB_SEQUENCE *seq, u_int32_t *minlowp, + int32_t *minhighp, u_int32_t *maxlowp, + int32_t *maxhighp) { + int64_t min, max; + int errno; + errno = seq->get_range(seq, &min, &max); + *minlowp = lower_u32bits(min); + *minhighp = upper_32bits(min); + *maxlowp = lower_u32bits(max); + *maxhighp = upper_32bits(max); + return errno; } /* Locks and timeouts */ From blee at common-lisp.net Thu Feb 24 01:06:10 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:06:10 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/tests/testsleepycat.lisp elephant/tests/testserializer.lisp elephant/tests/testcollections.lisp Message-ID: <20050224010610.2E2988867D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv4345/tests Modified Files: testsleepycat.lisp testserializer.lisp testcollections.lisp Log Message: updates for sbcl unicode, sleepycat 4.3, new sequences and degree-2 Date: Thu Feb 24 02:06:06 2005 Author: blee Index: elephant/tests/testsleepycat.lisp diff -u elephant/tests/testsleepycat.lisp:1.2 elephant/tests/testsleepycat.lisp:1.3 --- elephant/tests/testsleepycat.lisp:1.2 Thu Sep 16 06:28:05 2004 +++ elephant/tests/testsleepycat.lisp Thu Feb 24 02:06:05 2005 @@ -1,40 +1,35 @@ (in-package "ELE-TESTS") -(use-package "SLEEPYCAT") +;;(unuse-package "ELE") +;;(use-package "SLEEPYCAT") (defvar env) (defvar db) -(defvar keys) -(defun make-keys (iters) - (loop for i from 1 to iters - collect (concatenate 'string "key-" (prin1-to-string i)))) - -(setq keys (make-keys 1000)) - -(defun prepare() - (setq env (db-env-create)) - (db-env-open env "test" :create t :init-txn t :init-lock t +(defun prepare-sleepycat() + (setq env (sleepycat::db-env-create)) + (sleepycat::db-env-open env *sleepycatdb-path* :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread t :recover-fatal t) - (setq db (db-create env)) - (db-open db :file "foo" :database "bar" :type DB-BTREE + (setq db (sleepycat::db-create env)) + (sleepycat::db-open db :file "testsleepycat" :database "bar" :type SLEEPYCAT::DB-BTREE :auto-commit t :create t :thread t)) -(deftest prepares - (finishes (prepare)) t) +(deftest prepares-sleepycat + (finishes (prepare-sleepycat)) t) +#| (deftest put-alot (finishes (loop for key in keys do - (db-put db key key :auto-commit t))) + (sleepycat::db-put db key key :auto-commit t))) t) (defun get-alot () (loop for key in keys - always (string= key (db-get db key)))) + always (string= key (sleepycat::db-get db key)))) (deftest put-right (get-alot) t) @@ -43,11 +38,65 @@ (with-transaction (:environment env) (loop for key in keys do - (db-put db key key)))) + (sleepycat::db-put db key key)))) t) (deftest put-right-b (get-alot) t) +|# + +(defun test-sequence1 () + (let ((seq (sleepycat::db-sequence-create db))) + (sleepycat::db-sequence-set-cachesize seq 1000) + (sleepycat::db-sequence-set-flags seq :seq-inc t :seq-wrap t) + (sleepycat::db-sequence-set-range seq 0 most-positive-fixnum) + (sleepycat::db-sequence-initial-value seq (- most-positive-fixnum 99)) + (sleepycat::db-sequence-open seq "testseq1" + :auto-commit t :create t :thread t) + (loop for i = (sleepycat::db-sequence-get-fixnum seq 1 :auto-commit t :txn-nosync t) + for j from (- most-positive-fixnum 99) to most-positive-fixnum + while (> i 0) + do + (assert (= i j)) + finally (sleepycat::db-sequence-remove seq :auto-commit t)))) + +(deftest test-seq1 + (finishes (test-sequence1)) + t) + +(defun test-sequence2 () + (let ((seq (sleepycat::db-sequence-create db))) + (sleepycat::db-sequence-set-cachesize seq 1000) + (sleepycat::db-sequence-set-flags seq :seq-dec t :seq-wrap t) + (sleepycat::db-sequence-set-range seq most-negative-fixnum 0) + (sleepycat::db-sequence-initial-value seq (+ most-negative-fixnum 99)) + (sleepycat::db-sequence-open seq "testseq2" + :auto-commit t :create t :thread t) + (loop for i = (sleepycat::db-sequence-get-fixnum seq 1 :auto-commit t :txn-nosync t) + for j from (+ most-negative-fixnum 99) downto most-negative-fixnum + while (< i 0) + do + (assert (= i j)) + finally (sleepycat::db-sequence-remove seq :auto-commit t)))) +(deftest test-seq2 + (finishes (test-sequence2)) + t) + +(defun cleanup-sleepycat () + (sleepycat::db-close db) + (sleepycat::db-env-dbremove env "testsleepycat" :database "bar") + (sleepycat::db-env-close env) + (setq env (sleepycat::db-env-create)) + (sleepycat::db-env-remove env "test")) + +(deftest cleansup-sleepycat + (finishes (cleanup-sleepycat)) + t) + +;;(unuse-package "SLEEPYCAT") +;;(use-package "ELE") + +#| (defun txn-alot (iters) (loop for i from 1 to iters do @@ -80,12 +129,5 @@ with str string = (make-string ln :initial-element #\c) do (db-put db "fs" str)))) - -(defun cleanup () - (db-close db) - - (db-env-dbremove env "foo" :database "bar") - (db-env-close env) - (setq env (db-env-create)) - (db-env-remove env "test")) +|# Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.5 elephant/tests/testserializer.lisp:1.6 --- elephant/tests/testserializer.lisp:1.5 Thu Sep 16 06:27:19 2004 +++ elephant/tests/testserializer.lisp Thu Feb 24 02:06:05 2005 @@ -96,6 +96,14 @@ (in-out-equal (/ (expt 2 200) (- (expt 3 300))))) t t t t t t t) +(deftest base-strings + (are-not-null + (in-out-equal (make-string 0 :element-type 'base-char)) + (in-out-equal (coerce "this is a test" 'base-string)) + (in-out-equal (make-string 400 :initial-element (code-char 127) + :element-type 'base-char))) + t t t) + (deftest strings (are-not-null (in-out-equal "") Index: elephant/tests/testcollections.lisp diff -u elephant/tests/testcollections.lisp:1.2 elephant/tests/testcollections.lisp:1.3 --- elephant/tests/testcollections.lisp:1.2 Sun Sep 19 19:52:51 2004 +++ elephant/tests/testcollections.lisp Thu Feb 24 02:06:05 2005 @@ -14,7 +14,7 @@ (slot2 :accessor slot2 :initarg :slot2))) (defvar keys (loop for i from 1 to 1000 - collect (concatenate 'string "key-" (prin1-to-string i)))) + collect (concatenate 'base-string "key-" (prin1-to-string i)))) (defvar objs (loop for i from 1 to 1000 collect (make-instance 'blob @@ -46,12 +46,14 @@ (= (slot2 obj) (* i 100)))) t) +(defvar first-key (first keys)) + (deftest remove-kv - (finishes (with-transaction () (remove-kv "key-1" bt))) + (finishes (with-transaction () (remove-kv first-key bt))) t) (deftest removed - (not (get-value "key-1" bt)) + (not (get-value first-key bt)) t) (deftest map-btree @@ -146,12 +148,12 @@ t) (deftest remove-kv-indexed - (finishes (remove-kv "key-1" indexed)) + (finishes (remove-kv first-key indexed)) t) (deftest no-key-nor-indices (values - (get-value "key-1" indexed) + (get-value first-key indexed) (get-primary-key 1 index1) (get-primary-key 100 index2)) nil nil nil) @@ -162,7 +164,7 @@ (deftest no-key-nor-indices-slot1 (values - (get-value "key-2" indexed) + (get-value (second keys) indexed) (get-primary-key 2 index1) (get-primary-key 200 index2)) nil nil nil) @@ -173,7 +175,7 @@ (deftest no-key-nor-indices-slot2 (values - (get-value "key-3" indexed) + (get-value (third keys) indexed) (get-primary-key 3 index1) (get-primary-key 300 index2)) nil nil nil) From blee at common-lisp.net Thu Feb 24 01:06:20 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:06:20 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/src/utils.lisp elephant/src/sleepycat.lisp elephant/src/serializer.lisp elephant/src/controller.lisp elephant/src/berkeley-db.lisp Message-ID: <20050224010620.4B01B8867E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv4345/src Modified Files: utils.lisp sleepycat.lisp serializer.lisp controller.lisp berkeley-db.lisp Log Message: updates for sbcl unicode, sleepycat 4.3, new sequences and degree-2 Date: Thu Feb 24 02:06:10 2005 Author: blee Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.7 elephant/src/utils.lisp:1.8 --- elephant/src/utils.lisp:1.7 Sun Sep 19 19:52:18 2004 +++ elephant/src/utils.lisp Thu Feb 24 02:06:08 2005 @@ -47,6 +47,9 @@ (type hash-table *circularity-hash*) (type boolean *auto-commit*)) +(defvar *cachesize* 100 + "Size of the OID sequence cache.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Thread-local specials @@ -106,7 +109,7 @@ (environment '(controller-environment *store-controller*)) (parent '*current-transaction*) - dirty-read txn-nosync + degree-2 dirty-read txn-nosync txn-nowait txn-sync (retries 100)) &body body) @@ -118,6 +121,7 @@ `(sleepycat:with-transaction (:transaction ,transaction :environment ,environment :parent ,parent + :degree-2 ,degree-2 :dirty-read ,dirty-read :txn-nosync ,txn-nosync :txn-nowait ,txn-nowait Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.12 elephant/src/sleepycat.lisp:1.13 --- elephant/src/sleepycat.lisp:1.12 Tue Sep 21 03:37:21 2004 +++ elephant/src/sleepycat.lisp Thu Feb 24 02:06:09 2005 @@ -71,7 +71,11 @@ #:buffer-write-uint #:buffer-write-float #:buffer-write-double #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum #:buffer-read-int #:buffer-read-uint #:buffer-read-float - #:buffer-read-double #:buffer-read-string #:byte-length + #:buffer-read-double + #-(and allegro ics) #:buffer-read-ucs1-string + #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string + #+(and sbcl sb-unicode) #:buffer-read-ucs4-string + #:byte-length #:pointer-int #:pointer-void #:array-or-pointer-char @@ -92,7 +96,14 @@ #:db-cursor-pget-both-buffered #:db-cursor-put-buffered #:db-transaction-begin #:db-transaction-abort #:db-transaction-commit #:with-transaction - #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free + #:db-transaction-id + #:db-sequence-create #:db-sequence-open #:db-sequence-close + #:db-sequence-get #:db-sequence-get-fixnum + #:db-sequence-initial-value #:db-sequence-remove + #:db-sequence-set-cachesize #:db-sequence-get-cachesize + #:db-sequence-set-flags #:db-sequence-set-range + #:db-sequence-get-range + #:db-env-lock-id #:db-env-lock-id-free #:db-env-lock-get #:db-env-lock-put #:with-lock #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-lock-detect #:db-env-get-lock-detect @@ -132,12 +143,12 @@ (uffi:load-foreign-library ;; Sleepycat: this works on linux #+linux - "/usr/local/BerkeleyDB.4.2/lib/libdb.so" + "/db/ben/lisp/db43/lib/libdb.so" ;; this works on FreeBSD #+(and (or bsd freebsd) (not darwin)) - "/usr/local/lib/db42/libdb.so" + "/usr/local/lib/db43/libdb.so" #+darwin - "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" + "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib" :module "sleepycat") (error "Couldn't load libdb (Sleepycat)!")) @@ -165,7 +176,7 @@ (declaim (inline read-int read-uint read-float read-double write-int write-uint write-float write-double - offset-char-pointer copy-str-to-buf copy-bufs + offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs ;;resize-buffer-stream ;;buffer-stream-buffer buffer-stream-size buffer-stream-position ;;buffer-stream-length @@ -174,7 +185,9 @@ buffer-write-float buffer-write-double buffer-write-string buffer-read-byte buffer-read-fixnum buffer-read-int buffer-read-uint buffer-read-float buffer-read-double - buffer-read-string)) + #-(and allegreo ics) buffer-read-ucs1-string + #+(or lispworks (and allegro ics)) buffer-read-ucs2-string + #+(and sbcl sb-unicode) buffer-read-ucs4-string)) ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -182,8 +195,8 @@ ;I don't like the UFFI syntax for enumerations (defconstant DB-BTREE 1) (defconstant DB-HASH 2) -(defconstant DB-QUEUE 3) -(defconstant DB-RECNO 4) +(defconstant DB-RECNO 3) +(defconstant DB-QUEUE 4) (defconstant DB-UNKNOWN 5) (defconstant DB_AUTO_COMMIT #x1000000) @@ -201,7 +214,8 @@ (defconstant DB_SYSTEM_MEM #x0400000) (defconstant DB_THREAD #x0000040) (defconstant DB_FORCE #x0000004) -(defconstant DB_DIRTY_READ #x2000000) +(defconstant DB_DEGREE_2 #x2000000) +(defconstant DB_DIRTY_READ #x4000000) (defconstant DB_CREATE #x0000001) (defconstant DB_EXCL #x0001000) (defconstant DB_NOMMAP #x0000008) @@ -210,7 +224,7 @@ (defconstant DB_TXN_NOSYNC #x0000100) (defconstant DB_TXN_NOWAIT #x0001000) (defconstant DB_TXN_SYNC #x0002000) -(defconstant DB_LOCK_NOWAIT #x001) +(defconstant DB_LOCK_NOWAIT #x002) (defconstant DB_DUP #x0000002) (defconstant DB_DUPSORT #x0000004) @@ -238,6 +252,11 @@ (defconstant DB_POSITION 24) +(defconstant DB_SEQ_DEC #x00000001) +(defconstant DB_SEQ_INC #x00000002) +(defconstant DB_SEQ_WRAP #x00000008) + + (defconstant DB_SET_LOCK_TIMEOUT 29) (defconstant DB_SET_TXN_TIMEOUT 33) @@ -245,16 +264,17 @@ (defconstant DB_KEYEXIST -30996) (defconstant DB_LOCK_DEADLOCK -30995) (defconstant DB_LOCK_NOTGRANTED -30994) -(defconstant DB_NOTFOUND -30990) +(defconstant DB_NOTFOUND -30989) (defconstant DB_LOCK_DEFAULT 1) (defconstant DB_LOCK_EXPIRE 2) (defconstant DB_LOCK_MAXLOCKS 3) -(defconstant DB_LOCK_MINLOCKS 4) -(defconstant DB_LOCK_MINWRITE 5) -(defconstant DB_LOCK_OLDEST 6) -(defconstant DB_LOCK_RANDOM 7) -(defconstant DB_LOCK_YOUNGEST 8) +(defconstant DB_LOCK_MAXWRITE 4) +(defconstant DB_LOCK_MINLOCKS 5) +(defconstant DB_LOCK_MINWRITE 6) +(defconstant DB_LOCK_OLDEST 7) +(defconstant DB_LOCK_RANDOM 8) +(defconstant DB_LOCK_YOUNGEST 9) (defvar +NULL-VOID+ (make-null-pointer :void) "A null pointer to a void type.") @@ -299,6 +319,22 @@ (defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) "Vector of buffer-streams, which you can grab / return.") +(defconstant +2^32+ 4294967296) +(defconstant +2^64+ 18446744073709551616) +(defconstant +2^32-1+ (1- +2^32+)) + +(defmacro make-64-bit-integer (high32 low32) + `(+ ,low32 (ash ,high32 32))) + +(defmacro high32 (int64) + `(ash ,int64 -32)) + +(defmacro low32 (int64) + `(logand ,int64 +2^32-1+)) + +(defmacro split-64-bit-integer (int64) + `(values (ash ,int64 -32) (logand ,int64 +2^32-1+))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; buffer-streams @@ -498,9 +534,13 @@ (defmacro byte-length (s) "Return the number of bytes of the internal representation of a string." - #+(or lispworks (and allegro ics)) + #+(and allegro ics) `(let ((l (length ,s))) (+ l l)) - #-(or lispworks (and allegro ics)) + #+(or (and sbcl sb-unicode) lispworks) + `(etypecase ,s + (base-string (length ,s)) + (string (* (length ,s) #+sbcl 4 #+lispworks 2))) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) `(length ,s)) ;; for copying the bytes of a string to a foreign buffer @@ -517,14 +557,27 @@ :returning :void) #+(or cmu sbcl scl) -(def-function ("copy_buf" copy-str-to-buf) +(def-function ("copy_buf" %copy-str-to-buf) ((dest array-or-pointer-char) (dest-offset :int) - (src :cstring) + (src array-or-pointer-char) (src-offset :int) (length :int)) :returning :void) +#+(or cmu sbcl scl) +(defun copy-str-to-buf (d do s so l) + (declare (optimize (speed 3) (safety 0)) + (type array-or-pointer-char d) + (type fixnum do so l) + (type string s)) + (%copy-str-to-buf d do + #+sbcl + (sb-sys:vector-sap s) + #+(or cmu scl) + (sys:vector-sap s) + so l)) + ;; but OpenMCL can't directly pass string bytes. #+openmcl (defun copy-str-to-buf (dest dest-offset src src-offset length) @@ -775,27 +828,62 @@ (setf (buffer-stream-position bs) (+ position 8)) (read-double (buffer-stream-buffer bs) position))) -(defun buffer-read-string (bs length) - "Read a string. On Unicode Lisps this is a 16-bit operation!" +(defun buffer-read-ucs1-string (bs byte-length) + "Read a UCS1 string." (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs) - (type fixnum length)) + (type fixnum byte-length)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position byte-length)) + #-(and sbcl sb-unicode) + (convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length byte-length :null-terminated-p nil) + #+(and sbcl sb-unicode) + (let ((res (make-string byte-length :element-type 'base-char))) + (sb-kernel:copy-from-system-area + (sb-alien:alien-sap (buffer-stream-buffer bs)) + (* position sb-vm:n-byte-bits) + res + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + (* byte-length sb-vm:n-byte-bits)) + res))) + +#+(or lispworks (and allegro ics)) +(defun buffer-read-ucs2-string (bs byte-length) + "Read a UCS2 string." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum byte-length)) (let ((position (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ position length)) + (setf (buffer-stream-position bs) (+ position byte-length)) ;; wide!!! #+(and allegro ics) (excl:native-to-string (offset-char-pointer (buffer-stream-buffer bs) position) - :length length + :length byte-length :external-format :unicode) #+lispworks (fli:convert-from-foreign-string (offset-char-pointer (buffer-stream-buffer bs) position) - :length length :external-format :unicode :null-terminated-p nil) - #-(or lispworks (and allegro ics)) - (convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) position) - :length length :null-terminated-p nil))) + :length byte-length :external-format :unicode :null-terminated-p nil))) + +#+(and sbcl sb-unicode) +(defun buffer-read-ucs4-string (bs byte-length) + "Read a UCS4 string." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum byte-length)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position byte-length)) + (let ((res (make-string (/ byte-length 4) :element-type 'character))) + (sb-kernel:copy-from-system-area + (sb-alien:alien-sap (buffer-stream-buffer bs)) + (* position sb-vm:n-byte-bits) + res + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + (* byte-length sb-vm:n-byte-bits)) + res))) ;; Wrapper macro -- handles errno return values ;; makes flags into keywords @@ -881,12 +969,14 @@ (defmacro flags (&key auto-commit joinenv init-cdb init-lock init-log init-mpool init-rep init-txn recover recover-fatal lockdown - private system-mem thread force dirty-read create excl nommap + private system-mem thread force degree-2 dirty-read create + excl nommap rdonly truncate txn-nosync txn-nowait txn-sync lock-nowait dup dup-sort current first get-both get-both-range last next next-dup next-nodup prev prev-nodup set set-range after before keyfirst keylast - no-dup-data no-overwrite nosync position set-lock-timeout + no-dup-data no-overwrite nosync position + seq-dec seq-inc seq-wrap set-lock-timeout set-transaction-timeout) (let ((flags (gensym))) `(let ((,flags 0)) @@ -906,6 +996,7 @@ ,@(when system-mem `((when ,system-mem (setq ,flags (logior ,flags DB_SYSTEM_MEM))))) ,@(when thread `((when ,thread (setq ,flags (logior ,flags DB_THREAD))))) ,@(when force `((when ,force (setq ,flags (logior ,flags DB_FORCE))))) + ,@(when degree-2 `((when ,degree-2 (setq ,flags (logior ,flags DB_DEGREE_2))))) ,@(when dirty-read `((when ,dirty-read (setq ,flags (logior ,flags DB_DIRTY_READ))))) ,@(when create `((when ,create (setq ,flags (logior ,flags DB_CREATE))))) ,@(when excl `((when ,excl (setq ,flags (logior ,flags DB_EXCL))))) @@ -938,6 +1029,9 @@ ,@(when no-overwrite `((when ,no-overwrite (setq ,flags (logior ,flags DB_NOOVERWRITE))))) ,@(when nosync `((when ,nosync (setq ,flags (logior ,flags DB_NOSYNC))))) ,@(when position `((when ,position (setq ,flags (logior ,flags DB_POSITION))))) + ,@(when seq-dec `((when ,seq-dec (setq ,flags (logior ,flags DB_SEQ_DEC))))) + ,@(when seq-inc `((when ,seq-inc (setq ,flags (logior ,flags DB_SEQ_INC))))) + ,@(when seq-wrap `((when ,seq-wrap (setq ,flags (logior ,flags DB_SEQ_WRAP))))) ,@(when set-lock-timeout `((when ,set-lock-timeout (setq ,flags (logior ,flags DB_SET_LOCK_TIMEOUT))))) ,@(when set-transaction-timeout `((when ,set-transaction-timeout (setq ,flags (logior ,flags DB_SET_TXN_TIMEOUT))))) ,flags))) Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.9 elephant/src/serializer.lisp:1.10 --- elephant/src/serializer.lisp:1.9 Thu Sep 16 06:20:41 2004 +++ elephant/src/serializer.lisp Thu Feb 24 02:06:10 2005 @@ -62,20 +62,19 @@ (defconstant +nil+ 8) ;; 8-bit -#-(or lispworks (and allegro ics)) -(defconstant +symbol+ 9) -#-(or lispworks (and allegro ics)) -(defconstant +string+ 10) -#-(or lispworks (and allegro ics)) -(defconstant +pathname+ 11) +(defconstant +ucs1-symbol+ 9) +(defconstant +ucs1-string+ 10) +(defconstant +ucs1-pathname+ 11) ;; 16-bit -#+(or lispworks (and allegro ics)) -(defconstant +symbol+ 12) -#+(or lispworks (and allegro ics)) -(defconstant +string+ 13) -#+(or lispworks (and allegro ics)) -(defconstant +pathname+ 14) +(defconstant +ucs2-symbol+ 12) +(defconstant +ucs2-string+ 13) +(defconstant +ucs2-pathname+ 14) + +;; 32-bit +(defconstant +ucs4-symbol+ 20) +(defconstant +ucs4-string+ 21) +(defconstant +ucs4-pathname+ 22) (defconstant +persistent+ 15) (defconstant +cons+ 16) @@ -105,7 +104,15 @@ (symbol (let ((s (symbol-name frob))) (declare (type string s) (dynamic-extent s)) - (buffer-write-byte +symbol+ bs) + (buffer-write-byte + #+(and allegro ics) +ucs2-symbol+ + #+(or (and sbcl sb-unicode) lispworks) + (etypecase s + (base-string +ucs1-symbol+) + (string #+sbcl +ucs4-symbol+ #+lispwoks +ucs2-symbol+)) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) + +ucs1-symbol+ + bs) (buffer-write-int (byte-length s) bs) (buffer-write-string s bs) (let ((package (symbol-package frob))) @@ -113,7 +120,15 @@ (%serialize (package-name package)) (%serialize nil))))) (string - (buffer-write-byte +string+ bs) + (buffer-write-byte + #+(and allegro ics) +ucs2-string+ + #+(or (and sbcl sb-unicode) lispworks) + (etypecase frob + (base-string +ucs1-string+) + (string #+sbcl +ucs4-string+ #+lispwoks +ucs2-string+)) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) + +ucs1-string+ + bs) (buffer-write-int (byte-length frob) bs) (buffer-write-string frob bs)) (persistent @@ -134,7 +149,15 @@ (pathname (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) - (buffer-write-byte +pathname+ bs) + (buffer-write-byte + #+(and allegro ics) +ucs2-pathname+ + #+(or (and sbcl sb-unicode) lispworks) + (etypecase s + (base-string +ucs1-pathname+) + (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) + +ucs1-pathname+ + bs) (buffer-write-int (byte-length s) bs) (buffer-write-string s bs))) (integer @@ -252,14 +275,36 @@ ((= tag +fixnum+) (buffer-read-fixnum bs)) ((= tag +nil+) nil) - ((= tag +symbol+) - (let ((name (buffer-read-string bs (buffer-read-fixnum bs))) + #-(and allegro ics) + ((= tag +ucs1-symbol+) + (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) + (maybe-package-name (%deserialize bs))) + (if maybe-package-name + (intern name (find-package maybe-package-name)) + (make-symbol name)))) + #+(or lispworks (and allegro ics)) + ((= tag +ucs2-symbol+) + (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) (if maybe-package-name (intern name (find-package maybe-package-name)) (make-symbol name)))) - ((= tag +string+) - (buffer-read-string bs (buffer-read-fixnum bs))) + #+(and sbcl sb-unicode) + ((= tag +ucs4-symbol+) + (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) + (maybe-package-name (%deserialize bs))) + (if maybe-package-name + (intern name (find-package maybe-package-name)) + (make-symbol name)))) + #-(and allegro ics) + ((= tag +ucs1-string+) + (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) + #+(or lispworks (and allegro ics)) + ((= tag +ucs2-string+) + (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) + #+(and sbcl sb-unicode) + ((= tag +ucs4-string+) + (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) ((= tag +persistent+) (get-cached-instance *store-controller* (buffer-read-fixnum bs) @@ -270,9 +315,18 @@ (buffer-read-double bs)) ((= tag +char+) (code-char (buffer-read-uint bs))) - ((= tag +pathname+) + #-(and allegro ics) + ((= tag +ucs1-pathname+) + (parse-namestring + (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) ""))) + #+(or lispworks (and allegro ics)) + ((= tag +ucs2-pathname+) + (parse-namestring + (or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) ""))) + #+(and sbcl sb-unicode) + ((= tag +ucs4-pathname+) (parse-namestring - (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) + (or (buffer-read-ucs4-string bs (buffer-read-fixnum bs)) ""))) ((= tag +positive-bignum+) (deserialize-bignum bs (buffer-read-fixnum bs) t)) ((= tag +negative-bignum+) Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.11 elephant/src/controller.lisp:1.12 --- elephant/src/controller.lisp:1.11 Sun Sep 19 19:49:25 2004 +++ elephant/src/controller.lisp Thu Feb 24 02:06:10 2005 @@ -49,6 +49,8 @@ (environment :type (or null pointer-void) :accessor controller-environment) (db :type (or null pointer-void) :accessor controller-db) + (oid-db :type (or null pointer-void) :accessor controller-oid-db) + (oid-seq :type (or null pointer-void) :accessor controller-oid-seq) (btrees :type (or null pointer-void) :accessor controller-btrees) (indices :type (or null pointer-void) :accessor controller-indices) (indices-assoc :type (or null pointer-void) @@ -102,33 +104,11 @@ ;; Should get cached since make-instance calls cache-instance (make-instance class-name :from-oid oid)))) -;; OID stuff -;; This stuff is all a hack until sequences appear in Sleepycat 4.3 -(defvar %oid-entry (uffi:allocate-foreign-object :char 12)) -(defvar %oid-lock (uffi:allocate-foreign-object :char 16)) - -(eval-when (:load-toplevel) - (loop for c across "%ELEPHANTOID" - for i from 0 to 11 - do (setf (uffi:deref-array %oid-entry '(:array :char) i) - (char-code c))) - (loop for c across "%ELEPHANTOIDLOCK" - for i from 0 to 15 - do (setf (uffi:deref-array %oid-lock '(:array :char) i) - (char-code c))) - ) - -(defvar %oid-entry-length 12) -(defvar %oid-lock-length 16) - (defun next-oid (sc) "Get the next OID." (declare (type store-controller sc)) - (sleepycat::next-counter (controller-environment sc) - (controller-db sc) - *current-transaction* - %oid-entry %oid-entry-length - %oid-lock %oid-lock-length)) + (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ + :auto-commit t :txn-nosync t)) ;; Open/close (defmethod open-controller ((sc store-controller) &key (recover nil) @@ -166,20 +146,23 @@ (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES" :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t) (sleepycat::db-fake-associate btrees indices-assoc :auto-commit t) + + (let ((db (db-create env))) + (setf (controller-oid-db sc) db) + (db-open db :file "%ELEPHANTOID" :database "%ELEPHANTOID" + :auto-commit t :type DB-BTREE :create t :thread thread) + (let ((oid-seq (db-sequence-create db))) + (db-sequence-set-cachesize oid-seq *cachesize*) + (db-sequence-set-flags oid-seq :seq-inc t :seq-wrap t) + (db-sequence-set-range oid-seq 0 most-positive-fixnum) + (db-sequence-initial-value oid-seq 0) + (db-sequence-open oid-seq "%ELEPHANTOID" + :auto-commit t :create t :thread t) + (setf (controller-oid-seq sc) oid-seq))) (let ((root (make-instance 'btree :from-oid -1))) - (setf (slot-value sc 'root) root) - (with-transaction () - (with-buffer-streams (key-buf value-buf) - (let ((key-b (buffer-stream-buffer key-buf))) - (setf (buffer-stream-buffer key-buf) %oid-entry) - (setf (sleepycat::buffer-stream-size key-buf) %oid-entry-length) - (unless (db-get-key-buffered db key-buf value-buf) - (reset-buffer-stream value-buf) - (buffer-write-int 0 value-buf) - (db-put-buffered db key-buf value-buf)) - (setf (buffer-stream-buffer key-buf) key-b)))) - sc)))) + (setf (slot-value sc 'root) root)) + sc))) (defmethod close-controller ((sc store-controller)) (when (slot-value sc 'root) @@ -188,6 +171,10 @@ ;; clean instance cache (setf (instance-cache sc) (make-cache-table :test 'eql)) ;; close handles / environment + (db-sequence-close (controller-oid-seq sc)) + (setf (controller-oid-seq sc) nil) + (db-close (controller-oid-db sc)) + (setf (controller-oid-db sc) nil) (db-close (controller-indices-assoc sc)) (setf (controller-indices-assoc sc) nil) (db-close (controller-indices sc)) @@ -232,6 +219,7 @@ (progn , at body) (close-controller *store-controller*)))) +;;; Make these respect the transaction keywords (e.g. degree-2) (defun start-transaction (&key (parent *current-transaction*)) "Start a transaction. May be nested but not interleaved." (vector-push-extend *current-transaction* *transaction-stack*) Index: elephant/src/berkeley-db.lisp diff -u elephant/src/berkeley-db.lisp:1.2 elephant/src/berkeley-db.lisp:1.3 --- elephant/src/berkeley-db.lisp:1.2 Sun Sep 19 19:46:56 2004 +++ elephant/src/berkeley-db.lisp Thu Feb 24 02:06:10 2005 @@ -64,7 +64,9 @@ %db-txn-begin db-transaction-begin %db-txn-abort db-transaction-abort %db-txn-commit db-transaction-commit - %db-transaction-id + %db-transaction-id + %db-sequence-get db-sequence-get + %db-sequence-get-lower db-sequence-get-fixnum )) ;; Environment @@ -298,7 +300,7 @@ (defun db-get-key-buffered (db key-buffer-stream value-buffer-stream &key (transaction *current-transaction*) - auto-commit get-both dirty-read) + auto-commit get-both degree-2 dirty-read) "Get a key / value pair from a DB. The key is encoded in a buffer-stream. Space for the value is passed in as a buffer-stream. On success the buffer-stream is returned for @@ -306,7 +308,7 @@ (declare (optimize (speed 3) (safety 0)) (type pointer-void db transaction) (type buffer-stream key-buffer-stream value-buffer-stream) - (type boolean auto-commit get-both dirty-read)) + (type boolean auto-commit get-both degree-2 dirty-read)) (loop for value-length fixnum = (buffer-stream-length value-buffer-stream) do @@ -318,6 +320,7 @@ value-length (flags :auto-commit auto-commit :get-both get-both + :degree-2 degree-2 :dirty-read dirty-read)) (declare (type fixnum result-size errno)) (cond @@ -347,7 +350,7 @@ (defun db-get-buffered (db key value-buffer-stream &key (key-size (length key)) (transaction *current-transaction*) - auto-commit get-both dirty-read) + auto-commit get-both degree-2 dirty-read) "Get a key / value pair from a DB. The key is passed as a string. Space for the value is passed in as a buffer-stream. On success the buffer-stream is returned for @@ -357,7 +360,7 @@ (type string key) (type buffer-stream value-buffer-stream) (type fixnum key-size) - (type boolean auto-commit get-both dirty-read)) + (type boolean auto-commit get-both degree-2 dirty-read)) (with-cstring (k key) (loop for value-length fixnum = (buffer-stream-length value-buffer-stream) @@ -368,6 +371,7 @@ value-length (flags :auto-commit auto-commit :get-both get-both + :degree-2 degree-2 :dirty-read dirty-read)) (declare (type fixnum result-size errno)) (cond @@ -385,7 +389,7 @@ (defun db-get (db key &key (key-size (length key)) (transaction *current-transaction*) - auto-commit get-both dirty-read) + auto-commit get-both degree-2 dirty-read) "Get a key / value pair from a DB. The key is passed as a string, and the value is returned as a string. If nothing is found, NIL is returned." @@ -393,7 +397,7 @@ (type pointer-void db transaction) (type string key) (type fixnum key-size) - (type boolean auto-commit get-both dirty-read)) + (type boolean auto-commit get-both degree-2 dirty-read)) (with-cstring (k key) (with-buffer-streams (value-buffer-stream) (loop @@ -405,6 +409,7 @@ value-length (flags :auto-commit auto-commit :get-both get-both + :degree-2 degree-2 :dirty-read dirty-read)) (declare (type fixnum result-size errno)) (cond @@ -585,13 +590,14 @@ :returning :pointer-void) (defun db-cursor (db &key (transaction *current-transaction*) - dirty-read) + degree-2 dirty-read) "Create a cursor." (declare (optimize (speed 3) (safety 0)) (type pointer-void db) - (type boolean dirty-read) + (type boolean degree-2 dirty-read) (type pointer-int *errno-buffer*)) - (let* ((curs (%db-cursor db transaction (flags :dirty-read dirty-read) + (let* ((curs (%db-cursor db transaction (flags :degree-2 degree-2 + :dirty-read dirty-read) *errno-buffer*)) (errno (deref-array *errno-buffer* '(:array :int) 0))) (declare (type pointer-void curs) @@ -1015,17 +1021,18 @@ :returning :pointer-void) (defun db-transaction-begin (env &key (parent *current-transaction*) - dirty-read txn-nosync txn-nowait + degree-2 dirty-read txn-nosync txn-nowait txn-sync) "Start a transaction. Transactions may be nested." (declare (optimize (speed 3) (safety 0)) (type pointer-void env parent) - (type boolean dirty-read txn-nosync txn-nowait + (type boolean degree-2 dirty-read txn-nosync txn-nowait txn-sync) (type pointer-int *errno-buffer*)) (let* ((txn (%db-txn-begin env parent - (flags :dirty-read dirty-read + (flags :degree-2 degree-2 + :dirty-read dirty-read :txn-nosync txn-nosync :txn-nowait txn-nowait :txn-sync txn-sync) @@ -1102,7 +1109,7 @@ (defmacro with-transaction ((&key transaction environment (parent '*current-transaction*) (retries 100) - dirty-read txn-nosync + degree-2 dirty-read txn-nosync txn-nowait txn-sync) &body body) "Execute a body with a transaction in place. On success, @@ -1120,6 +1127,7 @@ (let ((,txn (db-transaction-begin ,environment :parent ,parent + :degree-2 ,degree-2 :dirty-read ,dirty-read :txn-nosync ,txn-nosync :txn-nowait ,txn-nowait @@ -1332,7 +1340,195 @@ "Sets the duplicate comparision function to a hand-cooked function for Elephant to compare lisp values.") -;; Poor man's counters +;; Sequences + +(def-function ("db_sequence_create2" %db-sequence-create) + ((db :pointer-void) + (flags :unsigned-int) + (errno (* :int))) + :returning :pointer-void) + +(defun db-sequence-create (db) + "Create a new sequence." + (declare (optimize (speed 3) (safety 0)) + (type pointer-void db) + (type pointer-int *errno-buffer*)) + (let* ((seq + (%db-sequence-create db 0 *errno-buffer*)) + (errno (deref-array *errno-buffer* '(:array :int) 0))) + (declare (type pointer-void seq) + (type fixnum errno)) + (if (= errno 0) + seq + (error 'db-error :errno errno)))) + +(def-function ("db_sequence_open" %db-sequence-open) + ((seq :pointer-void) + (txn :pointer-void) + (key :cstring) + (key-size :unsigned-int) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-sequence-open (sequence transaction key key-size flags) + :flags (auto-commit create excl thread) + :cstrings (key) + :keys ((key-size (length key)) + (transaction *current-transaction*)) + :transaction transaction + :documentation "Open a sequence.") + +(def-function ("db_sequence_close" %db-sequence-close) + ((seq :pointer-void) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno (db-sequence-close %db-sequence-close) (sequence flags) + :documentation "Close a sequence.") + +(def-function ("db_sequence_get" %db-sequence-get) + ((seq :pointer-void) + (txn :pointer-void) + (delta :int) + (low :unsigned-int :out) + (high :int :out) + (flags :unsigned-int)) + :returning :int) + +(defun db-sequence-get (sequence delta &key auto-commit txn-nosync + (transaction *current-transaction*)) + "Get the next element." + (declare (optimize (speed 3) (safety 0)) + (type pointer-void sequence transaction) + (type fixnum delta) + (type boolean auto-commit txn-nosync)) + (multiple-value-bind + (errno low high) + (%db-sequence-get sequence transaction delta + (flags :auto-commit auto-commit + :txn-nosync txn-nosync)) + (declare (type fixnum errno) + (type (unsigned-byte 32) low) + (type (signed-byte 32) high)) + (cond ((= errno 0) (make-64-bit-integer high low)) + ((or (= errno db_lock_deadlock) + (= errno db_lock_notgranted)) + (throw 'transaction transaction)) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_get_lower" %db-sequence-get-lower) + ((seq :pointer-void) + (txn :pointer-void) + (delta :int) + (low :int :out) + (flags :unsigned-int)) + :returning :int) + +(defun db-sequence-get-fixnum (sequence delta &key auto-commit txn-nosync + (transaction *current-transaction*)) + "Get the next element as a fixnum." + (declare (optimize (speed 3) (safety 0)) + (type pointer-void sequence transaction) + (type fixnum delta) + (type boolean auto-commit txn-nosync)) + (multiple-value-bind + (errno low) + (%db-sequence-get-lower sequence transaction delta + (flags :auto-commit auto-commit + :txn-nosync txn-nosync)) + (declare (type fixnum errno low)) + (cond ((= errno 0) low) + ((or (= errno db_lock_deadlock) + (= errno db_lock_notgranted)) + (throw 'transaction transaction)) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_initial_value" %db-sequence-initial-value) + ((seq :pointer-void) + (low :unsigned-int) + (high :int)) + :returning :int) + +(defun db-sequence-initial-value (sequence value) + "Set the initial value." + (let ((errno + (%db-sequence-initial-value sequence (low32 value) (high32 value)))) + (declare (type fixnum errno)) + (cond ((= errno 0) nil) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_remove" %db-sequence-remove) + ((seq :pointer-void) + (txn :pointer-void) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-sequence-remove (sequence transaction flags) + :keys ((transaction *current-transaction*)) + :transaction transaction + :flags (auto-commit txn-nosync) + :documentation "Remove a sequence.") + +(def-function ("db_sequence_set_cachesize" %db-sequence-set-cachesize) + ((seq :pointer-void) + (size :int)) + :returning :int) + +(wrap-errno db-sequence-set-cachesize (sequence size) + :documentation "Set cache size for a sequence.") + +(def-function ("db_sequence_get_cachesize" %db-sequence-get-cachesize) + ((seq :pointer-void) + (size :int :out)) + :returning :int) + +(wrap-errno db-sequence-get-cachesize (sequence) + :outs 2 + :documentation "Get cache size for a sequence.") + +(def-function ("db_sequence_set_flags" %db-sequence-set-flags) + ((seq :pointer-void) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-sequence-set-flags (sequence flags) + :flags (seq-dec seq-inc seq-wrap) + :documentation "Set cache size for a sequence.") + +(def-function ("db_sequence_set_range" %db-sequence-set-range) + ((seq :pointer-void) + (minlow :unsigned-int) + (minhigh :int) + (maxlow :unsigned-int) + (maxhigh :int)) + :returning :int) + +(defun db-sequence-set-range (sequence min max) + "Set the range of a sequence" + (let ((errno + (%db-sequence-set-range sequence (low32 min) (high32 min) + (low32 max) (high32 max)))) + (declare (type fixnum errno)) + (cond ((= errno 0) nil) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_get_range" %db-sequence-get-range) + ((seq :pointer-void) + (minlow :unsigned-int :out) + (minhigh :int :out) + (maxlow :unsigned-int :out) + (maxhigh :int :out)) + :returning :int) + +(defun db-sequence-get-range (sequence) + "Get the range of a sequence" + (multiple-value-bind (errno minlow minhigh maxlow maxhigh) + (%db-sequence-get-range sequence) + (declare (type fixnum errno) + (type integer minlow minhigh maxlow maxhigh)) + (cond ((= errno 0) (values (make-64-bit-integer minhigh minlow) + (make-64-bit-integer maxhigh maxlow))) + (t (error 'db-error :errno errno))))) (def-function ("next_counter" %next-counter) ((env :pointer-void) From blee at common-lisp.net Thu Feb 24 01:06:25 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:06:25 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/Makefile Message-ID: <20050224010625.E3EE3884E2@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv4345 Modified Files: Makefile Log Message: updates for sbcl unicode, sleepycat 4.3, new sequences and degree-2 Date: Thu Feb 24 02:06:20 2005 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.5 elephant/Makefile:1.6 --- elephant/Makefile:1.5 Tue Sep 21 03:38:56 2004 +++ elephant/Makefile Thu Feb 24 02:06:20 2005 @@ -7,13 +7,13 @@ SHELL=/bin/sh UNAME:=$(shell uname -s) -DB42DIR=/usr/local/BerkeleyDB.4.2 -DBLIBDIR=$(DB42DIR)/lib/ -DBINCDIR=$(DB42DIR)/include/ +DB43DIR=/db/ben/lisp/db43 +DBLIBDIR=$(DB43DIR)/lib/ +DBINCDIR=$(DB43DIR)/include/ # *BSD users will probably want -#DBLIBDIR=/usr/local/lib/db42 -#DBINCDIR=/usr/local/include/db42 +#DBLIBDIR=/usr/local/lib/db43 +#DBINCDIR=/usr/local/include/db43 ifeq (Darwin,$(UNAME)) SHARED=-bundle @@ -22,5 +22,5 @@ endif libsleepycat.so: src/libsleepycat.c - gcc $(SHARED) -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm + gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm From blee at common-lisp.net Thu Feb 24 01:07:53 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:07:53 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/tests/mop-tests.lisp elephant/tests/elephant-tests.lisp Message-ID: <20050224010753.16AE68867D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv4404/tests Modified Files: mop-tests.lisp elephant-tests.lisp Log Message: mop updates : update-class, change-class, new slot allocation type... Date: Thu Feb 24 02:07:51 2005 Author: blee Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.6 elephant/tests/mop-tests.lisp:1.7 --- elephant/tests/mop-tests.lisp:1.6 Tue Sep 21 21:36:34 2004 +++ elephant/tests/mop-tests.lisp Thu Feb 24 02:07:51 2005 @@ -154,7 +154,8 @@ (defclass no-eval-initform () ((slot1 :initarg :slot1 :initform (error "Shouldn't be called"))) (:metaclass persistent-metaclass)) - (make-instance 'no-eval-initform :slot1 "something") + (let ((*auto-commit* t)) + (make-instance 'no-eval-initform :slot1 "something")) t) t) @@ -218,4 +219,26 @@ (let ((foo (make-instance 'btree))) (change-class foo (find-class 'indexed-btree)) (is-not-null (indices foo)))) - t) \ No newline at end of file + t) + +(deftest change-class3 + (progn + (defclass class-one () + ((slot1 :accessor slot1)) + (:metaclass persistent-metaclass)) + + (defclass class-two () + ((slot1 :initform 0 :accessor slot1) + (slot2 :initform 2 :accessor slot2)) + (:metaclass persistent-metaclass)) + + (let* ((*auto-commit* t) + (foo (make-instance 'class-one))) + (change-class foo (find-class 'class-two)) + (values + (slot1 foo) + (slot2 foo)))) + 0 2) + + + Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.4 elephant/tests/elephant-tests.lisp:1.5 --- elephant/tests/elephant-tests.lisp:1.4 Tue Sep 21 03:38:12 2004 +++ elephant/tests/elephant-tests.lisp Thu Feb 24 02:07:51 2005 @@ -89,6 +89,13 @@ #p"tests/testdb/" (asdf:component-pathname (asdf:find-system 'elephant-tests))))) +(defvar *sleepycatdb-path* + ;;"/usr/local/share/common-lisp/elephant-0.2/tests/testdb" + (namestring + (merge-pathnames + #p"tests/sleepycatdb/" + (asdf:component-pathname (asdf:find-system 'elephant-tests))))) + (defun do-all-tests() (with-open-store (*testdb-path*) (let ((*auto-commit* nil)) From blee at common-lisp.net Thu Feb 24 01:07:55 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:07:55 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/src/metaclasses.lisp elephant/src/elephant.lisp elephant/src/classes.lisp Message-ID: <20050224010755.4CAD28867D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv4404/src Modified Files: metaclasses.lisp elephant.lisp classes.lisp Log Message: mop updates : update-class, change-class, new slot allocation type... Date: Thu Feb 24 02:07:53 2005 Author: blee Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.6 elephant/src/metaclasses.lisp:1.7 --- elephant/src/metaclasses.lisp:1.6 Sun Sep 19 19:50:38 2004 +++ elephant/src/metaclasses.lisp Thu Feb 24 02:07:52 2005 @@ -49,12 +49,24 @@ to user-defined classes and collections.)")) (defclass persistent-metaclass (standard-class) - () + ((%persistent-slots :accessor %persistent-slots)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by default; use the :transient flag otherwise.")) +(defmethod persistent-slots ((class persistent-metaclass)) + (car (%persistent-slots class))) + +(defmethod persistent-slots ((class standard-class)) + nil) + +(defmethod old-persistent-slots ((class persistent-metaclass)) + (cdr (%persistent-slots class))) + +(defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list) + (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class))))) + (defclass persistent-slot-definition (standard-slot-definition) ()) @@ -81,8 +93,12 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil) +#+allegro +(defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) + '(:instance :class :database)) + (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) - :class) + :database) (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) "Checks for the transient tag (and the allocation type) @@ -128,29 +144,6 @@ (t (find-class 'persistent-effective-slot-definition))))) -#+(or cmu sbcl) -(defgeneric ensure-storage-exists (class slot-definition slot-name)) - -#+(or cmu sbcl) -(defmethod ensure-storage-exists (class slot-definition slot-name) - nil) - -#+(or cmu sbcl) -(defmethod ensure-storage-exists (class (slot-definition persistent-slot-definition) slot-name) - (let ((use-class (or (slot-definition-allocation-class slot-definition) - class))) - (when (not (assoc slot-name (class-slot-cells use-class))) - (setf (plist-value use-class 'class-slot-cells) - (append - (plist-value use-class 'class-slot-cells) - (list (cons slot-name +slot-unbound+))))))) - -#+(or cmu sbcl) -(defmethod compute-effective-slot-definition :around ((class persistent-metaclass) slot-name direct-slot-definitions) - (let ((slot-definition (call-next-method))) - (ensure-storage-exists class slot-definition slot-name) - slot-definition)) - #+openmcl (defmethod compute-effective-slot-definition ((class persistent-metaclass) slot-name direct-slot-definitions) (declare (ignore slot-name)) @@ -198,7 +191,7 @@ (if (ensure-transient-chain slot-definitions initargs) (append initargs '(:transient t)) (progn - (setf (getf initargs :allocation) :class) + (setf (getf initargs :allocation) :database) initargs)))) (defmacro persistent-slot-reader (instance name) Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.13 elephant/src/elephant.lisp:1.14 --- elephant/src/elephant.lisp:1.13 Tue Sep 21 03:35:11 2004 +++ elephant/src/elephant.lisp Thu Feb 24 02:07:52 2005 @@ -104,6 +104,8 @@ slot-makunbound-using-class slot-definition-allocation slot-definition-initargs + class-finalized-p + finalize-inheritance compute-slots initialize-internal-slot-functions @@ -142,6 +144,8 @@ slot-makunbound-using-class slot-definition-allocation slot-definition-initargs + class-finalized-p + finalize-inheritance compute-slots) #+sbcl (:import-from :sb-pcl @@ -181,6 +185,8 @@ slot-makunbound-using-class slot-definition-allocation slot-definition-initargs + class-finalized-p + finalize-inheritance compute-slots) #+allegro (:import-from :excl Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.12 elephant/src/classes.lisp:1.13 --- elephant/src/classes.lisp:1.12 Tue Sep 21 21:35:29 2004 +++ elephant/src/classes.lisp Thu Feb 24 02:07:52 2005 @@ -54,9 +54,9 @@ (cache-instance *store-controller* instance)) (defclass persistent-object (persistent) - ((%persistent-slots :transient t)) + () (:documentation -"Superclass of all user-defined persistent classes. This is + "Superclass of all user-defined persistent classes. This is automatically inherited if you use the persistent-metaclass metaclass.") (:metaclass persistent-metaclass)) @@ -73,6 +73,63 @@ direct-superclasses) args) (call-next-method)))) +#+allegro +(defun make-persistent-reader (name slot-definition class class-name) + (eval `(defmethod ,name ((instance ,class-name)) + (slot-value-using-class ,class instance ,slot-definition)))) + +#+allegro +(defun make-persistent-writer (name slot-definition class class-name) + (eval `(defmethod (setf ,name) ((instance ,class-name) value) + (setf (slot-value-using-class ,class instance ,slot-definition) + value)))) + +#+allegro +(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) + (let ((readers (slot-definition-readers slot-definition)) + (writers (slot-definition-writers slot-definition)) + (class-name (class-name class))) + (loop for reader in readers + do (make-persistent-reader reader slot-definition class class-name)) + (loop for writer in writers + do (make-persistent-writer writer slot-definition class class-name)))) + +#+allegro +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (loop with persistent-slots = (persistent-slots instance) + for slot-def in (class-direct-slots instance) + when (member (slot-definition-name slot-def) persistent-slots) + do (initialize-accessors slot-def instance)) + (make-instances-obsolete instance)))) + +#+(or cmu sbcl) +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (make-instances-obsolete instance)))) + +#+allegro +(defmethod finalize-inheritance :around ((instance persistent-metaclass)) + (prog1 + (call-next-method) + (if (not (slot-boundp instance '%persistent-slots)) + (setf (%persistent-slots instance) + (cons (persistent-slot-names instance) nil))))) + +#+(or cmu sbcl) +(defmethod finalize-inheritance :around ((instance persistent-metaclass)) + (prog1 + (call-next-method) + (if (not (slot-boundp instance '%persistent-slots)) + (setf (%persistent-slots instance) + (cons (persistent-slot-names instance) nil))))) + (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for @@ -111,45 +168,76 @@ ;; let the implementation initialize the transient slots (apply #'call-next-method instance transient-slot-inits initargs))))) +(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) + ;; probably should delete discarded slots, but we'll worry about that later + (prog1 + (call-next-method) + (let* ((class (class-of instance)) + (new-persistent-slots (set-difference (persistent-slots class) + (old-persistent-slots class)))) + + (apply #'shared-initialize instance new-persistent-slots initargs)))) + +(defun find-slot-def-by-name (class slot-name) + (loop for slot-def in (class-slots class) + when (eq (slot-definition-name slot-def) slot-name) + do (return slot-def))) + (defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) - "Need to also update the persistent-slots, which have -:class allocation." - (let ((new-persistent-slots - (loop for slotd in (class-slots (class-of current)) - for slot-name = (slot-definition-name slotd) - with old-slot-names = (mapcar #'slot-definition-name - (class-slots (class-of previous))) - when (and (not (member slot-name old-slot-names :test #'eq)) - (persistent-p slotd)) - collect slot-name))) - (apply #'shared-initialize current new-persistent-slots initargs) + (let* ((old-class (class-of previous)) + (new-class (class-of current)) + (new-persistent-slots (set-difference + (persistent-slots new-class) + (persistent-slots old-class))) + (raw-retained-persistent-slots (intersection (persistent-slots new-class) + (persistent-slots old-class))) + (retained-unbound-slots (loop for slot-name in raw-retained-persistent-slots + when (not (persistent-slot-boundp previous slot-name)) + collect slot-name)) + (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) + (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) + (loop for slot-def in (class-slots new-class) + when (member (slot-definition-name slot-def) retained-persistent-slots) + do (setf (slot-value-using-class new-class + current + slot-def) + (slot-value-using-class old-class + previous + (find-slot-def-by-name old-class (slot-definition-name slot-def))))) (call-next-method))) -(defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." - (declare (optimize (speed 3)) - (ignore class)) + (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name))) -(defmethod (setf slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." - (declare (optimize (speed 3)) - (ignore class)) + (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name))) -(defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." - (declare (optimize (speed 3)) - (ignore class)) + (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp instance name))) -(defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) + "Checks if the slot exists in the database." + (declare (optimize (speed 3))) + (loop for slot in (class-slots class) + for matches-p = (eq (slot-definition-name slot) slot-name) + until matches-p + finally (if (and matches-p + (typep slot 'persistent-slot-definition)) + (persistent-slot-boundp instance slot-name) + (call-next-method)))) + +(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." - (declare (optimize (speed 3)) - (ignore class)) + (declare (optimize (speed 3))) (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize (slot-definition-name slot-def) key-buf) @@ -158,4 +246,11 @@ :transaction *current-transaction* :auto-commit *auto-commit*)) instance) - \ No newline at end of file + +#+allegro +(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) + (loop for slot in (class-slots class) + until (eq (slot-definition-name slot) slot-name) + finally (if (typep slot 'persistent-slot-definition) + (slot-makunbound-using-class class instance slot) + (call-next-method)))) \ No newline at end of file From blee at common-lisp.net Thu Feb 24 01:08:00 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:08:00 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/elephant.asd elephant/elephant-tests.asd Message-ID: <20050224010800.EAFFF884E2@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv4404 Modified Files: elephant.asd elephant-tests.asd Log Message: mop updates : update-class, change-class, new slot allocation type... Date: Thu Feb 24 02:07:55 2005 Author: blee Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.6 elephant/elephant.asd:1.7 --- elephant/elephant.asd:1.6 Thu Sep 16 06:12:41 2004 +++ elephant/elephant.asd Thu Feb 24 02:07:54 2005 @@ -56,6 +56,8 @@ (:file "berkeley-db") (:file "elephant") (:file "utils") + #+cmu + (:file "cmu-mop-patches") (:file "metaclasses") (:file "classes") (:file "collections") Index: elephant/elephant-tests.asd diff -u elephant/elephant-tests.asd:1.2 elephant/elephant-tests.asd:1.3 --- elephant/elephant-tests.asd:1.2 Thu Sep 16 06:11:42 2004 +++ elephant/elephant-tests.asd Thu Feb 24 02:07:55 2005 @@ -57,7 +57,7 @@ (:file "testserializer") (:file "mop-tests") (:file "testcollections") - ;(:file "testsleepycat") + (:file "testsleepycat") ) :serial t))) From blee at common-lisp.net Thu Feb 24 01:09:25 2005 From: blee at common-lisp.net (blee at common-lisp.net) Date: Thu, 24 Feb 2005 02:09:25 +0100 (CET) Subject: [elephant-cvs] CVS update: elephant/src/cmu-mop-patches.lisp Message-ID: <20050224010925.91CBC884E2@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv4460/src Added Files: cmu-mop-patches.lisp Log Message: mop updates : update-class, change-class, new slot allocation type... Date: Thu Feb 24 02:09:24 2005 Author: blee