BerkeleyDB

Check-in [2b1a1fe4a3]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Foreign key management improvements: - ffcall is no longer needed. - secondary indices can be queried for their primary database and key mapper. - the correct serializer and deserializer are used even if the primary and secondary databases have different serialization support configured. - database-fold can return primary keys when running over a secondary index, if requested.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v2.2.0
Files: files | file ages | folders
SHA1:2b1a1fe4a35604c3077854daf6ec9e7cbf009830
User & Date: murphy 2013-06-06 23:48:46
Context
2013-06-06
23:50
Updated release information check-in: 973bf6b65d user: murphy tags: trunk
23:48
Foreign key management improvements: - ffcall is no longer needed. - secondary indices can be queried for their primary database and key mapper. - the correct serializer and deserializer are used even if the primary and secondary databases have different serialization support configured. - database-fold can return pr... check-in: 2b1a1fe4a3 user: murphy tags: trunk, v2.2.0
2013-06-02
01:41
Updated release information check-in: 806f312f01 user: murphy tags: trunk, v2.1.0
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to berkeley-db.scm.

34
35
36
37
38
39
40

41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
...
168
169
170
171
172
173
174
175

176
177
178
179
180
181
182
...
396
397
398
399
400
401
402





















403
404
405
406
407
408
409
...
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563






564
565
566
567
568
569
570
...
590
591
592
593
594
595
596





























597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
...
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
...
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704


705
706
707





708
709
710








711
712
713
714







715
716
717
718
719
720
721
722
723
724

725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774

775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
...
841
842
843
844
845
846
847
848

849
850
851
852
853
854
855
856
857
858
859
860

861
862
863
864
865
866
867
...
873
874
875
876
877
878
879
880

881
882
883
884
885
886
887
888
889
...
934
935
936
937
938
939
940



941
942
943
944
945
946

947

948
949
950
951
952
953
954
...
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
...
979
980
981
982
983
984
985
986
987
988
989
990
991





992

993
994
995
996
997
998
999
1000

1001

1002

1003
1004
1005
1006
1007
1008
1009
   with-transaction
   copy-database rename-database delete-database
   database?
   open-database close-database
   database-type
   database-serializer database-deserializer
   database-associate

   database-ref database-set! database-exists? database-delete!
   database-fold database-walk)
  (import
   scheme chicken foreign
   srfi-1 srfi-4 srfi-18 srfi-69
   lolevel data-structures ports extras)
  (foreign-declare
   "#include <db.h>"
   "#include <callback.h>")

(define-syntax define-foreign-tagged-type
  (syntax-rules ()
    ((define-foreign-tagged-type (id nonnull-id target-type)
       predicate tag)
     (begin
       (define tag
................................................................................
	    (lambda (exn)
	      (eqv? (condition-code exn) not-found))))
    access-error?))

(define (blob/string-size v)
  (cond
   ((blob? v) (blob-size v))
   ((string? v) (string-length v))))


;; Database environments

(define-foreign-tagged-type (database-environment
			     nonnull-database-environment
			     "DB_ENV")
  database-environment?
................................................................................
    (current-database-environment) (current-transaction)
    file database flags))))

(define-foreign-tagged-type (database nonnull-database "DB")
  database?
  tag:database)






















(cond-expand
 (enable-heap
  (define-foreign-enum-type (database-type int)
    database-type->integer integer->database-type
    (b-tree "DB_BTREE")
    (hash-table "DB_HASH")
    (heap "DB_HEAP")
................................................................................
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db)
		   (nonnull-c-string password) (int flags))
	      "C_return(db->set_encrypt(db, password, flags));")
	     db password encryption-flags)))
	 (when serialize+deserialize
	   ((foreign-lambda*
	     void ((nonnull-database db) (scheme-object info))
	     "if (!db->app_private) db->app_private = CHICKEN_new_gc_root();"
	     "CHICKEN_gc_root_set(db->app_private, info);")
	    db serialize+deserialize))
	 (check-error
	  'open-database
	  ((foreign-lambda*
	    int ((nonnull-database db) (transaction txn)
		 (nonnull-c-string file) (c-string database)
		 (database-type type) (int flags) (int mode))
	    "C_return(db->open(db, txn, file, database, type, flags, mode));")
	   db (current-transaction) file database type flags mode)))






     (exn (exn db)
      (close-database db)
      (abort exn)))
    db)))

