;;;; tokyocabinet.scm -- Tokyo Cabinet DBM bindings for Chicken 5
;;
;; Copyright (c) 2018-2019 Sven Hartrumpf
;; All rights reserved.
;;
;; BSD-style license: http://www.debian.org/misc/bsd.license

; TODO find replacement for sized-c-string* below

(module tokyocabinet
 (
  ;tc-list-new tc-list-del
  ;tc-list-pop tc-list-push tc-list-fold
  ;tc-map-new tc-map-del
  ;tc-map-put! tc-map-out! tc-map-get
  ;tc-map-iter-init tc-map-iter-next
  ;tc-map-fold
  TC_HDBTLARGE TC_HDBTDEFLATE TC_HDBTBZIP TC_HDBTTCBS TC_HDBTEXCODEC
  TC_HDBOREADER TC_HDBOWRITER TC_HDBOCREAT TC_HDBOTRUNC TC_HDBONOLCK TC_HDBOLCKNB TC_HDBOTSYNC
  tc-hdb-open tc-hdb-close
  tc-hdb-get tc-hdb-get-exp
  ;tc-hdb-put! tc-hdb-out!
  ;tc-hdb-vsize tc-hdb-delete!
  tc-hdb-ecode
  ;tc-hdb-fold
  ;tc-hdb-iter-init tc-hdb-iter-next
  ;tc-hdb-sync tc-hdb-vanish tc-hdb-copy
  ;tc-hdb-path
  ;tc-hdb-transaction-begin tc-hdb-transaction-commit tc-hdb-transaction-abort
  ;tc-hdb-record-count tc-hdb-file-size
  ; tokyotable tct:
  TC_TDBTLARGE TC_TDBTDEFLATE TC_TDBTBZIP TC_TDBTTCBS TC_TDBTEXCODEC
  TC_TDBOREADER TC_TDBOWRITER TC_TDBOCREAT TC_TDBOTRUNC TC_TDBONOLCK TC_TDBOLCKNB TC_TDBOTSYNC
  tc-tdb-open tc-tdb-close
  tc-tdb-get-tabcols
)

(import scheme)
(import (chicken base))
(import (chicken fixnum))
(import (chicken foreign))
(import (chicken format))
(import (only (chicken memory) free))
(import (chicken port))

 (foreign-declare "#include <tcutil.h>")
 (foreign-declare "#include <tchdb.h>")
 (foreign-declare "#include <tctdb.h>")

(define TC_HDBTLARGE    1)
(define TC_HDBTDEFLATE  2)
(define TC_HDBTBZIP     4)
(define TC_HDBTTCBS     8)
(define TC_HDBTEXCODEC 16)

(define TC_HDBOREADER 1)
(define TC_HDBOWRITER 2)
(define TC_HDBOCREAT  4)
(define TC_HDBOTRUNC  8)
(define TC_HDBONOLCK 16)
(define TC_HDBOLCKNB 32)
(define TC_HDBOTSYNC 64)

; sorted by function name:
(define $tchdbclose (foreign-lambda bool tchdbclose (c-pointer (struct TCHDB))))
(define $tchdbecode (foreign-lambda int tchdbecode (c-pointer (struct TCHDB))))
(define $tchdbget (foreign-lambda c-pointer tchdbget (c-pointer (struct TCHDB)) blob int (c-pointer int)))
;(define $tchdbget (foreign-lambda c-string* tchdbget (c-pointer (struct TCHDB)) blob int (c-pointer int)))
(define $tchdbnew (foreign-lambda (c-pointer (struct TCHDB)) tchdbnew))
(define $tchdbopen (foreign-lambda bool tchdbopen (c-pointer (struct TCHDB)) c-string* int))

(define (tc-hdb-open file #!key (flags (fx+ TC_HDBOWRITER (fx+ TC_HDBOREADER TC_HDBOCREAT)))) ; (cache-limit #f)  (mmap-size #f) (mutex? #f) (num-buckets #f) (num-free-blocks #f) (record-alignment #f) (tune-opts #f))
  (let ((hdb ($tchdbnew)))
    ;(display hdb)(newline)
    (and hdb
         ;; make sure all the specified keyword settings succeed, and
         ;; return the hdb record
         (or (and
               ;(or (not mutex?) (%tc-hdb-setmutex hdb))
               ;(or (not cache-limit) (%tc-hdb-setcache hdb cache-limit))
               ;(or (not mmap-size) (%tc-hdb-setxmsiz hdb mmap-size))
               ;(or (not (or num-buckets record-alignment num-free-blocks tune-opts))
               ;    (%tc-hdb-tune hdb
               ;                  (or num-buckets 0)
               ;                  (or record-alignment -1)
               ;                  (or num-free-blocks -1)
               ;                  (or tune-opts 0)))
               ($tchdbopen hdb file flags)
               hdb)
             (begin
               ;; clean up and return #f if any of the functions failed
               ;(%tc-hdb-del hdb)
               #f)))))

(define (tc-hdb-close hdb)
  (and ($tchdbclose hdb)
       (begin
         ;(%tc-hdb-del hdb)
         ;(tc-hdb-ptr-set! hdb #f) ; prevent further use
         #t)))

;(define (tc-hdb-put! hdb key value)
;  (%tc-hdb-put hdb key (string-length key) value (string-length value)))

;(define (tc-hdb-out! hdb key)
;  (%tc-hdb-out hdb key (string-length key)))

;(define tc-hdb-delete! tc-hdb-out!)

(define (tc-hdb-ecode hdb)
  ($tchdbecode hdb))

(define (tc-hdb-get hdb key)
  (let-location ((size int))
    (let ((val ($tchdbget hdb key (string-length key) (location size))))
      (cond (val
             (let ((result (copy-buffer-to-string val size)))
               (free val)
               result))
        (else
          #f)))))
      ;(let ((val val))) ; trick to ensure release
  ; maybe copy (ref size) bytes
  ;    (foreign-code "C_string (val, size, int length, char *string)")
  ;  (and-let* ((ptr (tchdbget hdb key (string-length key) (location size))))
  ;    (sized-c-string* ptr size 'tc-hdb-get))))

(define (tc-hdb-get-exp db key)
  (let ((val-str (tc-hdb-get db key)))
    (and val-str
         (call-with-input-string val-str read))))

;(define (tc-hdb-vsize hdb key)
;  (%tc-hdb-vsiz hdb key (string-length key)))

;(define tc-hdb-iter-init %tc-hdb-iterinit)
;(define (tc-hdb-iter-next hdb)
;  (let-location ((size int))
;    (and-let* ((ptr (%tc-hdb-iternext hdb (location size))))
;      (sized-c-string* ptr size 'tc-hdb-iter-next))))

;(define (tc-hdb-fold hdb kons knil)
;  (tc-hdb-iter-init hdb)
;  (let lp ((acc knil))
;    (let ((key (tc-hdb-iter-next hdb)))
;      (if (not key)
;          acc
;          (let ((val (tc-hdb-get hdb key)))
;            (lp (kons key val acc)))))))
;
;(define tc-hdb-sync %tc-hdb-sync)
;(define tc-hdb-vanish %tc-hdb-vanish)
;(define tc-hdb-copy %tc-hdb-copy)
;(define tc-hdb-transaction-begin  %tc-hdb-tranbegin)
;(define tc-hdb-transaction-commit %tc-hdb-trancommit)
;(define tc-hdb-transaction-abort  %tc-hdb-tranabort)
;(define tc-hdb-record-count %tc-hdb-rnum)
;(define tc-hdb-file-size %tc-hdb-fsiz)

(foreign-declare "#define copy_string(ptr, to, len) (C_memcpy(C_data_pointer(to), (C_char *)C_block_item(ptr, 0), C_unfix(len)), C_SCHEME_UNDEFINED)")
(define (copy-buffer-to-string b len)
  (let ((str (make-string len)))
    (##core#inline "copy_string" b str len)
    ;(##core#inline "C_peek_c_string" b 0 str len) ; only in library.scm, hence not accessible here
    str))

; tct:

(define $tctdbclose (foreign-lambda bool tctdbclose (c-pointer (struct TCTDB))))
(define $tctdbget3 (foreign-lambda c-string* tctdbget3 (c-pointer (struct TCTDB)) c-string*))
(define $tctdbnew (foreign-lambda (c-pointer (struct TCTDB)) tctdbnew))
(define $tctdbopen (foreign-lambda bool tctdbopen (c-pointer (struct TCTDB)) c-string* int))

(define TC_TDBTLARGE    1)
(define TC_TDBTDEFLATE  2)
(define TC_TDBTBZIP     4)
(define TC_TDBTTCBS     8)
(define TC_TDBTEXCODEC 16)

(define TC_TDBOREADER 1)
(define TC_TDBOWRITER 2)
(define TC_TDBOCREAT  4)
(define TC_TDBOTRUNC  8)
(define TC_TDBONOLCK 16)
(define TC_TDBOLCKNB 32)
(define TC_TDBOTSYNC 64)

(define (tc-tdb-open file #!key (flags (fx+ TC_TDBOWRITER (fx+ TC_TDBOREADER TC_TDBOCREAT))))
  (let ((tdb ($tctdbnew)))
    ;(display tdb)(newline)
    (and tdb
         ;; make sure all the specified keyword settings succeed, and
         ;; return the tdb record
         (or (and
               ;(or (not mutex?) (%tc-hdb-setmutex hdb))
               ;(or (not cache-limit) (%tc-hdb-setcache hdb cache-limit))
               ;(or (not mmap-size) (%tc-hdb-setxmsiz hdb mmap-size))
               ;(or (not (or num-buckets record-alignment num-free-blocks tune-opts))
               ;    (%tc-hdb-tune hdb
               ;                  (or num-buckets 0)
               ;                  (or record-alignment -1)
               ;                  (or num-free-blocks -1)
               ;                  (or tune-opts 0)))
               ($tctdbopen tdb file flags)
               tdb)
             (begin
               ;; clean up and return #f if any of the functions failed
               ;(%tc-tdb-del htb)
               #f)))))

(define (tc-tdb-close tdb)
  (and ($tctdbclose tdb)
       (begin
         ;(%tc-hdb-del hdb)
         ;(tc-hdb-ptr-set! hdb #f) ; prevent further use
         #t)))

(define (tc-tdb-get-tabcols tdb key)
  (let ((val ($tctdbget3 tdb key)))
    val))

)