Menu
▾
▴
clisp-cvs digest, Vol 1 #622 - 5 msgs
|
From: <cli...@li...> - 2004-07-27 15:37:43
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src clos-method1.lisp,1.8,1.9 clos-method3.lisp,1.3,1.4 ChangeLog,1.3332,1.3333 (Bruno Haible) 2. clisp/src clos-method1.lisp,1.9,1.10 clos-method2.lisp,1.6,1.7 clos-method3.lisp,1.4,1.5 clos-class3.lisp,1.25,1.26 clos-class5.lisp,1.29,1.30 ChangeLog,1.3333,1.3334 (Bruno Haible) 3. clisp/src clos-method2.lisp,1.7,1.8 ChangeLog,1.3334,1.3335 (Sam Steingold) 4. clisp/doc unix-ent.xml,1.48,1.49 (Sam Steingold) 5. clisp/modules/berkeley-db test.tst,1.7,1.8 dbi.lisp,1.13,1.14 berkeley-db.xml,1.27,1.28 bdb.c,1.44,1.45 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-method1.lisp,1.8,1.9 clos-method3.lisp,1.3,1.4 ChangeLog,1.3332,1.3333 Date: Tue, 27 Jul 2004 09:45:45 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21082/src Modified Files: clos-method1.lisp clos-method3.lisp ChangeLog Log Message: Process the qualifiers as specified in the MOP. Index: clos-method3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-method3.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- clos-method3.lisp 26 Jul 2004 08:59:31 -0000 1.3 +++ clos-method3.lisp 27 Jul 2004 09:45:41 -0000 1.4 @@ -39,6 +39,7 @@ 'reinitialize-instance instance)) +;; MOP p. 82 (defgeneric method-qualifiers (method) (:method ((method standard-method)) (std-method-qualifiers method))) Index: clos-method1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-method1.lisp,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- clos-method1.lisp 26 Jul 2004 08:59:31 -0000 1.8 +++ clos-method1.lisp 27 Jul 2004 09:45:41 -0000 1.9 @@ -27,7 +27,7 @@ (parameter-specializers ; list ({class | (EQL object)}*) :type list :accessor std-method-parameter-specializers) - (qualifiers ; list of symbols, e.g. (:before) + (qualifiers ; list of non-NIL atoms, e.g. (:before) :type list :accessor std-method-qualifiers) (signature ; signature struct (see functions.lisp) @@ -83,6 +83,12 @@ &allow-other-keys) (when *classes-finished* (apply #'%initialize-instance method args)) ; == (call-next-method) + (unless (proper-list-p qualifiers) + (error (TEXT "(~S ~S): The ~S argument should be a proper list, not ~S") + 'initialize-instance 'standard-method ':qualifiers qualifiers)) + (unless (notany #'listp qualifiers) + (error (TEXT "(~S ~S): The qualifiers list should consist of non-NIL atoms, not ~S") + 'initialize-instance 'standard-method qualifiers)) (setf (std-method-function method) function) (setf (std-method-wants-next-method-p method) wants-next-method-p) (setf (std-method-parameter-specializers method) parameter-specializers) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3332 retrieving revision 1.3333 diff -u -d -r1.3332 -r1.3333 --- ChangeLog 26 Jul 2004 19:06:25 -0000 1.3332 +++ ChangeLog 27 Jul 2004 09:45:41 -0000 1.3333 @@ -1,3 +1,8 @@ +2004-06-03 Bruno Haible <br...@cl...> + + * clos-method1.lisp (initialize-instance-<standard-method>): Check the + qualifiers argument. + 2004-07-26 Sam Steingold <sd...@gn...> * modules/berkeley-db/bdb.c (BDB:DBE-SET-OPTIONS): finish the --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-method1.lisp,1.9,1.10 clos-method2.lisp,1.6,1.7 clos-method3.lisp,1.4,1.5 clos-class3.lisp,1.25,1.26 clos-class5.lisp,1.29,1.30 ChangeLog,1.3333,1.3334 Date: Tue, 27 Jul 2004 09:48:03 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv21451/src Modified Files: clos-method1.lisp clos-method2.lisp clos-method3.lisp clos-class3.lisp clos-class5.lisp ChangeLog Log Message: Method initialization supports :lambda-list argument. Index: clos-class5.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class5.lisp,v retrieving revision 1.29 retrieving revision 1.30 diff -u -d -r1.29 -r1.30 --- clos-class5.lisp 26 Jul 2004 08:59:31 -0000 1.29 +++ clos-class5.lisp 27 Jul 2004 09:48:00 -0000 1.30 @@ -356,7 +356,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'standard-object) (find-class 't)) :qualifiers '() - :signature #s(compiler::signature :req-num 2 :rest-p t))) + :lambda-list '(instance slot-names &rest initargs) + 'signature #s(compiler::signature :req-num 2 :rest-p t))) (do-defmethod 'shared-initialize (make-instance-<standard-method> <standard-method> :initfunction #'(lambda (gf) (declare (ignore gf)) @@ -365,7 +366,8 @@ :parameter-specializers (list (find-class 'structure-object) (find-class 't)) :qualifiers '() - :signature #s(compiler::signature :req-num 2 :rest-p t))) + :lambda-list '(instance slot-names &rest initargs) + 'signature #s(compiler::signature :req-num 2 :rest-p t))) ;; CLtL2 28.1.12., ANSI CL 7.3. (defgeneric reinitialize-instance @@ -409,7 +411,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'standard-object)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(instance &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) (do-defmethod 'reinitialize-instance (make-instance-<standard-method> <standard-method> :initfunction #'(lambda (gf) (declare (ignore gf)) @@ -417,7 +420,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'structure-object)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(instance &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) ;; At the first call of REINITIALIZE-INSTANCE of each class ;; we memorize the needed information in *reinitialize-instance-table*. (defun initial-reinitialize-instance (instance &rest initargs) @@ -473,7 +477,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'standard-object)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(instance &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) (do-defmethod 'initialize-instance (make-instance-<standard-method> <standard-method> :initfunction #'(lambda (gf) (declare (ignore gf)) @@ -481,7 +486,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'structure-object)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(instance &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) ;; At the first call of MAKE-INSTANCE or INITIALIZE-INSTANCE of each class ;; we memorize the needed information in *make-instance-table*. (defun initial-initialize-instance (instance &rest initargs) @@ -529,7 +535,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'standard-class)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(class &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) (do-defmethod 'allocate-instance (make-instance-<standard-method> <standard-method> :initfunction #'(lambda (gf) (declare (ignore gf)) @@ -537,7 +544,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'structure-class)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(class &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) ;; CLtL2 28.1.9.7., ANSI CL 7.1.7. (defgeneric make-instance (class &rest initargs &key &allow-other-keys) @@ -591,7 +599,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'standard-class)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(class &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) (do-defmethod 'make-instance (make-instance-<standard-method> <standard-method> :initfunction #'(lambda (gf) (declare (ignore gf)) @@ -599,7 +608,8 @@ :wants-next-method-p nil :parameter-specializers (list (find-class 'structure-class)) :qualifiers '() - :signature #s(compiler::signature :req-num 1 :rest-p t))) + :lambda-list '(class &rest initargs) + 'signature #s(compiler::signature :req-num 1 :rest-p t))) ;; At the first call of MAKE-INSTANCE or INITIALIZE-INSTANCE of each class ;; we memorize the needed information in *make-instance-table*. (defun initial-make-instance (class &rest initargs) Index: clos-method1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-method1.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- clos-method1.lisp 27 Jul 2004 09:45:41 -0000 1.9 +++ clos-method1.lisp 27 Jul 2004 09:48:00 -0000 1.10 @@ -30,6 +30,9 @@ (qualifiers ; list of non-NIL atoms, e.g. (:before) :type list :accessor std-method-qualifiers) + (lambda-list ; lambda list without specializers + :type list + :accessor std-method-lambda-list) (signature ; signature struct (see functions.lisp) :type (simple-vector 6) :accessor std-method-signature) @@ -70,29 +73,58 @@ (defun initialize-instance-<standard-method> (method &rest args &key (qualifiers '()) - ;(lambda-list nil lambda-list-p) + (lambda-list nil lambda-list-p) ;(specializers nil specializers-p) (function nil function-p) ;(documentation nil) initfunction wants-next-method-p parameter-specializers - signature + ((signature signature) nil signature-p) gf origin &allow-other-keys) (when *classes-finished* (apply #'%initialize-instance method args)) ; == (call-next-method) + ; Check the qualifiers. (unless (proper-list-p qualifiers) (error (TEXT "(~S ~S): The ~S argument should be a proper list, not ~S") 'initialize-instance 'standard-method ':qualifiers qualifiers)) (unless (notany #'listp qualifiers) (error (TEXT "(~S ~S): The qualifiers list should consist of non-NIL atoms, not ~S") 'initialize-instance 'standard-method qualifiers)) + ; Check the lambda-list and compute the signature from it. + (unless lambda-list-p + (error (TEXT "(~S ~S): Missing ~S argument.") + 'initialize-instance 'standard-method ':lambda-list)) + (multiple-value-bind (reqvars optvars optinits optsvars rest + keyp keywords keyvars keyinits keysvars + allowp auxvars auxinits) + (analyze-lambdalist lambda-list + #'(lambda (errorstring &rest arguments) + (error (TEXT "(~S ~S): Invalid ~S argument: ~A") + 'initialize-instance 'standard-method ':lambda-list + (apply #'format nil errorstring arguments)))) + (declare (ignore optinits optsvars keyvars keyinits keysvars + auxvars auxinits)) + ; Check the signature argument. It is optional; specifying it only has + ; the purpose of saving memory allocation (by sharing the same signature + ; for all reader methods and the same signature for all writer methods). + (let ((sig (make-signature + :req-num (length reqvars) :opt-num (length optvars) + :rest-p (or keyp (not (eql rest 0))) :keys-p keyp + :keywords keywords :allow-p allowp))) + (if signature-p + (unless (equalp sig signature) + (error (TEXT "(~S ~S): Lambda-list ~S and signature ~S are inconsistent.") + 'initialize-instance 'standard-method lambda-list signature)) + (setq signature sig)))) + ; Fill the slots. (setf (std-method-function method) function) (setf (std-method-wants-next-method-p method) wants-next-method-p) (setf (std-method-parameter-specializers method) parameter-specializers) (setf (std-method-qualifiers method) qualifiers) + (setf (std-method-lambda-list method) lambda-list) (setf (std-method-signature method) signature) (setf (std-method-gf method) gf) (setf (std-method-initfunction method) initfunction) Index: clos-method3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-method3.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- clos-method3.lisp 27 Jul 2004 09:45:41 -0000 1.4 +++ clos-method3.lisp 27 Jul 2004 09:48:00 -0000 1.5 @@ -44,6 +44,11 @@ (:method ((method standard-method)) (std-method-qualifiers method))) +;; MOP p. 82 +(defgeneric method-lambda-list (method) + (:method ((method standard-method)) + (std-method-lambda-list method))) + (defgeneric function-keywords (method) (:method ((method standard-method)) (let ((sig (std-method-signature method))) Index: clos-method2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-method2.lisp,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- clos-method2.lisp 26 Jul 2004 08:59:31 -0000 1.6 +++ clos-method2.lisp 27 Jul 2004 09:48:00 -0000 1.7 @@ -74,11 +74,12 @@ (declare (ignore reqs optinits optsvars keyvars keyinits keysvars auxvars auxinits)) (let ((optanz (length optvars)) - (restp (or keyp (not (eql rest 0))))) + (restp (or keyp (not (eql rest 0)))) + (weakened-lambda-list lambda-list)) ;; Methods have an implicit &allow-other-keys (CLtL2 28.1.6.4., ANSI CL 7.6.4.): (when (and keyp (not allowp)) (let ((index (+ (position '&KEY lambda-list :test #'eq) 1 (length keywords)))) - (setq lambda-list + (setq weakened-lambda-list `(,@(subseq lambda-list 0 index) &ALLOW-OTHER-KEYS ,@(subseq lambda-list index))))) (let* ((self (gensym)) @@ -92,7 +93,7 @@ (push `(IGNORABLE ,@(nreverse ignorable-req-vars)) declarations)) (let ((lambdabody-part1 - `(,lambda-list + `(,weakened-lambda-list ,@(if declarations `((DECLARE ,@declarations))))) (lambdabody-part2 (if (eq caller 'generic-function) @@ -129,6 +130,7 @@ :PARAMETER-SPECIALIZERS (LIST ,@(nreverse req-specializer-forms)) :QUALIFIERS ',qualifiers - :SIGNATURE ,sig + :LAMBDA-LIST ',lambda-list + 'SIGNATURE ,sig ,@(if (eq caller 'DEFGENERIC) `(:ORIGIN T))) sig))))))))) Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.25 retrieving revision 1.26 diff -u -d -r1.25 -r1.26 --- clos-class3.lisp 23 Jul 2004 10:56:09 -0000 1.25 +++ clos-class3.lisp 27 Jul 2004 09:48:00 -0000 1.26 @@ -1237,7 +1237,8 @@ :wants-next-method-p t :parameter-specializers (list class) :qualifiers nil - :signature (sys::memoized (make-signature :req-num 1)) + :lambda-list '(OBJECT) + 'signature (sys::memoized (make-signature :req-num 1)) :slot-definition slot)) (method-class (apply #'reader-method-class class slot args))) @@ -1271,7 +1272,8 @@ :wants-next-method-p t :parameter-specializers (list <t> class) :qualifiers nil - :signature (sys::memoized (make-signature :req-num 2)) + :lambda-list '(NEW-VALUE OBJECT) + 'signature (sys::memoized (make-signature :req-num 2)) :slot-definition slot)) (method-class (apply #'writer-method-class class slot args))) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3333 retrieving revision 1.3334 diff -u -d -r1.3333 -r1.3334 --- ChangeLog 27 Jul 2004 09:45:41 -0000 1.3333 +++ ChangeLog 27 Jul 2004 09:48:00 -0000 1.3334 @@ -1,3 +1,16 @@ +2004-06-04 Bruno Haible <br...@cl...> + + * clos-method1.lisp (standard-method): Add lambda-list slot. + (initialize-instance-<standard-method>): Accept :lambda-list argument. + Check it. Compute the signature from it. + * clos-method2.lisp (analyze-method-description): Add a :LAMBDA-LIST + initializer to the generated form. + * clos-method3.lisp (method-lambda-list): New function. + * clos-class3.lisp (install-class-direct-accessors): Provide + :lambda-list arguments for all methods. + * clos-class5.lisp (shared-initialize, reinitialize-instance, + initialize-instance, allocate-instance, make-instance): Likewise. + 2004-06-03 Bruno Haible <br...@cl...> * clos-method1.lisp (initialize-instance-<standard-method>): Check the --__--__-- Message: 3 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src clos-method2.lisp,1.7,1.8 ChangeLog,1.3334,1.3335 Date: Tue, 27 Jul 2004 15:03:46 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv11751/src Modified Files: clos-method2.lisp ChangeLog Log Message: (analyze-method-description): signal an error when a lambda-list entry is invalid Index: clos-method2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-method2.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- clos-method2.lisp 27 Jul 2004 09:48:00 -0000 1.7 +++ clos-method2.lisp 27 Jul 2004 15:03:34 -0000 1.8 @@ -41,6 +41,10 @@ (if (atom item) (progn (push item req-vars) 't) (progn + (when (cddr item) + (error-of-type 'source-program-error + (TEXT "~S ~S: invalid specialized lambda list entry ~S") + caller funname item)) (push (first item) req-vars) (push (first item) ignorable-req-vars) ; CLtL2 p. 840 top (second item))))) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3334 retrieving revision 1.3335 diff -u -d -r1.3334 -r1.3335 --- ChangeLog 27 Jul 2004 09:48:00 -0000 1.3334 +++ ChangeLog 27 Jul 2004 15:03:35 -0000 1.3335 @@ -1,3 +1,8 @@ +2004-07-27 Sam Steingold <sd...@gn...> + + * clos-method2.lisp (analyze-method-description): signal an error + when a lambda-list entry is invalid + 2004-06-04 Bruno Haible <br...@cl...> * clos-method1.lisp (standard-method): Add lambda-list slot. --__--__-- Message: 4 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc unix-ent.xml,1.48,1.49 Date: Tue, 27 Jul 2004 15:34:50 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18012/doc Modified Files: unix-ent.xml Log Message: interface to the LOG subsystem Index: unix-ent.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/unix-ent.xml,v retrieving revision 1.48 retrieving revision 1.49 diff -u -d -r1.48 -r1.49 --- unix-ent.xml 23 Jul 2004 22:17:46 -0000 1.48 +++ unix-ent.xml 27 Jul 2004 15:34:47 -0000 1.49 @@ -114,6 +114,7 @@ <!ENTITY sleepycat-berkeley-db "<ulink url='http://www.sleepycat.com/docs/index.html'>Berkeley DB from Sleepycat Software</ulink>"> <!ENTITY db_create "<ulink url='&bdb;db_create.html'><function>db_create</function></ulink>"> <!ENTITY db_version "<ulink url='&bdb;env_version.html'><function>db_version</function></ulink>"> +<!ENTITY db_log_compare "<ulink url='&bdb;log_compare.html'><function>log_compare</function></ulink>"> <!ENTITY dbe_create "<ulink url='&bdb;env_create.html'><function>db_env_create</function></ulink>"> <!ENTITY DB_close "<ulink url='&bdb;db_close.html'><function>DB->close</function></ulink>"> <!ENTITY DB_cursor "<ulink url='&bdb;db_cursor.html'><function>DB->cursor</function></ulink>"> @@ -179,6 +180,14 @@ <!ENTITY DBE_set_errfile "<ulink url='&bdb;env_set_errfile.html'><function>DB_ENV->set_errfile</function></ulink>"> <!ENTITY DBE_get_flags "<ulink url='&bdb;env_set_flags.html'><function>DB_ENV->get_flags</function></ulink>"> <!ENTITY DBE_set_flags "<ulink url='&bdb;env_set_flags.html'><function>DB_ENV->set_flags</function></ulink>"> +<!ENTITY DBE_get_lg_bsize "<ulink url='&bdb;env_set_lg_bsize.html'><function>DB_ENV->get_lg_bsize</function></ulink>"> +<!ENTITY DBE_set_lg_bsize "<ulink url='&bdb;env_set_lg_bsize.html'><function>DB_ENV->set_lg_bsize</function></ulink>"> +<!ENTITY DBE_get_lg_dir "<ulink url='&bdb;env_set_lg_dir.html'><function>DB_ENV->get_lg_dir</function></ulink>"> +<!ENTITY DBE_set_lg_dir "<ulink url='&bdb;env_set_lg_dir.html'><function>DB_ENV->set_lg_dir</function></ulink>"> +<!ENTITY DBE_get_lg_max "<ulink url='&bdb;env_set_lg_max.html'><function>DB_ENV->get_lg_max</function></ulink>"> +<!ENTITY DBE_set_lg_max "<ulink url='&bdb;env_set_lg_max.html'><function>DB_ENV->set_lg_max</function></ulink>"> +<!ENTITY DBE_get_lg_regionmax "<ulink url='&bdb;env_set_lg_regionmax.html'><function>DB_ENV->get_lg_regionmax</function></ulink>"> +<!ENTITY DBE_set_lg_regionmax "<ulink url='&bdb;env_set_lg_regionmax.html'><function>DB_ENV->set_lg_regionmax</function></ulink>"> <!ENTITY DBE_get_lk_conflicts "<ulink url='&bdb;env_set_lk_conflicts.html'><function>DB_ENV->get_lk_conflicts</function></ulink>"> <!ENTITY DBE_set_lk_conflicts "<ulink url='&bdb;env_set_lk_conflicts.html'><function>DB_ENV->set_lk_conflicts</function></ulink>"> <!ENTITY DBE_get_lk_detect "<ulink url='&bdb;env_set_lk_detect.html'><function>DB_ENV->get_lk_detect</function></ulink>"> @@ -209,13 +218,21 @@ <!ENTITY DBE_lock_id_free "<ulink url='&bdb;env_lock_id_free.html'><function>DB_ENV->lock_id_free</function></ulink>"> <!ENTITY DBE_lock_put "<ulink url='&bdb;env_lock_put.html'><function>DB_ENV->lock_put</function></ulink>"> <!ENTITY DBE_lock_stat "<ulink url='&bdb;env_lock_stat.html'><function>DB_ENV->lock_stat</function></ulink>"> +<!ENTITY DBE_log_archive "<ulink url='&bdb;env_log_archive.html'><function>DB_ENV->log_archive</function></ulink>"> +<!ENTITY DBE_log_cursor "<ulink url='&bdb;env_log_cursor.html'><function>DB_ENV->log_cursor</function></ulink>"> +<!ENTITY DBE_log_file "<ulink url='&bdb;env_log_file.html'><function>DB_ENV->log_file</function></ulink>"> +<!ENTITY DBE_log_flush "<ulink url='&bdb;env_log_flush.html'><function>DB_ENV->log_flush</function></ulink>"> +<!ENTITY DBE_log_put "<ulink url='&bdb;env_log_put.html'><function>DB_ENV->log_put</function></ulink>"> +<!ENTITY DBE_log_stat "<ulink url='&bdb;env_log_stat.html'><function>DB_ENV->log_stat</function></ulink>"> <!ENTITY DBE_open "<ulink url='&bdb;env_open.html'><function>DB_ENV->open</function></ulink>"> <!ENTITY DBE_remove "<ulink url='&bdb;env_remove.html'><function>DB_ENV->remove</function></ulink>"> <!ENTITY DBE_set_rpc_server "<ulink url='&bdb;env_set_rpc_server.html'><function>DB_ENV->set_rpc_server</function></ulink>"> <!ENTITY DBE_txn_begin "<ulink url='&bdb;txn_begin.html'><function>DB_ENV->txn_begin</function></ulink>"> <!ENTITY DBE_txn_checkpoint "<ulink url='&bdb;txn_checkpoint.html'><function>DB_ENV->txn_checkpoint</function></ulink>"> -<!ENTITY DBE_txn_recover "<ulink url='&bdb;txn_txn_recover.html'><function>DB_ENV->txn_recover</function></ulink>"> -<!ENTITY DBE_txn_stat "<ulink url='&bdb;txn_txn_stat.html'><function>DB_ENV->txn_stat</function></ulink>"> +<!ENTITY DBE_txn_recover "<ulink url='&bdb;txn_recover.html'><function>DB_ENV->txn_recover</function></ulink>"> +<!ENTITY DBE_txn_stat "<ulink url='&bdb;txn_stat.html'><function>DB_ENV->txn_stat</function></ulink>"> +<!ENTITY LOGC_close "<ulink url='&bdb;ogc_close.html'><function>DB_LOGC->close</function></ulink>"> +<!ENTITY LOGC_get "<ulink url='&bdb;ogc_get.html'><function>DB_LOGC->get</function></ulink>"> <!ENTITY TXN_abort "<ulink url='&bdb;txn_abort.html'><function>DB_TXN->abort</function></ulink>"> <!ENTITY TXN_commit "<ulink url='&bdb;txn_commit.html'><function>DB_TXN->commit</function></ulink>"> <!ENTITY TXN_discard "<ulink url='&bdb;txn_discard.html'><function>DB_TXN->discard</function></ulink>"> --__--__-- Message: 5 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/modules/berkeley-db test.tst,1.7,1.8 dbi.lisp,1.13,1.14 berkeley-db.xml,1.27,1.28 bdb.c,1.44,1.45 Date: Tue, 27 Jul 2004 15:34:49 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/modules/berkeley-db In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18012/modules/berkeley-db Modified Files: test.tst dbi.lisp berkeley-db.xml bdb.c Log Message: interface to the LOG subsystem Index: bdb.c =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/bdb.c,v retrieving revision 1.44 retrieving revision 1.45 diff -u -d -r1.44 -r1.45 --- bdb.c 26 Jul 2004 17:43:54 -0000 1.44 +++ bdb.c 27 Jul 2004 15:34:47 -0000 1.45 @@ -377,6 +377,7 @@ DEFUN(BDB:DBE-SET-OPTIONS, dbe &key \ :ERRFILE :PASSWORD :ENCRYPT :LOCK_TIMEOUT :TXN_TIMEOUT :TIMEOUT \ :SHM_KEY :TAS_SPINS :TX_TIMESTAMP :TX_MAX :DATA_DIR :TMP_DIR \ + :LG_BSIZE :LG_DIR :LG_MAX :LG_REGIONMAX \ :LK_CONFLICTS :LK_DETECT :LK_MAX_LOCKERS :LK_MAX_LOCKS :LK_MAX_OBJECTS \ :AUTO_COMMIT :CDB_ALLDB :DIRECT_DB :DIRECT_LOG :NOLOCKING \ :NOMMAP :NOPANIC :OVERWRITE :PANIC_ENVIRONMENT :REGION_INIT \ @@ -384,7 +385,7 @@ :VERB_CHKPOINT :VERB_DEADLOCK :VERB_RECOVERY :VERB_REPLICATION \ :VERB_WAITSFOR :VERBOSE) { /* set many options */ - DB_ENV *dbe = object_handle(STACK_(36),`BDB::DBE`,OH_VALID); + DB_ENV *dbe = object_handle(STACK_(40),`BDB::DBE`,OH_VALID); { /* verbose */ object verbosep = popSTACK(); /* :VERBOSE - all */ set_verbose(dbe,verbosep,DB_VERB_WAITSFOR); @@ -453,6 +454,13 @@ } } skipSTACK(1); + DBE_SET(lg_regionmax,u_int32_t,I_to_uint32(check_uint32(STACK_0))); + DBE_SET(lg_max,u_int32_t,I_to_uint32(check_uint32(STACK_0))); + if (!missingp(STACK_0)) { /* LG_DIR */ + with_string_0(physical_namestring(popSTACK()),GLO(pathname_encoding),dirz, + { SYSCALL(dbe->set_lg_dir,(dbe,dirz)); }); + } else skipSTACK(1); + DBE_SET(lg_bsize,u_int32_t,I_to_uint32(check_uint32(STACK_0))); if (!missingp(STACK_0)) { /* TMP_DIR */ with_string_0(physical_namestring(popSTACK()),GLO(pathname_encoding),tmpz, { SYSCALL(dbe->set_tmp_dir,(dbe,tmpz)); }); @@ -521,13 +529,6 @@ if (onoffp) { pushSTACK(`:VERB_CHKPOINT`); count++; } return listof(count); } -/* get the tmp directory - can trigger GC */ -static object dbe_get_tmp_dir (DB_ENV *dbe) { - const char *dir; - SYSCALL(dbe->get_tmp_dir,(dbe,&dir)); - return dir ? asciz_to_string(dir,GLO(pathname_encoding)) : NIL; -} /* get the data directory list can trigger GC */ static object dbe_get_data_dirs (DB_ENV *dbe) { @@ -539,19 +540,6 @@ return listof(ii); } else return NIL; } -/* get the max number of transactions */ -static object dbe_get_tx_max (DB_ENV *dbe) { - u_int32_t tx_max; - SYSCALL(dbe->get_tx_max,(dbe,&tx_max)); - return fixnum(tx_max); -} -/* get the transaction timestamp - can trigger GC */ -static object dbe_get_tx_timestamp (DB_ENV *dbe) { - time_t tx_timestamp; - SYSCALL(dbe->get_tx_timestamp,(dbe,&tx_timestamp)); - return convert_time_to_universal(&tx_timestamp); -} /* get the home directory return T when DBE is not yet open and a list otherwise can trigger GC */ @@ -636,6 +624,15 @@ DEFINE_DBE_GETTER1(get_lk_max_lockers,u_int32_t,UL_to_I(value)) DEFINE_DBE_GETTER1(get_lk_max_locks,u_int32_t,UL_to_I(value)) DEFINE_DBE_GETTER1(get_lk_max_objects,u_int32_t,UL_to_I(value)) +DEFINE_DBE_GETTER1(get_lg_bsize,u_int32_t,UL_to_I(value)) +DEFINE_DBE_GETTER1(get_lg_dir,const char *, + value ? asciz_to_string(value,GLO(pathname_encoding)) : NIL) +DEFINE_DBE_GETTER1(get_lg_max,u_int32_t,UL_to_I(value)) +DEFINE_DBE_GETTER1(get_lg_regionmax,u_int32_t,UL_to_I(value)) +DEFINE_DBE_GETTER1(get_tmp_dir,const char *, + value ? asciz_to_string(value,GLO(pathname_encoding)) : NIL) +DEFINE_DBE_GETTER1(get_tx_max,u_int32_t,UL_to_I(value)) +DEFINE_DBE_GETTER1(get_tx_timestamp,time_t,convert_time_to_universal(&value)) /* get timeout values for locks or transactions in the database environment */ static object dbe_get_timeout (DB_ENV *dbe, u_int32_t which) { @@ -695,6 +692,10 @@ pushSTACK(`:ERRFILE`); pushSTACK(dbe_get_errfile(dbe)); count++; pushSTACK(`:TIMEOUT`); value1 = dbe_get_timeouts(dbe); pushSTACK(value1); count++; + pushSTACK(`:LG_BSIZE`); pushSTACK(dbe_get_lg_bsize(dbe)); count++; + pushSTACK(`:LG_DIR`); pushSTACK(dbe_get_lg_dir(dbe)); count++; + pushSTACK(`:LG_MAX`); pushSTACK(dbe_get_lg_max(dbe)); count++; + pushSTACK(`:LG_REGIONMAX`); pushSTACK(dbe_get_lg_regionmax(dbe)); count++; pushSTACK(`:LK_CONFLICTS`); pushSTACK(dbe_get_lk_conflicts(dbe)); count++; pushSTACK(`:LK_DETECT`); pushSTACK(dbe_get_lk_detect(dbe)); count++; pushSTACK(`:LK_MAX_LOCKERS`);pushSTACK(dbe_get_lk_max_lockers(dbe));count++; @@ -752,6 +753,14 @@ VALUES_IF(dbe_get_flags_num(dbe) & DB_CDB_ALLDB); } else if (eq(what,`:AUTO_COMMIT`)) { VALUES_IF(dbe_get_flags_num(dbe) & DB_AUTO_COMMIT); + } else if (eq(what,`:LG_BSIZE`)) { + VALUES1(dbe_get_lg_bsize(dbe)); + } else if (eq(what,`:LG_DIR`)) { + VALUES1(dbe_get_lg_dir(dbe)); + } else if (eq(what,`:LG_MAX`)) { + VALUES1(dbe_get_lg_max(dbe)); + } else if (eq(what,`:LG_REGIONMAX`)) { + VALUES1(dbe_get_lg_regionmax(dbe)); } else if (eq(what,`:LK_CONFLICTS`)) { VALUES1(dbe_get_lk_conflicts(dbe)); } else if (eq(what,`:LK_DETECT`)) { @@ -1092,7 +1101,7 @@ STAT_SLOT_FAST(hash_stat->hash_dup); STAT_SLOT_FAST(hash_stat->hash_dup_free); funcall(`BDB::MKDBSTAT-HASH`,count); - free(hash_stat); + begin_system_call(); free(hash_stat); end_system_call(); } break; case DB_BTREE: case DB_RECNO: { DB_BTREE_STAT *btree_stat; @@ -1116,7 +1125,7 @@ STAT_SLOT_FAST(btree_stat->bt_dup_pgfree); STAT_SLOT_FAST(btree_stat->bt_over_pgfree); funcall(`BDB::MKDBSTAT-BTREE`,count); - free(btree_stat); + begin_system_call(); free(btree_stat); end_system_call(); } break; case DB_QUEUE: { DB_QUEUE_STAT *queue_stat; @@ -1134,7 +1143,7 @@ STAT_SLOT(queue_stat->qs_first_recno); STAT_SLOT(queue_stat->qs_cur_recno); funcall(`BDB::MKDBSTAT-QUEUE`,count); - free(queue_stat); + begin_system_call(); free(queue_stat); end_system_call(); } break; default: NOTREACHED; #undef STAT_SLOT @@ -1824,7 +1833,7 @@ VALUES1(uint32_to_I(id)); } DEFUN(BDB:LOCK-ID-FREE, dbe id) -{ /* Release a locker ID */ +{ /* Release a locker ID */ u_int32_t id = I_to_uint32(check_uint32(popSTACK())); DB_ENV *dbe = object_handle(popSTACK(),`BDB::DBE`,OH_VALID); SYSCALL(dbe->lock_id_free,(dbe,id)); @@ -1891,7 +1900,171 @@ pushSTACK(uint32_to_I(ls->st_region_wait)); pushSTACK(uint32_to_I(ls->st_region_nowait)); funcall(`BDB::MKLOCKSTAT`,24); - free(ls); + begin_system_call(); free(ls); end_system_call(); +} + +/* ===== logs ===== */ + +DEFFLAGSET(log_archive_flags,DB_ARCH_ABS DB_ARCH_DATA DB_ARCH_LOG \ + DB_ARCH_REMOVE) +DEFUN(BDB:LOG-ARCHIVE, dbe &key :ARCH_ABS :ARCH_DATA :ARCH_LOG :ARCH_REMOVE) +{ /* return a list of log or database filenames. */ + u_int32_t flags = log_archive_flags(); + DB_ENV *dbe = object_handle(popSTACK(),`BDB::DBE`,OH_VALID); + char **list = NULL; + SYSCALL(dbe->log_archive,(dbe,&list,flags)); + if (list) { + int count = 0; + for (; *list; list++, count++) + pushSTACK(asciz_to_string(*list,GLO(pathname_encoding))); + begin_system_call(); free(list); end_system_call(); + VALUES1(listof(count)); + } else VALUES0; +} + +/* extract the DB_LSN data from the object + can trigger GC */ +static void check_lsn (gcv_object_t *obj_, DB_LSN *lsn) { + *obj_ = check_classname(*obj_,`BDB::LSN`); + lsn->file = I_to_uint32(TheStructure(*obj_)->recdata[1]); + lsn->offset = I_to_uint32(TheStructure(*obj_)->recdata[2]); +} + +DEFUN(BDB:LOG-FILE, dbe lsn) +{ /* return the name of the file containing the record named by lsn. */ + DB_LSN lsn; + DB_ENV *dbe = object_handle(STACK_1,`BDB::DBE`,OH_VALID); + char path[MAX_PATH]; + check_lsn(&STACK_0,&lsn); + SYSCALL(dbe->log_file,(dbe,&lsn,path,MAX_PATH)); + VALUES1(asciz_to_string(path,GLO(pathname_encoding))); + skipSTACK(2); +} + +DEFUN(BDB:LOG-FLUSH, dbe lsn) +{ /* flush log records to disk */ + DB_LSN lsn; + DB_ENV *dbe = object_handle(STACK_1,`BDB::DBE`,OH_VALID); + check_lsn(&STACK_0,&lsn); + SYSCALL(dbe->log_flush,(dbe,&lsn)); + VALUES0; + skipSTACK(2); +} + +/* convert C srtuct DB_LSN to Lisp structure LSN + can trigger GC */ +static object make_lsn (DB_LSN *lsn) { + pushSTACK(uint32_to_I(lsn->file)); + pushSTACK(uint32_to_I(lsn->offset)); + funcall(`BDB::MKLSN`,2); + return value1; +} + +DEFFLAGSET(log_put_flags, DB_FLUSH) +DEFUN(BDB:LOG-PUT, dbe data &key FLUSH) +{ /* write a log record */ + u_int32_t flags = log_put_flags(); + DB_LSN lsn; + DB_ENV *dbe = object_handle(STACK_1,`BDB::DBE`,OH_VALID); + DBT data; + fill_dbt(STACK_0,&data,0); skipSTACK(2); + SYSCALL1(dbe->log_put,(dbe,&lsn,&data,flags),{free(data.data);}); + make_lsn(&lsn); +} + +DEFUN(BDB:LOG-STAT, dbe &key :STAT_CLEAR) +{ /* logging subsystem statistics */ + u_int32_t flags = stat_flags(); + DB_ENV *dbe = object_handle(popSTACK(),`BDB::DBE`,OH_VALID); + DB_LOG_STAT *stat; + SYSCALL(dbe->log_stat,(dbe,&stat,flags)); + pushSTACK(uint32_to_I(stat->st_magic)); + pushSTACK(uint32_to_I(stat->st_version)); + pushSTACK(uint32_to_I(stat->st_mode)); + pushSTACK(uint32_to_I(stat->st_lg_bsize)); + pushSTACK(uint32_to_I(stat->st_lg_size)); + pushSTACK(uint32_to_I(stat->st_w_mbytes)); + pushSTACK(uint32_to_I(stat->st_w_bytes)); + pushSTACK(uint32_to_I(stat->st_wc_mbytes)); + pushSTACK(uint32_to_I(stat->st_wc_bytes)); + pushSTACK(uint32_to_I(stat->st_wcount)); + pushSTACK(uint32_to_I(stat->st_wcount_fill)); + pushSTACK(uint32_to_I(stat->st_scount)); + pushSTACK(uint32_to_I(stat->st_cur_file)); + pushSTACK(uint32_to_I(stat->st_cur_offset)); + pushSTACK(uint32_to_I(stat->st_disk_file)); + pushSTACK(uint32_to_I(stat->st_disk_offset)); + pushSTACK(uint32_to_I(stat->st_maxcommitperflush)); + pushSTACK(uint32_to_I(stat->st_mincommitperflush)); + pushSTACK(uint32_to_I(stat->st_regsize)); + pushSTACK(uint32_to_I(stat->st_region_wait)); + pushSTACK(uint32_to_I(stat->st_region_nowait)); + funcall(`BDB::MKLOGSTAT`,21); + begin_system_call(); free(stat); end_system_call(); +} + +DEFUN(BDB:LOG-CURSOR, dbe) +{ /* create a log cursor. */ + DB_ENV *dbe = object_handle(STACK_0,`BDB::DBE`,OH_VALID); + DB_LOGC *cursor; + SYSCALL(dbe->log_cursor,(dbe,&cursor,0)); + wrap_finalize(cursor,STACK_0,`BDB::MKLOGC`,``BDB::LOGC-CLOSE``); +} + +DEFUN(BDB:LOGC-CLOSE, logc) +{ /* discard the log cursor. */ + DB_LOGC *logc = object_handle(STACK_0,`BDB::LOGC`,OH_INVALIDATE); + if (logc) { + funcall(`BDB::KILL-HANDLE`,1); + SYSCALL(logc->close,(logc,0)); + VALUES1(T); + } else { skipSTACK(1); VALUES1(NIL); } +} + +DEFCHECKER(logc_get_action, DB_CURRENT DB_FIRST DB_LAST DB_NEXT DB_PREV) +DEFUN(BDB:LOGC-GET, logc action &key :TYPE :ERROR) +{ /* return records from the log. */ + int no_error = nullp(popSTACK()); + dbt_o_t out_type = check_dbt_type(popSTACK()); + DB_LOGC *logc = object_handle(STACK_1,`BDB::LOGC`,OH_VALID); + DB_LSN lsn; + u_int32_t action; + DBT data; + int status; + if (symbolp(STACK_0) || fixnump(STACK_0)) { + action = logc_get_action(STACK_0); + } else { + action = DB_SET; + check_lsn(&STACK_0,&lsn); + } + init_dbt(&data,DB_DBT_MALLOC); + begin_system_call(); + status = logc->get(logc,&lsn,&data,action); + end_system_call(); + if (status) { + if (no_error) { + switch (status) { + case DB_NOTFOUND: VALUES1(`:NOTFOUND`); error_message_reset(); return; + } + } + error_bdb(status,"dbc->c_get"); + } + if (action == DB_SET) { /* STACK_0 is the LSN */ + } else STACK_0 = make_lsn(&lsn); + VALUES2(dbt_to_object(&data,out_type),popSTACK()); + free_dbt(&data); + skipSTACK(1); +} + +DEFUN(BDB:LOG-COMPARE, lsn1 lsn2) +{ /* Compare two Log Sequence Numbers */ + DB_LSN lsn1, lsn2; + int value; + check_lsn(&STACK_1,&lsn1); + check_lsn(&STACK_0,&lsn2); + begin_system_call(); value = log_compare(&lsn1,&lsn2); end_system_call(); + VALUES1(fixnum(value)); + skipSTACK(2); } /* ===== transactions ===== */ @@ -2040,38 +2213,34 @@ DB_ENV *dbe = object_handle(popSTACK(),`BDB::DBE`,OH_VALID); DB_TXN_STAT *stat; SYSCALL(dbe->txn_stat,(dbe,&stat,flags)); - pushSTACK(UL_to_I(stat->st_last_ckp.file)); - pushSTACK(UL_to_I(stat->st_last_ckp.offset)); - funcall(`BDB::MKLSM`,2); pushSTACK(value1); + pushSTACK(make_lsn(&(stat->st_last_ckp))); pushSTACK(convert_time_to_universal(&(stat->st_time_ckp))); - pushSTACK(UL_to_I(stat->st_last_txnid)); - pushSTACK(UL_to_I(stat->st_maxtxns)); - pushSTACK(UL_to_I(stat->st_nactive)); - pushSTACK(UL_to_I(stat->st_maxnactive)); - pushSTACK(UL_to_I(stat->st_nbegins)); - pushSTACK(UL_to_I(stat->st_naborts)); - pushSTACK(UL_to_I(stat->st_ncommits)); - pushSTACK(UL_to_I(stat->st_nrestores)); - pushSTACK(UL_to_I(stat->st_regsize)); - pushSTACK(UL_to_I(stat->st_region_wait)); - pushSTACK(UL_to_I(stat->st_region_nowait)); + pushSTACK(uint32_to_I(stat->st_last_txnid)); + pushSTACK(uint32_to_I(stat->st_maxtxns)); + pushSTACK(uint32_to_I(stat->st_nactive)); + pushSTACK(uint32_to_I(stat->st_maxnactive)); + pushSTACK(uint32_to_I(stat->st_nbegins)); + pushSTACK(uint32_to_I(stat->st_naborts)); + pushSTACK(uint32_to_I(stat->st_ncommits)); + pushSTACK(uint32_to_I(stat->st_nrestores)); + pushSTACK(uint32_to_I(stat->st_regsize)); + pushSTACK(uint32_to_I(stat->st_region_wait)); + pushSTACK(uint32_to_I(stat->st_region_nowait)); { /* txnarray */ int ii, size = stat->st_nactive; DB_TXN_ACTIVE *txn_active = stat->st_txnarray; for (ii=0; ii<size; ii++) { - pushSTACK(UL_to_I(txn_active->txnid)); - pushSTACK(UL_to_I(txn_active->parentid)); - pushSTACK(UL_to_I(txn_active->lsn.file)); - pushSTACK(UL_to_I(txn_active->lsn.offset)); - funcall(`BDB::MKLSM`,2); pushSTACK(value1); - pushSTACK(UL_to_I(txn_active->xa_status)); + pushSTACK(uint32_to_I(txn_active->txnid)); + pushSTACK(uint32_to_I(txn_active->parentid)); + pushSTACK(make_lsn(&(txn_active->lsn))); + pushSTACK(uint32_to_I(txn_active->xa_status)); pushSTACK(gid_to_vector(txn_active->xid)); funcall(`BDB::MKTXNACTIVE`,5); pushSTACK(value1); } value1 = vectorof(size); pushSTACK(value1); } funcall(`BDB::MKTXNSTAT`,14); - free(stat); + begin_system_call(); free(stat); end_system_call(); } void module__bdb__init_function_2 (module_t* module) Index: berkeley-db.xml =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/berkeley-db.xml,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- berkeley-db.xml 26 Jul 2004 17:21:22 -0000 1.27 +++ berkeley-db.xml 27 Jul 2004 15:34:47 -0000 1.28 @@ -72,12 +72,12 @@ <variablelist> <varlistentry><term><literal role="sexp">(BDB:DBE-SET-OPTIONS dbe &key-amp; ERRFILE PASSWORD ENCRYPT LOCK_TIMEOUT TXN_TIMEOUT SHM_KEY - TAS_SPINS TX_TIMESTAMP TX_MAX DATA_DIR TMP_DIR LK_CONFLICTS LK_DETECT - LK_MAX_LOCKERS LK_MAX_LOCKS LK_MAX_OBJECTS AUTO_COMMIT CDB_ALLDB - DIRECT_DB DIRECT_LOG NOLOCKING NOMMAP NOPANIC OVERWRITE - PANIC_ENVIRONMENT REGION_INIT TXN_NOSYNC TXN_WRITE_NOSYNC YIELDCPU - VERB_CHKPOINT VERB_DEADLOCK VERB_RECOVERY VERB_REPLICATION - VERB_WAITSFOR VERBOSE)</literal></term> + TAS_SPINS TX_TIMESTAMP TX_MAX DATA_DIR TMP_DIR LG_BSIZE LG_DIR LG_MAX + LG_REGIONMAX LK_CONFLICTS LK_DETECT LK_MAX_LOCKERS LK_MAX_LOCKS + LK_MAX_OBJECTS AUTO_COMMIT CDB_ALLDB DIRECT_DB DIRECT_LOG NOLOCKING + NOMMAP NOPANIC OVERWRITE PANIC_ENVIRONMENT REGION_INIT TXN_NOSYNC + TXN_WRITE_NOSYNC YIELDCPU VERB_CHKPOINT VERB_DEADLOCK VERB_RECOVERY + VERB_REPLICATION VERB_WAITSFOR VERBOSE)</literal></term> <listitem><para>Set some environment options using <simplelist columns="4"> <member>&DBE_set_flags;</member> <member>&DBE_set_verbose;</member> @@ -90,6 +90,10 @@ <member>&DBE_set_timeout;</member> <member>&DBE_set_encrypt;</member> <member>&DBE_set_errfile;</member> + <member>&DBE_set_lg_bsize;</member> + <member>&DBE_set_lg_dir;</member> + <member>&DBE_set_lg_max;</member> + <member>&DBE_set_lg_regionmax;</member> <member>&DBE_set_lk_conflicts;</member> <member>&DBE_set_lk_detect;</member> <member>&DBE_set_lk_max_lockers;</member> @@ -140,6 +144,18 @@ <listitem><simpara>a &boolean-t; indicator of whether this option is set or not (&DBE_get_verbose; and &DBE_get_flags;). </simpara></listitem></varlistentry> + <varlistentry><term><constant>:LG_BSIZE</constant></term> + <listitem><simpara>log buffer size + (&DBE_get_lg_bsize;)</simpara></listitem></varlistentry> + <varlistentry><term><constant>:LG_DIR</constant></term> + <listitem><simpara>logging directory + (&DBE_get_lg_dir;)</simpara></listitem></varlistentry> + <varlistentry><term><constant>:LG_MAX</constant></term> + <listitem><simpara>log file size + (&DBE_get_lg_max;)</simpara></listitem></varlistentry> + <varlistentry><term><constant>:LG_REGIONMAX</constant></term> + <listitem><simpara>logging region size + (&DBE_get_lg_regionmax;)</simpara></listitem></varlistentry> <varlistentry><term><constant>:LK_CONFLICTS</constant></term> <listitem><simpara>lock conflicts matrix (&DBE_get_lk_conflicts;)</simpara></listitem></varlistentry> @@ -418,7 +434,7 @@ and then use the database handle to open a database of different type (e.g., <constant>:QUEUE</constant>).</para></warning> </listitem></varlistentry> -</variablelist> +</variablelist></section> <section id="bdb-cursor"><title>Database Cursor Operations</title> <!-- @@ -550,11 +566,27 @@ DB_ENV->log_stat Return log subsystem statistics --> <variablelist> -<varlistentry><term><literal role="sexp">()</literal></term> - <listitem><simpara></simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:LOG-ARCHIVE dbe + &key-amp; :ARCH_ABS :ARCH_DATA :ARCH_LOG :ARCH_REMOVE)</literal></term> + <listitem><simpara>Return a list of log or database filenames + (&DBE_log_archive;).</simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:LOG-FILE dbe lsn)</literal></term> + <listitem><simpara>Return the name of the file containing the record + named by <replaceable>lsn</replaceable> (&DBE_log_file;). +</simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:LOG-FLUSH dbe + lsn)</literal></term> + <listitem><simpara>Flush log records to disk (&DBE_log_flush;). +</simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:LOG-PUT dbe data + &key-amp; :FLUSH)</literal></term> + <listitem><simpara>Write a log record (&DBE_log_put;). +</simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:LOG-STAT dbe + &key-amp; STAT_CLEAR)</literal></term> + <listitem><simpara>Logging subsystem statistics (&DBE_log_stat;). +</simpara></listitem></varlistentry> </variablelist> -</section> - <section id="bdb-log-cursor"><title>Log Cursor Operations</title> <!-- @@ -563,22 +595,47 @@ DB_LOGC->get Retrieve a log record --> <variablelist> -<varlistentry><term><literal role="sexp">()</literal></term> - <listitem><simpara></simpara></listitem></varlistentry> -</variablelist> -</section> +<varlistentry><term><literal role="sexp">(BDB:LOG-CURSOR dbe)</literal></term> + <listitem><simpara>Create a log cursor handle + (&DBE_log_cursor;).</simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:LOGC-CLOSE logc)</literal></term> + <listitem><simpara>Close a log cursor handle + (&LOGC_close;).</simpara></listitem></varlistentry> +<varlistentry><term><literal role="sexp">(BDB:LOGC-GET logc action + &key-amp; TYPE ERROR)</literal></term> + <listitem><para>Retrieve a log record (&LOGC_get;). + If &error-k; is &nil; and the record is not found, no &err-sig;, + <constant>:NOTFOUND</constant> is returned instead. + <variablelist><title>Valid <replaceable>action</replaceable>s</title> + <varlistentry><term><constant>:DB_CURRENT</constant></term> + <term><constant>:DB_FIRST</constant></term> + <term><constant>:DB_LAST</constant></term> + <term><constant>:DB_NEXT</constant></term> + <term><constant>:DB_PREV</constant></term> + <listitem><simpara>Retrieve the appropriate record. + </simpara></listitem></varlistentry> + <varlistentry><term><type>DB:LSN</type></term> + <listitem><simpara>Retrieve the specified record, as + with <constant>DB_SET</constant>. + </simpara></listitem></varlistentry></variablelist> + Returns two values: the datum of type specified by the &type-k; + argument and the <type>DB:LSN</type> value of the record retrieved + (when <replaceable>action</replaceable> is a <type>DB:LSN</type>, it + is returned unchanged). +</para></listitem></varlistentry> +</variablelist></section> <section id="bdb-log-seq"><title>Log Sequence Numbers</title> -<para>Use &equalp; to compare <type>BDB::LSN</type> objects.</para> +<para>Use &equalp; to check similarity of <type>BDB:LSN</type> objects.</para> -<!-- log_compare Compare two Log Sequence Numbers <variablelist> -<varlistentry><term><literal role="sexp">()</literal></term> - <listitem><simpara></simpara></listitem></varlistentry> -</variablelist> --> - +<varlistentry><term><literal role="sexp">(BDB:LOG-COMPARE + lsn1 lsn2)</literal></term> + <listitem><simpara>Compare two Log Sequence Numbers (&db_log_compare;). +</simpara></listitem></varlistentry> +</variablelist></section> </section> <section id="bdb-mem-pool"><title>Memory Pool Subsystem</title> @@ -684,19 +741,4 @@ </variablelist> </section> - -<!-- -<section id="bdb-"><title></title> - -<variablelist> -<varlistentry><term><literal role="sexp">()</literal></term> - <listitem><simpara></simpara></listitem></varlistentry> -</variablelist> -</section> - ---> - - - - </section> Index: test.tst =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/test.tst,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- test.tst 26 Jul 2004 17:43:54 -0000 1.7 +++ test.tst 27 Jul 2004 15:34:45 -0000 1.8 @@ -32,6 +32,13 @@ (bdb:db-get-options db)))) nil) show-db +(defun show-dbe (dbe) + (let ((*print-pretty* t)) + (print (list dbe :archive (bdb:log-archive dbe) + (bdb:txn-stat dbe) (bdb:lock-stat dbe) (bdb:log-stat dbe) + (bdb:dbe-get-options dbe)))) + nil) +show-dbe (defun finish-file (file) (when (probe-file file) (with-open-file (st file :direction :input) @@ -66,11 +73,11 @@ :data_dir "bdb-data/") NIL -(let ((*print-pretty* t)) (print (bdb:dbe-get-options *dbe*)) nil) NIL - -(bdb:dbe-open *dbe* :home "bdb-home/" :create t :init_mpool t :init_lock t) NIL +(bdb:dbe-open *dbe* :home "bdb-home/" :create t + :init_mpool t :init_txn t :init_lock t :init_log t) +NIL -(let ((*print-pretty* t)) (print (bdb:dbe-get-options *dbe*)) nil) NIL +(show-dbe *dbe*) NIL (defvar *db* (let ((*print-pretty* t)) (print (bdb:db-create *dbe*)))) *db* @@ -190,11 +197,11 @@ (equalp arr (bdb:dbe-get-options *dbe* :lk_conflicts))) T -(bdb:dbe-open *dbe* :home "bdb-home/" :create t :init_mpool t :init_txn t - :init_lock t) +(bdb:dbe-open *dbe* :home "bdb-home/" :create t + :init_mpool t :init_txn t :init_lock t :init_log t) NIL -(let ((*print-pretty* t)) (print (bdb:dbe-get-options *dbe*)) nil) NIL +(show-dbe *dbe*) NIL (let ((*print-pretty* t)) (setq *db* (print (bdb:db-create *dbe*))) nil) NIL @@ -269,7 +276,8 @@ (bdb:lock-put *dbe* (print *lock*)) NIL (bdb:lock-id-free *dbe* *locker*) NIL -(close *dbe*) T +(show-dbe *dbe*) NIL +(close *dbe*) T (finish-file "bdb-errors") T ; no errors, bdb-errors does not exist (rmrf "bdb-home/") T Index: dbi.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/dbi.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- dbi.lisp 23 Jul 2004 22:17:46 -0000 1.13 +++ dbi.lisp 27 Jul 2004 15:34:47 -0000 1.14 @@ -7,7 +7,7 @@ (:nicknames "BERKELEY-DB" "BERKDB") (:export "DB-VERSION" "BDB-HANDLE" "BDB-HANDLE-PARENTS" "BDB-HANDLE-DEPENDENTS" - "DBE" "DB" "TXN" "DBC" "LOGC" "MPOOLFILE" "DBLOCK" + "DBE" "DB" "TXN" "DBC" "LOGC" "MPOOLFILE" "DBLOCK" "LSN" "DBE-CREATE" "DBE-CLOSE" "DBE-DBREMOVE" "DBE-DBRENAME" "DBE-OPEN" "DBE-REMOVE" "DBE-SET-OPTIONS" "DBE-GET-OPTIONS" "DB-CREATE" "DB-CLOSE" "DB-DEL" "DB-FD" "DB-GET" "DB-STAT" @@ -18,6 +18,8 @@ "DBC-DUP" "DBC-GET" "DBC-PUT" "LOCK-DETECT" "LOCK-GET" "LOCK-ID" "LOCK-ID-FREE" "LOCK-PUT" "LOCK-CLOSE" "LOCK-STAT" + "LOG-ARCHIVE" "LOG-FILE" "LOG-FLUSH" "LOG-PUT" "LOG-STAT" + "LOG-COMPARE" "LOG-CURSOR" "LOGC-CLOSE" "LOGC-GET" "TXN-BEGIN" "TXN-ABORT" "TXN-COMMIT" "TXN-DISCARD" "TXN-ID" "TXN-CHECKPOINT" "TXN-PREPARE" "TXN-RECOVER" "TXN-SET-TIMEOUT" "TXN-STAT" @@ -132,65 +134,118 @@ (defstruct (db-lock-stat (:constructor mklockstat - (st_id st_cur_maxid st_nmodes st_maxlocks - st_maxlockers st_maxobjects st_nlocks st_maxnlocks - st_nlockers st_maxnlockers st_nobjects st_maxnobjects - st_nrequests st_nreleases st_nnowaits st_nconflicts - st_ndeadlocks st_locktimeout st_nlocktimeouts - st_txntimeout st_ntxntimeouts st_regsize - st_region_wait st_region_nowait))) + (id cur_maxid nmodes maxlocks + maxlockers maxobjects nlocks maxnlocks + nlockers maxnlockers nobjects maxnobjects + nrequests nreleases nnowaits nconflicts + ndeadlocks locktimeout nlocktimeouts + txntimeout ntxntimeouts regsize + region_wait region_nowait))) ;; The last allocated locker ID. - (st_id 0 :type (unsigned-byte 32) :read-only t) + (id 0 :type (unsigned-byte 32) :read-only t) ;; The current maximum unused locker ID. - (st_cur_maxid 0 :type (unsigned-byte 32) :read-only t) + (cur_maxid 0 :type (unsigned-byte 32) :read-only t) ;; The number of lock modes. - (st_nmodes 0 :type (unsigned-byte 32) :read-only t) + (nmodes 0 :type (unsigned-byte 32) :read-only t) ;; The maximum number of locks possible. - (st_maxlocks 0 :type (unsigned-byte 32) :read-only t) + (maxlocks 0 :type (unsigned-byte 32) :read-only t) ;; The maximum number of lockers possible. - (st_maxlockers 0 :type (unsigned-byte 32) :read-only t) + (maxlockers 0 :type (unsigned-byte 32) :read-only t) ;; The maximum number of lock objects possible. - (st_maxobjects 0 :type (unsigned-byte 32) :read-only t) + (maxobjects 0 :type (unsigned-byte 32) :read-only t) ;; The number of current locks. - (st_nlocks 0 :type (unsigned-byte 32) :read-only t) + (nlocks 0 :type (unsigned-byte 32) :read-only t) ;; The maximum number of locks at any one time. - (st_maxnlocks 0 :type (unsigned-byte 32) :read-only t) + (maxnlocks 0 :type (unsigned-byte 32) :read-only t) ;; The number of current lockers. - (st_nlockers 0 :type (unsigned-byte 32) :read-only t) + (nlockers 0 :type (unsigned-byte 32) :read-only t) ;; The maximum number of lockers at any one time. - (st_maxnlockers 0 :type (unsigned-byte 32) :read-only t) + (maxnlockers 0 :type (unsigned-byte 32) :read-only t) ;; The number of current lock objects. - (st_nobjects 0 :type (unsigned-byte 32) :read-only t) + (nobjects 0 :type (unsigned-byte 32) :read-only t) ;; The maximum number of lock objects at any one time. - (st_maxnobjects 0 :type (unsigned-byte 32) :read-only t) + (maxnobjects 0 :type (unsigned-byte 32) :read-only t) ;; The total number of locks requested. - (st_nrequests 0 :type (unsigned-byte 32) :read-only t) + (nrequests 0 :type (unsigned-byte 32) :read-only t) ;; The total number of locks released. - (st_nreleases 0 :type (unsigned-byte 32) :read-only t) + (nreleases 0 :type (unsigned-byte 32) :read-only t) ;; The total number of lock requests failing because DB_LOCK_NOWAIT was set. - (st_nnowaits 0 :type (unsigned-byte 32) :read-only t) + (nnowaits 0 :type (unsigned-byte 32) :read-only t) ;; The total number of locks not immediately available due to conflicts. - (st_nconflicts 0 :type (unsigned-byte 32) :read-only t) + (nconflicts 0 :type (unsigned-byte 32) :read-only t) ;; The number of deadlocks. - (st_ndeadlocks 0 :type (unsigned-byte 32) :read-only t) + (ndeadlocks 0 :type (unsigned-byte 32) :read-only t) ;; Lock timeout value. - (st_locktimeout 0 :type (unsigned-byte 32) :read-only t) + (locktimeout 0 :type (unsigned-byte 32) :read-only t) ;; The number of lock requests that have timed out. - (st_nlocktimeouts 0 :type (unsigned-byte 32) :read-only t) + (nlocktimeouts 0 :type (unsigned-byte 32) :read-only t) ;; Transaction timeout value. - (st_txntimeout 0 :type (unsigned-byte 32) :read-only t) + (txntimeout 0 :type (unsigned-byte 32) :read-only t) ;; The number of transactions that have timed out. This value is also - ;; a component of st_ndeadlocks, the total number of deadlocks detected. - (st_ntxntimeouts 0 :type (unsigned-byte 32) :read-only t) + ;; a component of ndeadlocks, the total number of deadlocks detected. + (ntxntimeouts 0 :type (unsigned-byte 32) :read-only t) ;; The size of the lock region. - (st_regsize 0 :type (unsigned-byte 32) :read-only t) + (regsize 0 :type (unsigned-byte 32) :read-only t) ;; The number of times that a thread of control was forced to wait ;; before obtaining the region lock. - (st_region_wait 0 :type (unsigned-byte 32) :read-only t) + (region_wait 0 :type (unsigned-byte 32) :read-only t) ;; The number of times that a thread of control was able to obtain the ;; region lock without waiting. - (st_region_nowait 0 :type (unsigned-byte 32) :read-only t)) + (region_nowait 0 :type (unsigned-byte 32) :read-only t)) +(defstruct (db-log-stat (:constructor + mklogstat + (magic version mode lg_bsize lg_size w_mbytes w_bytes + wc_mbytes wc_bytes wcount wcount_fill scount cur_file + cur_offset disk_file disk_offset maxcommitperflush + mincommitperflush regsize region_wait region_nowait))) + ;; The magic number that identifies a file as a log file. + (magic 0 :type (unsigned-byte 32) :read-only t) + ;; The version of the log file type. + (version 0 :type (unsigned-byte 32) :read-only t) + ;; The mode of any created log files. + (mode 0 :type int :read-only t) + ;; The in-memory log record cache size. + (lg_bsize 0 :type (unsigned-byte 32) :read-only t) + ;; The current log file size. + (lg_size 0 :type (unsigned-byte 32) :read-only t) + ;; The number of megabytes written to this log. + (w_mbytes 0 :type (unsigned-byte 32) :read-only t) + ;; The number of bytes over and above w_mbytes written to this log. + (w_bytes 0 :type (unsigned-byte 32) :read-only t) + ;; The number of megabytes written to this log since the last checkpoint. + (wc_mbytes 0 :type (unsigned-byte 32) :read-only t) + ;; The number of bytes over and above wc_mbytes written to this log + ;; since the last checkpoint. + (wc_bytes 0 :type (unsigned-byte 32) :read-only t) + ;; The number of times the log has been written to disk. + (wcount 0 :type (unsigned-byte 32) :read-only t) + ;; The number of times the log has been written to disk because the + ;; in-memory log record cache filled up. + (wcount_fill 0 :type (unsigned-byte 32) :read-only t) + ;; The number of times the log has been flushed to disk. + (scount 0 :type (unsigned-byte 32) :read-only t) + ;; The current log file number. + (cur_file 0 :type (unsigned-byte 32) :read-only t) + ;; The byte offset in the current log file. + (cur_offset 0 :type (unsigned-byte 32) :read-only t) + ;; The log file number of the last record known to be on disk. + (disk_file 0 :type (unsigned-byte 32) :read-only t) + ;; The byte offset of the last record known to be on disk. + (disk_offset 0 :type (unsigned-byte 32) :read-only t) + ... [truncated message content] |