(define (database-type db)
  (let-location ((type database-type #f))
................................................................................
       "if (db->app_private) {"
       "  CHICKEN_delete_gc_root(db->app_private);"
       "  db->app_private = NULL;"
       "}"
       "C_return(db->close(db, flags));")
      db flags))))






























(define-foreign-enum-argconvert (secondary-key-flags int)
  (#:create "DB_CREATE")
  (#:immutable "DB_IMMUTABLE_KEY"))

(define-foreign-enum-argconvert (foreign-key-flags int)
  (#:abort "DB_FOREIGN_ABORT")
  (#:cascade "DB_FOREIGN_CASCADE"))

(define-values (database-serializer database-deserializer)
  (letrec ((serializer+deserializer
	    (foreign-lambda*
	     scheme-object ((nonnull-database db))
	     "C_return(db->app_private ? "
	     "CHICKEN_gc_root_ref(db->app_private) : "
	     "C_SCHEME_FALSE);"))
	   (serializer
	    (lambda (db)
	      (cond
	       ((serializer+deserializer db) => car)
	       (else #f))))
	   (deserializer
	    (lambda (db)
	      (cond
	       ((serializer+deserializer db) => cdr)
	       (else #f)))))
    (values serializer deserializer)))

(define (make-key-data db key)
  (case (database-type db)
    ((heap)
     (if key
	 (ensure blob? key)
	 (make-blob
	  (cond-expand
................................................................................
       (move-memory! ptr data size)
       (u32vector-ref (blob->u32vector/shared data) 0)))
    (else
     (import-value-data db ptr size))))

(define (make-value-data db value)
  (cond
   ((database-serializer db)
    => (lambda (serialize)
	 (call-with-output-string (cut serialize value <>))))
   (else
    value)))

(define (import-value-data db ptr size)
  (let ((data (make-string size)))
................................................................................
    (move-memory! ptr data size)
    (cond
     ((database-deserializer db)
      => (cut call-with-input-string data <>))
     (else
      data))))

(define-external (secondary_key (c-pointer root) (c-pointer args)) void
  ((foreign-lambda*
    void ((nonnull-c-pointer args) (bool ok))
    "va_return_int((va_alist)args, ok ? 0 : DB_DONOTINDEX);")
   args
   (handle-exceptions
    exn (begin
	  (print-error-message exn (current-error-port) "Callback Error")
	  #f)
    (let* ((proc
	    ((foreign-lambda
	      scheme-object "CHICKEN_gc_root_ref"
	      nonnull-c-pointer)
	     root)))
      (let-location ((db database #f)
		     (key-ptr c-pointer #f)
		     (key-size unsigned-long 0)
		     (value-ptr c-pointer #f)
		     (value-size unsigned-long 0)
		     (results (c-pointer "DBT") #f))
	((foreign-lambda*
	  void ((nonnull-c-pointer args)
		((nonnull-c-pointer database) db)
		((nonnull-c-pointer c-pointer) key_data)
		((nonnull-c-pointer unsigned-long) key_size)
		((nonnull-c-pointer c-pointer) value_data)
		((nonnull-c-pointer unsigned-long) value_size)
		((nonnull-c-pointer (c-pointer "DBT")) results))
	  "va_start_int((va_alist)args);"
	  "DB *secondary = va_arg_ptr((va_alist)args, DB *);"
	  "*db = secondary;"
	  "const DBT *key = va_arg_ptr((va_alist)args, const DBT *);"
	  "*key_data = key->data; *key_size = key->size;"
	  "const DBT *value = va_arg_ptr((va_alist)args, const DBT *);"
	  "*value_data = value->data; *value_size = value->size;"
	  "*results = va_arg_ptr((va_alist)args, DBT *);")
	 args


	 (location db)
	 (location key-ptr) (location key-size)
	 (location value-ptr) (location value-size)





	 (location results))
	(let* ((key (import-key-data db key-ptr key-size))
	       (value (import-value-data db value-ptr value-size))








	       (result-data (list->vector
			     (map
			      (cut make-key-data db <>)
			      (receive (proc key value))))))







	  ((foreign-lambda*
	    void (((nonnull-c-pointer "DBT") results)
		  (unsigned-long result_count))
	    "size_t results_size = result_count * sizeof(DBT);"
	    "if ((results->data = malloc(results_size))) {"
	    "  memset(results->data, 0, results_size);"
	    "  results->size = result_count;"
	    "  results->flags = DB_DBT_APPMALLOC;"
	    "}")
	   results (vector-length result-data))

	  (do ((i 0 (fx+ i 1))) ((>= i (vector-length result-data)))
	    (let ((result-data (vector-ref result-data i)))
	      ((foreign-lambda*
		void (((nonnull-c-pointer "DBT") results)
		      (unsigned-long i)
		      (nonnull-scheme-pointer result_data)
		      (unsigned-long result_size))
		"if (results->data) {"
		"  DBT *result = &((DBT *)results)[i];"
		"  if ((result->data = malloc(result_size))) {"
		"    memcpy(result->data, result_data, result_size);"
		"    result->size = result_size;"
		"    result->flags = DB_DBT_APPMALLOC;"
		"  }"
		"}")
	       results i result-data (blob/string-size result-data))))))))))

(define secondary-key-callback
  (letrec ((cache
	    (make-mutex 'secondary-key-callback))
	   (secondary-key-callback
	    (lambda (proc key-type result-type)
	      (dynamic-wind
		(cut mutex-lock! cache)
		(lambda ()
		  (and
		   proc
		   (let ((cache (mutex-specific cache)))
		     (cond
		      ((hash-table-ref/default cache proc #f)
		       => identity)
		      (else
		       (let ((callback
			      ((foreign-lambda*
				c-pointer ((scheme-object info))
				"void *root = CHICKEN_new_gc_root();"
				"CHICKEN_gc_root_set(root, info);"
				"C_return(alloc_callback(&secondary_key, root));")
			       proc)))
			 (hash-table-set! cache proc callback)
			 callback))))))
		(cut mutex-unlock! cache)))))
    (mutex-specific-set! cache (make-hash-table equal? equal?-hash))
    secondary-key-callback))

(define (database-associate db proc secondary . args)
  (let-keys+flags database-associate args
		  ((0 foreign #f))
		  ((secondary-key-flags secondary-flags)
		   (foreign-key-flags foreign-flags))

    (check-error
     'database-associate
     ((foreign-safe-lambda*
       int ((nonnull-database db) (transaction txn) (nonnull-database secondary)
	    (c-pointer callback) (int flags))
       "C_return(db->associate(db, txn, secondary, callback, flags));")
      db (current-transaction) secondary
      (secondary-key-callback proc (database-type db) (database-type secondary))
      secondary-flags))
    (when foreign
      (check-error
       'database-associate
       ((foreign-lambda*
	 int ((nonnull-database db) (nonnull-database secondary)
	      (c-pointer callback) (int flags))
	 "C_return(db->associate_foreign(db, secondary, callback, flags));")
	foreign secondary #f foreign-flags)))))

(define-foreign-enum-argconvert (database-ref-flags int)
  (#:consume "DB_CONSUME")
  (#:consume/wait "DB_CONSUME_WAIT")
  (#:ignore-lease "DB_IGNORE_LEASE")
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
................................................................................
			"s = db->get(db, txn, &key, &value, flags);"
			"*value_data = value.data; *value_size = value.size;"
			"C_return(s);")
		       db (current-transaction)
		       key-data (blob/string-size key-data)
		       (location value-ptr) (location value-size)
		       flags)))
		   (import-value-data db value-ptr value-size))

		 (exn (exn db)
		  (if (access-error? exn)
		      (if (procedure? default) (default) default)
		      (abort exn)))))))
	   (database-set!
	    (lambda (db key value . args)
	      (let-keys+flags database-set! args
			      ()
			      ((database-set!-flags flags))
		(let* ((key-data (make-key-data db key))
		       (key-size (blob/string-size key-data))
		       (value-data (make-value-data db value))

		       (value-size (string-length value-data)))
		  (check-error
		   'database-set!
		   ((foreign-safe-lambda*
		     int ((nonnull-database db) (transaction txn)
			  (nonnull-scheme-pointer key_data)
			  (unsigned-long key_size)
................................................................................
		     "key.data = key_data; key.size = key.ulen = key_size;"
		     "key.flags = DB_DBT_USERMEM;"
		     "memset(&value, 0, sizeof(DBT));"
		     "value.data = value_data; value.size = value_size;"
		     "C_return(db->put(db, txn, &key, &value, flags));")
		    db (current-transaction)
		    key-data key-size value-data value-size flags))
		  (if (memq #:append args)

		      (import-key-data db key-data key-size)
		      (void)))))))
    (values (getter-with-setter database-ref database-set!)
	    database-set!)))

(define-foreign-enum-argconvert (database-exists?-flags int)
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:read-modify-write "DB_RMW"))
................................................................................
(define-foreign-enum-argconvert (database-cursor-flags int)
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:snapshot "DB_TXN_SNAPSHOT"))

(define-foreign-enum-argconvert (database-cursor-set-flags int)
  (#:range "DB_SET_RANGE"))




(define (database-fold db proc seed . args)
  (let-keys+flags database-fold args
		  ((0 key #f))
		  ((database-cursor-flags flags)
		   (database-cursor-set-flags set-flags))

    (define step-flags (foreign-value "DB_NEXT" int))

    (if key
	(if (zero? set-flags)
	    (set!-values (set-flags step-flags)
	      (values (foreign-value "DB_SET" int)
		      (foreign-value "DB_NEXT_DUP" int))))
	(set! set-flags (foreign-value "DB_FIRST" int)))
    (let-location ((cur cursor #f))
................................................................................
	   'database-fold
	   ((foreign-lambda*
	     int ((nonnull-database db) (transaction txn)
		  ((nonnull-c-pointer cursor) cur) (int flags))
	     "C_return(db->cursor(db, txn, cur, flags));")
	    db (current-transaction) (location cur) flags))
	  (let ((cur cur))
	    (define (cursor-step key flag)
	      (condition-case
	       (let-location ((key-ptr c-pointer #f)
			      (key-size unsigned-long 0)
			      (value-ptr c-pointer #f)
			      (value-size unsigned-long 0))
		 (let ((key-data (make-key-data db key)))
		   (check-error
................................................................................
		      int ((nonnull-cursor cur)
			   (scheme-pointer ikey_data)
			   (unsigned-long ikey_size)
			   ((nonnull-c-pointer c-pointer) okey_data)
			   ((nonnull-c-pointer unsigned-long) okey_size)
			   ((nonnull-c-pointer c-pointer) value_data)
			   ((nonnull-c-pointer unsigned-long) value_size)
			   (int flags))
		      "int s;"
		      "DBT key, value;"
		      "memset(&key, 0, sizeof(DBT));"
		      "key.data = ikey_data; key.size = ikey_size;"
		      "memset(&value, 0, sizeof(DBT));"





		      "s = cur->get(cur, &key, &value, flags);"

		      "*okey_data = key.data; *okey_size = key.size;"
		      "*value_data = value.data; *value_size = value.size;"
		      "C_return(s);")
		     cur
		     key-data (blob/string-size key-data)
		     (location key-ptr) (location key-size)
		     (location value-ptr) (location value-size)
		     flag)))

		 (cons (import-key-data db key-ptr key-size)

		       (import-value-data db value-ptr value-size)))

	       (exn (exn db)
		(if (access-error? exn)
		    #f
		    (abort exn)))))
	    (let loop ((seed seed)
		       (key+value (cursor-step key set-flags)))
	      (if key+value







>







|
<







 







|
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<







|
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







|







 







|
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
|
<
<
<
|
<
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
>
>
|
<
<
>
>
>
>
>
|
<
<
>
>
>
>
>
>
>
>
|
|
|
|
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<






>




|
|
|
<
<





|
|
|







 







|
>











|
>







 







|
>
|
<







 







>
>
>





|
>

>







 







|







 







|

|

|

>
>
>
>
>
|
>







|
>
|
>
|
>







34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49

50
51
52
53
54
55
56
...
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
...
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
...
565
566
567
568
569
570
571






572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
...
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655



















656
657
658
659
660
661
662
...
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
...
693
694
695
696
697
698
699
700













701

702



703

704
705
706












707
708
709


710
711
712
713
714
715


716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743

744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760






















761





762
763
764
765
766
767
768
769
770
771
772
773
774
775


776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
...
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
...
867
868
869
870
871
872
873
874
875
876

877
878
879
880
881
882
883
...
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
...
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
...
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
   with-transaction
   copy-database rename-database delete-database
   database?
   open-database close-database
   database-type
   database-serializer database-deserializer
   database-associate
   database-primary database-mapper
   database-ref database-set! database-exists? database-delete!
   database-fold database-walk)
  (import
   scheme chicken foreign
   srfi-1 srfi-4 srfi-18 srfi-69
   lolevel data-structures ports extras)
  (foreign-declare
   "#include <db.h>")


(define-syntax define-foreign-tagged-type
  (syntax-rules ()
    ((define-foreign-tagged-type (id nonnull-id target-type)
       predicate tag)
     (begin
       (define tag
................................................................................
	    (lambda (exn)
	      (eqv? (condition-code exn) not-found))))
    access-error?))

(define (blob/string-size v)
  (cond
   ((blob? v) (blob-size v))
   ((string? v) (string-length v))
   (else 0)))

;; Database environments

(define-foreign-tagged-type (database-environment
			     nonnull-database-environment
			     "DB_ENV")
  database-environment?
................................................................................
    (current-database-environment) (current-transaction)
    file database flags))))

(define-foreign-tagged-type (database nonnull-database "DB")
  database?
  tag:database)

(define-record-type berkeley-db:info
  (make-database-info serializer deserializer primary mapper)
  database-info?
  (serializer %database-serializer)
  (deserializer %database-deserializer)
  (primary %database-primary %database-primary-set!)
  (mapper %database-mapper %database-mapper-set!))

(define database-info
  (foreign-lambda*
   scheme-object ((nonnull-database db))
   "C_return(db->app_private ? "
   "CHICKEN_gc_root_ref(db->app_private) : "
   "C_SCHEME_FALSE);"))

(define database-info-set!
  (foreign-lambda*
   void ((nonnull-database db) (scheme-object info))
   "if (!db->app_private) db->app_private = CHICKEN_new_gc_root();"
   "CHICKEN_gc_root_set(db->app_private, info);"))

(cond-expand
 (enable-heap
  (define-foreign-enum-type (database-type int)
    database-type->integer integer->database-type
    (b-tree "DB_BTREE")
    (hash-table "DB_HASH")
    (heap "DB_HEAP")
................................................................................
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db)
		   (nonnull-c-string password) (int flags))
	      "C_return(db->set_encrypt(db, password, flags));")
	     db password encryption-flags)))






	 (check-error
	  'open-database
	  ((foreign-lambda*
	    int ((nonnull-database db) (transaction txn)
		 (nonnull-c-string file) (c-string database)
		 (database-type type) (int flags) (int mode))
	    "C_return(db->open(db, txn, file, database, type, flags, mode));")
	   db (current-transaction) file database type flags mode))
	 (database-info-set!
	  db
	  (make-database-info
	   (cond (serialize+deserialize => car) (else #f))
	   (cond (serialize+deserialize => cdr) (else #f))
	   #f #f)))
     (exn (exn db)
      (close-database db)
      (abort exn)))
    db)))

(define (database-type db)
  (let-location ((type database-type #f))
................................................................................
       "if (db->app_private) {"
       "  CHICKEN_delete_gc_root(db->app_private);"
       "  db->app_private = NULL;"
       "}"
       "C_return(db->close(db, flags));")
      db flags))))

(define (database-serializer db)
  (cond
   ((database-info db) => %database-serializer)
   (else #f)))

(define (database-deserializer db)
  (cond
   ((database-info db) => %database-deserializer)
   (else #f)))

(define (database-primary db)
  (cond
   ((database-info db) => %database-primary)
   (else #f)))

(define (database-mapper db)
  (cond
   ((database-info db) => %database-mapper)
   (else #f)))

(define (database-primary+mapper-set! db primary mapper)
  (cond
   ((database-info db) =>
    (lambda (info)
      (%database-primary-set! info primary)
      (%database-mapper-set! info mapper)))
   (else
    (database-info-set! db (make-database-info #f #f primary mapper)))))

(define-foreign-enum-argconvert (secondary-key-flags int)
  (#:create "DB_CREATE")
  (#:immutable "DB_IMMUTABLE_KEY"))

(define-foreign-enum-argconvert (foreign-key-flags int)
  (#:abort "DB_FOREIGN_ABORT")
  (#:cascade "DB_FOREIGN_CASCADE"))




















(define (make-key-data db key)
  (case (database-type db)
    ((heap)
     (if key
	 (ensure blob? key)
	 (make-blob
	  (cond-expand
................................................................................
       (move-memory! ptr data size)
       (u32vector-ref (blob->u32vector/shared data) 0)))
    (else
     (import-value-data db ptr size))))

(define (make-value-data db value)
  (cond
   ((and value (database-serializer db))
    => (lambda (serialize)
	 (call-with-output-string (cut serialize value <>))))
   (else
    value)))

(define (import-value-data db ptr size)
  (let ((data (make-string size)))
................................................................................
    (move-memory! ptr data size)
    (cond
     ((database-deserializer db)
      => (cut call-with-input-string data <>))
     (else
      data))))

(define (dbt->data+size dbt)













  (let-location ((data c-pointer #f)

		 (size unsigned-long 0))



    ((foreign-lambda*

      void (((nonnull-c-pointer (const "DBT")) dbt)
	    ((nonnull-c-pointer c-pointer) data)
	    ((nonnull-c-pointer unsigned-long) size))












      "*data = dbt->data;"
      "*size = dbt->size;")
     dbt (location data) (location size))


    (values data size)))

(define-external (secondary_key (database secondary)
				((c-pointer (const "DBT")) key)
				((c-pointer (const "DBT")) data)
				((c-pointer "DBT") results))


  int
  (handle-exceptions
   exn (begin
	 (print-error-message exn (current-error-port) "Callback Error")
	 (foreign-value "DB_DONOTINDEX" int))
   (let ((primary (database-primary secondary))
	 (mapper (database-mapper secondary)))
     (let* ((result-data
	     (list->vector
	      (map
	       (cut make-key-data secondary <>)
	       (receive
		(mapper
		 (call-with-values (cut dbt->data+size key)
		   (cut import-key-data primary <> <>))
		 (call-with-values (cut dbt->data+size data)
		   (cut import-value-data primary <> <>)))))))
	    (result-count
	     (vector-length result-data)))
       ((foreign-lambda*
	 void (((nonnull-c-pointer "DBT") results)
	       (unsigned-long result_count))
	 "size_t results_size = result_count * sizeof(DBT);"
	 "if ((results->data = malloc(results_size))) {"
	 "  memset(results->data, 0, results_size);"
	 "  results->size = result_count;"
	 "  results->flags = DB_DBT_APPMALLOC;"
	 "}")

	results result-count)
       (do ((i 0 (fx+ i 1))) ((fx>= i result-count))
	 (let ((result-data (vector-ref result-data i)))
	   ((foreign-lambda*
	     void (((nonnull-c-pointer "DBT") results)
		   (unsigned-long i)
		   (nonnull-scheme-pointer result_data)
		   (unsigned-long result_size))
	     "if (results->data) {"
	     "  DBT *result = &((DBT *)results)[i];"
	     "  if ((result->data = malloc(result_size))) {"
	     "    memcpy(result->data, result_data, result_size);"
	     "    result->size = result_size;"
	     "    result->flags = DB_DBT_APPMALLOC;"
	     "  }"
	     "}")
	    results i result-data (blob/string-size result-data))))))






















   0))






(define (database-associate db proc secondary . args)
  (let-keys+flags database-associate args
		  ((0 foreign #f))
		  ((secondary-key-flags secondary-flags)
		   (foreign-key-flags foreign-flags))
    (database-primary+mapper-set! secondary db proc)
    (check-error
     'database-associate
     ((foreign-safe-lambda*
       int ((nonnull-database db) (transaction txn) (nonnull-database secondary)
	    (int flags))
       "C_return(db->associate(db, txn, secondary, secondary_key, flags));")
      db (current-transaction) secondary secondary-flags))


    (when foreign
      (check-error
       'database-associate
       ((foreign-lambda*
	 int ((nonnull-database db) (nonnull-database secondary)
	      (int flags))
	 "C_return(db->associate_foreign(db, secondary, NULL, flags));")
	foreign secondary foreign-flags)))))

(define-foreign-enum-argconvert (database-ref-flags int)
  (#:consume "DB_CONSUME")
  (#:consume/wait "DB_CONSUME_WAIT")
  (#:ignore-lease "DB_IGNORE_LEASE")
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
................................................................................
			"s = db->get(db, txn, &key, &value, flags);"
			"*value_data = value.data; *value_size = value.size;"
			"C_return(s);")
		       db (current-transaction)
		       key-data (blob/string-size key-data)
		       (location value-ptr) (location value-size)
		       flags)))
		   (import-value-data
		    (or (database-primary db) db) value-ptr value-size))
		 (exn (exn db)
		  (if (access-error? exn)
		      (if (procedure? default) (default) default)
		      (abort exn)))))))
	   (database-set!
	    (lambda (db key value . args)
	      (let-keys+flags database-set! args
			      ()
			      ((database-set!-flags flags))
		(let* ((key-data (make-key-data db key))
		       (key-size (blob/string-size key-data))
		       (value-data (make-value-data
				    (or (database-primary db) db) value))
		       (value-size (string-length value-data)))
		  (check-error
		   'database-set!
		   ((foreign-safe-lambda*
		     int ((nonnull-database db) (transaction txn)
			  (nonnull-scheme-pointer key_data)
			  (unsigned-long key_size)
................................................................................
		     "key.data = key_data; key.size = key.ulen = key_size;"
		     "key.flags = DB_DBT_USERMEM;"
		     "memset(&value, 0, sizeof(DBT));"
		     "value.data = value_data; value.size = value_size;"
		     "C_return(db->put(db, txn, &key, &value, flags));")
		    db (current-transaction)
		    key-data key-size value-data value-size flags))
		  (if (zero? (fxand flags (foreign-value "DB_APPEND" int)))
		      (void)
		      (import-key-data db key-data key-size)))))))

    (values (getter-with-setter database-ref database-set!)
	    database-set!)))

(define-foreign-enum-argconvert (database-exists?-flags int)
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:read-modify-write "DB_RMW"))
................................................................................
(define-foreign-enum-argconvert (database-cursor-flags int)
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:snapshot "DB_TXN_SNAPSHOT"))

(define-foreign-enum-argconvert (database-cursor-set-flags int)
  (#:range "DB_SET_RANGE"))

(define-foreign-enum-argconvert (database-cursor-key-flags int)
  (#:primary "1"))

(define (database-fold db proc seed . args)
  (let-keys+flags database-fold args
		  ((0 key #f))
		  ((database-cursor-flags flags)
		   (database-cursor-set-flags set-flags)
		   (database-cursor-key-flags key-flags))
    (define step-flags (foreign-value "DB_NEXT" int))
    (define primary? (bit-set? key-flags 0))
    (if key
	(if (zero? set-flags)
	    (set!-values (set-flags step-flags)
	      (values (foreign-value "DB_SET" int)
		      (foreign-value "DB_NEXT_DUP" int))))
	(set! set-flags (foreign-value "DB_FIRST" int)))
    (let-location ((cur cursor #f))
................................................................................
	   'database-fold
	   ((foreign-lambda*
	     int ((nonnull-database db) (transaction txn)
		  ((nonnull-c-pointer cursor) cur) (int flags))
	     "C_return(db->cursor(db, txn, cur, flags));")
	    db (current-transaction) (location cur) flags))
	  (let ((cur cur))
	    (define (cursor-step key flags)
	      (condition-case
	       (let-location ((key-ptr c-pointer #f)
			      (key-size unsigned-long 0)
			      (value-ptr c-pointer #f)
			      (value-size unsigned-long 0))
		 (let ((key-data (make-key-data db key)))
		   (check-error
................................................................................
		      int ((nonnull-cursor cur)
			   (scheme-pointer ikey_data)
			   (unsigned-long ikey_size)
			   ((nonnull-c-pointer c-pointer) okey_data)
			   ((nonnull-c-pointer unsigned-long) okey_size)
			   ((nonnull-c-pointer c-pointer) value_data)
			   ((nonnull-c-pointer unsigned-long) value_size)
			   (int flags) (bool primary))
		      "int s;"
		      "DBT key, skey, value;"
		      "memset(&key, 0, sizeof(DBT));"
		      "memset(&skey, 0, sizeof(DBT));"
		      "memset(&value, 0, sizeof(DBT));"
		      "if (primary) {"
		      "  skey.data = ikey_data; skey.size = ikey_size;"
		      "  s = cur->pget(cur, &skey, &key, &value, flags);"
		      "} else {"
		      "  key.data = ikey_data; key.size = ikey_size;"
		      "  s = cur->get(cur, &key, &value, flags);"
		      "}"
		      "*okey_data = key.data; *okey_size = key.size;"
		      "*value_data = value.data; *value_size = value.size;"
		      "C_return(s);")
		     cur
		     key-data (blob/string-size key-data)
		     (location key-ptr) (location key-size)
		     (location value-ptr) (location value-size)
		     flags (and primary? (database-primary db)))))
		 (let ((primary (database-primary db)))
		   (cons (import-key-data
			  (or (and primary? primary) db) key-ptr key-size)
			 (import-value-data
			  (or primary db) value-ptr value-size))))
	       (exn (exn db)
		(if (access-error? exn)
		    #f
		    (abort exn)))))
	    (let loop ((seed seed)
		       (key+value (cursor-step key set-flags)))
	      (if key+value

Changes to berkeley-db.setup.

1
2
3
4

5

6
7
8
9
10
11
12
;; -*- mode: Scheme; -*-
(compile -s -O2 -d1 "berkeley-db.scm" -ldb -lcallback
	 -j berkeley-db
	 -j berkeley-db-serialization)



(compile -s -O2 -d0 "berkeley-db.import.scm")

(install-extension
 'berkeley-db
 '("berkeley-db.so"
   "berkeley-db.import.so")
 '((version "2.1.0")))

|
|
|
>

>






|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
;; -*- mode: Scheme; -*-
(define d*
  (cond-expand
   (debug '-d2)
   (else  '-d1)))

(compile -s -O2 ,d* "berkeley-db.scm" -ldb -J)
(compile -s -O2 -d0 "berkeley-db.import.scm")

(install-extension
 'berkeley-db
 '("berkeley-db.so"
   "berkeley-db.import.so")
 '((version "2.2.0")))

Changes to berkeley-db.wiki.

149
150
151
152
153
154
155
156
157















158
159
160
161
162
163
164
...
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213




214
215
216
217
218
219
220
221
222
  =>
  (void)
</verbatim>

Associates a database with a secondary index and optionally associates
the secondary index with a foreign key constraint.

The serializers and deserializers of the linked databases, if
configured, must be compatible.
















<verbatim>
  (database-ref
   DATABASE KEY [DEFAULT]
   [#:consume] [#:consume/wait] [#:ignore-lease]
   [#:read-committed] [#:read-uncommitted] [#:read-modify-write])
  =>
................................................................................
</verbatim>

Deletes a record from the database.

<verbatim>
  (database-fold
   DATABASE PROC SEED [KEY]
   [#:range] [#:read-committed] [#:read-uncommitted] [#:snapshot])
  =>
  (PROC KEY VALUE (... (PROC KEY VALUE SEED)))
</verbatim>

Folds over the records in the database. If <tt>KEY</tt> is given, only
fold over the records with matching key, unless <tt>#:range</tt> is
also specified to start walking from the first index greater than or
equal to <tt>KEY</tt> in a b-tree database.





<verbatim>
  (database-walk
   DATABASE PROC [KEY]
   [#:range] [#:read-committed] [#:read-uncommitted] [#:snapshot])
  =>
  (void)
</verbatim>

Like <tt>database-fold</tt>, but discarding the result.







|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|









>
>
>
>



|





149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
...
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
  =>
  (void)
</verbatim>

Associates a database with a secondary index and optionally associates
the secondary index with a foreign key constraint.

The serializers and deserializers of <tt>SECONDARY</tt> and
<tt>FOREIGN</tt>, if configured, must be compatible.

<verbatim>
  (database-primary DATABASE) => DATABASE
</verbatim>

Retrieves the primary database associated with a secondary index.
Returns <tt>#f</tt> for a normal database.

<verbatim>
  (database-mapper DATABASE) => PROC
</verbatim>

Retrieves the mapping from primary keys and values to secondary keys
associated with a secondary index. Returns <tt>#f</tt> for a normal
database.

<verbatim>
  (database-ref
   DATABASE KEY [DEFAULT]
   [#:consume] [#:consume/wait] [#:ignore-lease]
   [#:read-committed] [#:read-uncommitted] [#:read-modify-write])
  =>
................................................................................
</verbatim>

Deletes a record from the database.

<verbatim>
  (database-fold
   DATABASE PROC SEED [KEY]
   [#:range] [#:primary] [#:read-committed] [#:read-uncommitted] [#:snapshot])
  =>
  (PROC KEY VALUE (... (PROC KEY VALUE SEED)))
</verbatim>

Folds over the records in the database. If <tt>KEY</tt> is given, only
fold over the records with matching key, unless <tt>#:range</tt> is
also specified to start walking from the first index greater than or
equal to <tt>KEY</tt> in a b-tree database.

If <tt>#:primary</tt> is specified and the database is a secondary
index, <tt>PROC</tt> will be invoked with the primary keys and values
instead of the secondary keys and primary values.

<verbatim>
  (database-walk
   DATABASE PROC [KEY]
   [#:range] [#:primary] [#:read-committed] [#:read-uncommitted] [#:snapshot])
  =>
  (void)
</verbatim>

Like <tt>database-fold</tt>, but discarding the result.