;;;; gdbm.scm -- GNU DBM bindings for Chicken
;;
;; Copyright (c) 2005-2011 Alex Shinn
;; All rights reserved.
;;
;; BSD-style license: http://www.debian.org/misc/bsd.license
(module gdbm

( gdbm-open gdbm-close gdbm-store gdbm-fetch gdbm-delete gdbm-exists
  gdbm-first-key gdbm-next-key gdbm-fold
  GDBM_READER GDBM_WRITER GDBM_WRCREAT GDBM_NEWDB GDBM_SYNC GDBM_NOLOCK
  GDBM_INSERT GDBM_REPLACE)

(import scheme)
(import chicken)
(import foreign)

(declare
 (fixnum-arithmetic)
 (usual-integrations)
 )

(declare
  (foreign-declare #<<EOF
#include <gdbm.h>

#define copy_string_result(ptr, len, str)     (C_memcpy(C_c_string(str), (char *)C_block_item(ptr, 0), C_unfix(len)), C_SCHEME_UNDEFINED)
#define free_ptr(ptr)     (C_free((char *)C_block_item(ptr, 0)), C_SCHEME_UNDEFINED)
EOF
) )

;; gdbm-open flags
(define-foreign-variable GDBM_READER_ int "GDBM_READER")
(define-foreign-variable GDBM_WRITER_ int "GDBM_WRITER")
(define-foreign-variable GDBM_WRCREAT_ int "GDBM_WRCREAT")
(define-foreign-variable GDBM_NEWDB_ int "GDBM_NEWDB")
(define-foreign-variable GDBM_SYNC_ int "GDBM_SYNC")
(define-foreign-variable GDBM_NOLOCK_ int "GDBM_NOLOCK")

(define GDBM_READER GDBM_READER_)
(define GDBM_WRITER GDBM_WRITER_)
(define GDBM_WRCREAT GDBM_WRCREAT_)
(define GDBM_NEWDB GDBM_NEWDB_)
(define GDBM_SYNC GDBM_SYNC_)
(define GDBM_NOLOCK GDBM_NOLOCK_)

;; gdbm-store flags
(define-foreign-variable GDBM_INSERT_ int "GDBM_INSERT")
(define-foreign-variable GDBM_REPLACE_ int "GDBM_REPLACE")

(define GDBM_INSERT GDBM_INSERT_)
(define GDBM_REPLACE GDBM_REPLACE_)

(define %gdbm-open
  (foreign-lambda* c-pointer ((c-string file) (int block_size) (int flags) (int mode))
    "GDBM_FILE result = gdbm_open(file, block_size, flags, mode, NULL);"
    "return(result);"))

(define (gdbm-open file . o)
  (let-optionals* o ((block-size #f)
                     (flags #f)
                     (mode #o644))
    (%gdbm-open file (or block-size 512) (or flags 2) mode)))

(define gdbm-close
  (foreign-lambda* void ((c-pointer dbf))
    "gdbm_close((GDBM_FILE) dbf);"))

(define %gdbm-store
  (foreign-lambda* int ((c-pointer dbf) (scheme-pointer kptr) (int ksize)
                        (scheme-pointer vptr) (int vsize) (int flag))
    "datum dkey = {kptr, ksize};"
    "datum dvalue = {vptr, vsize};"
    "return(gdbm_store((GDBM_FILE) dbf, dkey, dvalue, flag));"))

(define (gdbm-store dbf key value . o)
  (%gdbm-store dbf key (string-length key) value (string-length value)
               (if (pair? o) (car o) 1)))

(define %gdbm-delete
  (foreign-lambda* void ((c-pointer dbf) (scheme-pointer kptr) (int ksize))
    "datum dkey = {kptr, ksize};"
    "gdbm_delete((GDBM_FILE) dbf, dkey);"))

(define (gdbm-delete dbf key)
  (%gdbm-delete dbf key (string-length key)))

(define %gdbm-fetch
  (foreign-safe-lambda* scheme-object ((c-pointer dbf) (scheme-pointer kptr) (int ksize))
    "datum dkey = {kptr, ksize};"
    "datum result = gdbm_fetch((GDBM_FILE) dbf, dkey);"
    "return(make_string_with_len(result.dptr, result.dsize));"))

(define (gdbm-fetch dbf key)
  (%gdbm-fetch dbf key (string-length key)))

(define %gdbm-exists
  (foreign-lambda* bool ((c-pointer dbf) (scheme-pointer kptr) (int ksize))
    "datum dkey = {kptr, ksize};"
    "int result = gdbm_exists((GDBM_FILE) dbf, dkey);"
    "return(result);"))

(define (gdbm-exists dbf key)
  (%gdbm-exists dbf key (string-length key)))

(define gdbm-first-key
  (foreign-safe-lambda* scheme-object ((c-pointer dbf))
    "datum result = gdbm_firstkey((GDBM_FILE) dbf);"
    "return(make_string_with_len(result.dptr, result.dsize));"))

(define %gdbm-next-key
  (foreign-safe-lambda* scheme-object ((c-pointer dbf) (scheme-pointer kptr) (int ksize))
    "datum dkey = {kptr, ksize};"
    "datum result = gdbm_nextkey((GDBM_FILE) dbf, dkey);"
    "return(make_string_with_len(result.dptr, result.dsize));"))

(define (gdbm-next-key dbf key)
  (%gdbm-next-key dbf key (string-length key)))

(define (gdbm-fold dbf kons knil)
  (let lp ((key (gdbm-first-key dbf)) (acc knil))
    (if (not key)
      acc
      (let ((val (gdbm-fetch dbf key)))
        (lp (gdbm-next-key dbf key) (kons key val acc))))))

(define-external (make_string_with_len (c-pointer ptr) (int len)) scheme-object
  (and ptr
       (let ([str (make-string len)])
	 (##core#inline "copy_string_result" ptr len str)
	 (##core#inline "free_ptr" ptr)
	 str) ) ) )