(module lmdb
  (database-environment?
   current-database-environment
   open-database-environment close-database-environment
   copy-database-environment
   with-transaction
   database?
   open-database close-database drop-database
   database-ref database-set! database-exists? database-delete!
   database-fold database-walk
   database->alist alist->database)

(import
  scheme
  (chicken base)
  (chicken blob)
  (chicken fixnum)
  (chicken keyword)

  [#:reverse-key "MDB_REVERSEKEY"]
  [#:duplicate-sort "MDB_DUPSORT"]
  [#:integer-key "MDB_INTEGERKEY"]
  [#:duplicate-fixed "MDB_DUPFIXED"]
  [#:integer-duplicate "MDB_INTEGERDUP"]
  [#:reverse-duplicate "MDB_REVERSEDUP"]
  [#:create "MDB_CREATE"])

(define (%open-database name flags)
  (let-location ([dbi database (wrap-database 0)])
    (check-error
     'open-database
     ((foreign-lambda
       int "mdb_dbi_open"
       nonnull-transaction c-string unsigned-int
       (nonnull-c-pointer database))
      (current-transaction) name flags (location dbi)))
    dbi))

(define (open-database . args)
  (let-keys+flags open-database args
                  ([0 name #f])
                  ([database-flags flags])


    (%open-database name flags)))







(define (close-database dbi #!optional [env (current-database-environment)])
  ((foreign-lambda
    void "mdb_dbi_close"
    nonnull-database-environment database)
   env dbi))

   [else 0]))

(define-foreign-enum-argconvert (database-set!-flags unsigned-int)
  [#:no-duplicate "MDB_NODUPDATA"]
  [#:no-overwrite "MDB_NOOVERWRITE"]
  [#:append "MDB_APPEND"]
  [#:append/duplicate "MDB_APPENDDUP"])

(define (%database-set! dbi key val flags)
  (check-error
   'database-set!
   ((foreign-lambda*
     int ([nonnull-transaction txn] [database dbi]
          [size_t klen] [scheme-pointer kptr]
          [size_t vlen] [scheme-pointer vptr]
          [unsigned-int flags])
     "MDB_val key, val;"
     "key.mv_size = klen; key.mv_data = kptr;"
     "val.mv_size = vlen; val.mv_data = vptr;"
     "C_return(mdb_put(txn, dbi, &key, &val, flags));")
    (current-transaction) dbi
    (blob/string-size key) key
    (blob/string-size val) val
    flags)))

(define-values (database-ref database-set!)
  (letrec ([database-ref
            (lambda (dbi key #!optional [default (cut check-error 'database-ref not-found)])
              (let-location ([vlen size_t 0] [vptr c-pointer #f])
                (let ([status
                       ((foreign-lambda*

                    [else
                     (check-error 'database-ref status)]))))]
           [database-set!
            (lambda (dbi key val . args)
              (let-keys+flags database-set! args
                              ()
                              ([database-set!-flags flags])

                (%database-set! dbi key val flags)))])













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

(define (database-exists? dbi key)
  (let ([status
         ((foreign-lambda*

          (set! complete? #t))))))

(define (database-walk proc dbi . args)
  (apply
   database-fold
   (lambda (key val seed) (proc key val) seed) (void)
   dbi args))

(define (database->alist dbi #!rest args #!key from to< to<=)
  (reverse!
   (database-fold
    (if (memq #:duplicate-list args)
        (lambda (key val rest)
          (if (pair? rest)
              (if (equal? key (caar rest))
                  (begin
                    (set-cdr! (car rest) (cons val (cdar rest)))
                    rest)
                  (begin
                    (set-cdr! (car rest) (reverse! (cdar rest)))
                    (cons (cons key (list val)) rest)))
              (cons (cons key (list val)) rest)))
        (lambda (key val rest)
          (cons (cons key val) rest)))
    '() dbi #:from from #:to< to< #:to<= to<=)))

(define (alist->database alist . args)
  (let-keys+flags open-database args
                  ([0 name #f])
                  ([database-flags dbi-flags]
                   [database-set!-flags set-flags])
    (let ([dbi (%open-database name dbi-flags)])
      (handle-exceptions exn
        (begin
          (close-database dbi)
          (abort exn))
        (for-each
          (lambda (key+val)
            (let ([key (car key+val)]
                  [val (cdr key+val)])
              (if (list? val)
                  (for-each
                    (cut %database-set! dbi key <> set-flags)
                    val)
                  (%database-set! dbi key val set-flags))))
          alist))
      dbi)))

)

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;