(module c-sqld-psql mzscheme
        (require (lib "foreign.ss")) (unsafe!)
        (require "utils.scm")
        (require (lib "getinfo.ss" "setup"))
        (provide                  
                 PQconnectdb
                 PQconnectStart
                 PQconnectPoll
                 PQsocket
                 PQstatus
                 PQdb
                 PQuser
                 PQpass
                 PQport
                 PQhost
                 PQtransactionStatus
                 PQprotocolVersion
                 PQserverVersion
                 PQerrorMessage
                 PQexec
                 
                 pg-connect
                 pg-finish
                 
                 pg-escape
                 pg-query
                 pg-row
                 pg-nrows
                 pg-ncols
                 pg-column-name
                 
                 pg-server-version
                 pg-protocol-version
                 
                 pg-debug
                 pg-nodebug
                 
                 pg-error-message
                 
                 pg-version
                 
                 pg-ok?
                 )
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Library loading
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define (SCHEME-SLEEP-THREAD)  (sleep 0.01))
        
        (define (load-lib-internal libs L)
          (if (null? libs)
              'nil
              (let ((lib (with-handlers ((exn:fail? (lambda (exn) #f)))
                           (ffi-lib (car libs)))))
                (if (eq? lib #f)
                    (load-lib-internal (cdr libs) L)
                    lib))))
        
        (define (load-lib L)
          (load-lib-internal L L))
        
        (define lib   (load-lib '("pq" "libpq" "libpq.dll")))
        (define tlib  (let ((paths (find-relevant-directories '(sqld-psql-c))))
                        (if (null? paths)
                            (load-lib '("c-sqld-psql"))
                            (load-lib (list 
                                       (path->string (build-path (car paths) "c-sqld-psql"))
                                       "c-sqld-psql")))))
        (define clib  (load-lib '("wsock32.dll" #f "libc" "libc.so.6")))
        (define melib (load-lib '(#f)))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Constants
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (def-consts (PGRES-POLLING-FAILED 0) 
                    PGRES-POLLING-READING
                    PGRES-POLLING-WRITING
                    PGRES-POLLING-OK
                    PGRES-POLLING-ACTIVE
                    ) ;; polling
        
        (def-consts (CONNECTION-OK 0)
                    CONNECTION-BAD
                    CONNECTION-STARTED
                    CONNECTION-MADE
                    CONNECTION-AWAITING-RESPONSE
                    CONNECTION-AUTH-OK
                    CONNECTION-SETENV
                    CONNECTION-SSL-STARTUP
                    CONNECTION-NEEDED
                    ) ;; status
        
        (def-consts (PQTRANS-IDLE 0)
                    PQTRANS-ACTIVE
                    PQTRANS-INTRANS
                    PQTRANS-INERROR
                    PQTRANS-UNKNOWN
                    ) ;; transaction status
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; types
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define-cpointer-type _PGconn)
        (define-cpointer-type _PGresult)
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Finalizers
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define (finalize-pgconn pgconn-obj)
          (let ((R (unbox pgconn-obj)))
            (if (not (eq? R #f))
                (PQfinish R))))
        
        (define (finalize-pgresult pgresult-obj)
          (if (not (eq? pgresult-obj #f))
              (PQclear pgresult-obj)))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; FFI functions
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define-syntax my-get-ffi-obj
          (syntax-rules ()
            ((_ a1 ...)
             (with-handlers ((exn:fail? (lambda (exn)
                                          (lambda args 
                                            (error 
                                             (format "Function '~a' has not been loaded" 
                                                     (car (list a1 ...))))))))
               (get-ffi-obj a1 ...)))))
        
        (define-syntax my-ffi-obj-ref
          (syntax-rules ()
            ((_ a1 ...)
             (with-handlers ((exn:fail? (lambda (exn) #f)))
               (ffi-obj-ref a1 ...)))))
        
        
        (define c_psql_set_block    (my-get-ffi-obj "c_psql_set_block"
                                                 tlib
                                                 (_fun (cf : _fpointer)
                                                       -> _void)))
        
        (define c_psql_set_pqexec   (my-get-ffi-obj "c_psql_set_pqexec"
                                                 tlib
                                                 (_fun (cf : _fpointer)
                                                       -> _void)))
        
        (define c_psql_query       (my-get-ffi-obj "c_psql_query"
                                                tlib
                                                (_fun (PQconn : _PGconn)
                                                      (cmd : _string)
                                                      -> (result : _pointer)
                                                      -> (if (eq? result #f)
                                                             #f
                                                             (begin
                                                               (set-cpointer-tag! result PGresult-tag)
                                                               (register-finalizer result finalize-pgresult)
                                                               result)))))
          
        (define scheme_block_until (my-ffi-obj-ref "scheme_block_until" melib))
;                                                melib
;                                                (_fun (f1    : _pointer)
;                                                      (f2    : _pointer)
;                                                      (data  : _pointer)
;                                                      (sleep : _float)
;                                                      -> _int)))
        (define PQexec_set         (my-ffi-obj-ref "PQexec" lib))
        
        (define PQconnectdb    (my-get-ffi-obj "PQconnectdb"
                                            lib
                                            (_fun (conn : _string)
                                                  -> (result : _pointer)
                                                  -> (let ((R (box result)))
                                                       (if (not (eq? result #f))
                                                           (set-cpointer-tag! result PGconn-tag))
                                                       (register-finalizer R finalize-pgconn)
                                                       R))))
        
        (define PQconnectStart (my-get-ffi-obj "PQconnectStart"
                                            lib
                                            (_fun (conn : _string)
                                                  -> (result : _pointer)
                                                  -> (let ((R (box result)))
                                                       (if (not (eq? result #f))
                                                           (set-cpointer-tag! result PGconn-tag))
                                                       (register-finalizer R finalize-pgconn)
                                                       R))))
        
        (define PQconnectPoll  (my-get-ffi-obj "PQconnectPoll"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> (PGpoll : _int)
                                                  -> PGpoll)))
        
        (define PQsocket       (my-get-ffi-obj "PQsocket"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> _int)))
        
        (define PQstatus       (my-get-ffi-obj "PQstatus"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> _int)))
        
        (define PQdb           (my-get-ffi-obj "PQdb"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> _string)))
        
        (define PQuser         (my-get-ffi-obj "PQuser"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> _string)))
        
        (define PQpass         (my-get-ffi-obj "PQpass"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> _string)))

        (define PQhost         (my-get-ffi-obj "PQhost"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> _string)))
        
        
        (define PQport         (my-get-ffi-obj "PQport"
                                            lib
                                            (_fun (PQconn : _PGconn)
                                                  -> _string)))
        
        (define PQtransactionStatus (my-get-ffi-obj "PQtransactionStatus"
                                                 lib
                                                 (_fun (PQconn : _PGconn)
                                                       -> _int)))
        
        (define PQprotocolVersion (my-get-ffi-obj "PQprotocolVersion"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     -> _int)))
        
        (define PQserverVersion   (my-get-ffi-obj "PQserverVersion"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     -> _int)))
        
        (define PQerrorMessage    (my-get-ffi-obj "PQerrorMessage"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     -> _string)))
        
        (define PQfinish          (my-get-ffi-obj "PQfinish"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     -> _void)))
        
        (define PQexec            (my-get-ffi-obj "PQexec"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     (cmd : _string)
                                                     -> (result : _pointer)
                                                     -> (if (eq? result #f)
                                                            #f
                                                            (begin
                                                              (set-cpointer-tag! result PGresult-tag)
                                                              (register-finalizer result finalize-pgresult)
                                                              result)))))
        
        (define PQclear           (my-get-ffi-obj "PQclear" 
                                               lib
                                               (_fun (PQresult : _PGresult)
                                                     -> _void)))
        
        (define PQresultErrorMessage 
                                  (my-get-ffi-obj "PQresultErrorMessage"
                                               lib
                                               (_fun (PQresult : _PGresult)
                                                     -> _string)))
        
        (define PQsendQuery       (my-get-ffi-obj "PQsendQuery"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     (cmd : _string)
                                                     -> _int)))
        
        (define PQgetResult       (my-get-ffi-obj "PQgetResult"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     -> (result : _pointer)
                                                     -> (if (eq? result #f)
                                                            #f
                                                            (begin
                                                              (set-cpointer-tag! result PGresult-tag)
                                                              (register-finalizer result finalize-pgresult)
                                                              result)))))
        
        (define PQconsumeInput    (my-get-ffi-obj "PQconsumeInput"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     -> _int)))
        
        (define PQisBusy          (my-get-ffi-obj "PQisBusy"
                                               lib
                                               (_fun (PQconn : _PGconn)
                                                     -> _int)))
        
        (define PQntuples         (my-get-ffi-obj "PQntuples"
                                               lib
                                               (_fun (PQresult : _PGresult)
                                                     -> _int)))
        
        (define PQnfields         (my-get-ffi-obj "PQnfields"
                                               lib
                                               (_fun (PQresult : _PGresult)
                                                     -> _int)))
        
        (define PQfname           (my-get-ffi-obj "PQfname"
                                               lib
                                               (_fun (PQresult : _PGresult)
                                                     (column   : _int)
                                                     -> _string)))
        
        (define PQgetvalue        (my-get-ffi-obj "PQgetvalue"
                                               lib
                                               (_fun (PQresult : _PGresult)
                                                     (row      : _int)
                                                     (col      : _int)
                                                     -> _string)))
        
        (define PQgetisnull        (my-get-ffi-obj "PQgetisnull"
                                                lib
                                                (_fun (PQresult : _PGresult)
                                                      (row      : _int)
                                                      (col      : _int)
                                                      -> _int)))
        
        (define PQescapeStringConn (my-get-ffi-obj "PQescapeStringConn"
                                                lib
                                                (_fun (PQconn : _PGconn)
                                                      (to     : _string)
                                                      (from   : _string)
                                                      (length : _int)
                                                      (error  : _pointer)
                                                      -> _int)))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Exported funcs
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define (pg-connect connstr debug)
          (PQconnectdb connstr))
        
        (define (pg-finish conn debug)
          (let ((R (unbox conn)))
            (PQfinish R)
            (set-box! conn #f)))
        
        (define (pg-query conn query debug)
          (set! conn (unbox conn))
          (c_psql_set_block  scheme_block_until)
          (c_psql_set_pqexec PQexec_set)
          (c_psql_query conn query))
        
        (define (pg-escape conn from debug)
          (let ((b (string->bytes/utf-8 from)))
            (let ((L (bytes-length b)))
              (let ((out (make-bytes (+ (* L 3)) 0)))  ;;; utf-8 stuff
                (let ((NL (PQescapeStringConn (unbox conn) out from L #f)))
                  (debug "New length: ~s~%" NL)
                  (debug "Out       : ~s~%" out)
                  (let ((R (subbytes out 0 NL)))
                    (bytes->string/utf-8 R)))))))
        
        (define (pg-nrows result)
          (PQntuples result))
        
        (define (pg-ncols result)
          (PQnfields result))
        
        (define (pg-column-name result i)
          (PQfname result i))
        
        (define (pg-row result row null-value)
          (letrec ((f  (lambda (i N)
                         (if (< i N)
                             (cons (if (= (PQgetisnull result row i) 1)
                                       null-value
                                       (PQgetvalue result row i))
                                   (f (+ i 1) N))
                             '()))))
            (if (< row 0)
                #f
                (if (>= row (PQntuples result))
                    #f
                    (f 0 (PQnfields result))))))
        
        
        (define (pg-debug form . args)
          (display (apply format form args))
          (flush-output (current-output-port)))
        
        (define (pg-nodebug . args)
          #t)
        
        (define (pg-server-version conn)
          (PQserverVersion (unbox conn)))
        
        (define (pg-protocol-version conn)
          (PQprotocolVersion (unbox conn)))
        
        (define (pg-error-message conn-or-result)
          (if (box? conn-or-result)
              (if (eq? (unbox conn-or-result) #f)
                  "No connection to the postgreSQL server"
                  (PQerrorMessage (unbox conn-or-result)))
              (PQresultErrorMessage conn-or-result)))
        
        (define (pg-version)
          100)
        
        (define (pg-ok? conn-or-result)
          (if (box? conn-or-result)
              (if (eq? (unbox conn-or-result) #f)
                  #f
                  (string=? (pg-error-message conn-or-result) ""))
              (string=? (pg-error-message conn-or-result) "")))

        (define (pg-error? conn-or-result)
          (not (pg-ok? conn-or-result)))
        
        
        )