Calling this function with a valid PostgreSQL connection string (containing host, dbname, user, etc.), will instantiate a new driver, that can be given to a new instance of SQLI.

The module definition is as follows:

(module sqld-psql mzscheme
        (require (lib "time.ss" "srfi" "19"))
        (require "c-sqld-psql.scm")

As can be seen, only one function is exported, the sqld-psql-new function. All other function definitions are interface definitions for C functions that are called from this module.

In the next section, supportive functions and definitions are described.

The ierr function displays a message and returns #f. This function is simply used to report errors to the current output port.

(define (ierr msg)
  (display msg)
  (newline)
  #f)

Conversion functions are used to convert between database representations of types and scheme representations of types. They are all straightforward.

Psql is SQL92 compliant, so for all strings, the single quote must be escaped. A simple pregexp-replace* call is used to escape the single quotes. This function could be made more efficient, using a loop, or even a C function to do the same.

(define (string2db conn s debug)
  (string-append "'" (pg-escape conn s debug) "'"))

A PostgreSQL date type is constructed from the bigloo date type, using a the predescribed PostgreSQL encoding, without a zone part.

The interpretation back from the database is done by expecting the same encoding. No checking is done for the parts of the strings; so, the precondition for the use of this function is, that the given string conforms to the previous definition.

;#+ mzscheme
(define-syntax integer->string
  (syntax-rules ()
    ((integer->string s) (number->string s))))

(define-syntax string->integer
  (syntax-rules ()
    ((string->integer s) (string->number s))))
;##


(define (pre-zero2 n)
  (if (< n 10) 
      (string-append "0" (integer->string n))
      (integer->string n)))

(define (date2db dt)
  (string-append "'"
  (date->string dt "~Y~m~dT~H~M~S")
  "'"))


(define (db2date dt)
  (string->date dt "~Y-~m-~d ~H:~M:~S")
)

All other conversions are done using the standard scheme primitives.

The connection function is called from the closure provided by sqld-psql-new, when it is called with the 'connect argument. It returns a closure that is used for further command processing and that has a connection to the Psql database.

The commands to be processed are placed in a cond structure, with the probably most commonly used commands at front.

Supportive functions are defined within the closure, to handle the interfacing for queries to the C part and fetches.

(define (sqld-psql-connect connection-info null-value debug)
  (let ((db (pg-async-connect connection-info debug))
        (current-query-result #f)
        (valid-handle         #t)
        (nrows                0)
        (ncols                0)
        (row                  0)
        )

    (define (query q)
      (begin
        (set! current-query-result (pg-query db q debug))
        (set! row -1)
        (set! ncols (pg-ncols current-query-result))
        (set! nrows (pg-nrows current-query-result))))

    (define (fetch)
      (set! row (+ row 1))
      (pg-row current-query-result row null-value))

    (lambda (cmd . args)
      (if (eq? valid-handle #f)
          (ierr "ERROR: disconnected handle")
          (cond

           ((eq? cmd 'string2db)    (string2db db (car args) debug))
           ((eq? cmd 'int2db)       (integer->string (car args)))
           ((eq? cmd 'number2db)    (number->string (car args)))
           ((eq? cmd 'date2db)      (date2db (car args)))
           ((eq? cmd 'bool2db)      (if (eq? (car args) #t) "'t'" "'f'"))

           ((eq? cmd 'db2date)      (db2date (car args)))
           ((eq? cmd 'db2bool)      (if (string=? (car args) "t") #t #f))
           
           ((eq? cmd 'fetchrow)     (if (eq? current-query-result #f) #f (fetch)))
           ((eq? cmd 'lasterr)      (pg-error-message (if (eq? current-query-result #f) db current-query-result)))

           ((eq? cmd 'begin)        (query "BEGIN;"))
           ((eq? cmd 'commit)       (query "COMMIT;"))
           ((eq? cmd 'rollback)     (query "ROLLBACK;"))
           ((eq? cmd 'query)        (query (car args)))
           
           ((eq? cmd 'null-value)   (begin
                                      (if (not (null? args))
                                          (set! null-value (car args)))
                                      null-value))
           
           ((eq? cmd 'debug)        (begin
                                      (if (not (null? args))
                                          (if (eq? (car args) #f)
                                              (set! debug pg-nodebug)
                                              (if (procedure? (car args))
                                                  (set! debug (car args))
                                                  (set! debug pg-debug))))
                                      debug))

           ((eq? cmd 'disconnect)   (begin
                                      (pg-finish db debug)
                                      (set! valid-handle #f)))
           
           (else (ierr "Unknown command")))))))

Now for the main function that this driver provides: sqld-psql-new. This function takes connection-info as an argument, which must be an Psql database. It returns a closure that handles the 'connect, 'clean, 'name and 'version calls. It is a very simple function.

The 'version call returns the major version number of PostgreSQL * 100 + the middle version number * 10 + the minor version number.

(define (sqld-psql-new _connection-info)
  (let ((connection-info _connection-info)
        (null-value      "")
        (debug           pg-nodebug))
    (lambda (cmd . args)
      (cond

       ((eq? cmd 'connect)     (sqld-psql-connect connection-info null-value debug))
       ((eq? cmd 'clean)       #t)

       ((eq? cmd 'name)        "psql-ffi")
       ((eq? cmd 'version)     (pg-version))
       ((eq? cmd 'null-value)  (begin
                                  (if (not (null? args)) 
                                      (set! null-value (car args)))
                                 null-value))
       ((eq? cmd 'debug)       (begin
                                 (if (not (null? args))
                                     (if (eq? (car args) #f)
                                         (set! debug pg-nodebug)
                                         (if (procedure? (car args))
                                             (set! debug (car args))
                                             (set! debug pg-debug))))
                                 debug))

       (else (ierr "ERROR: Connect to the datebase first"))))))

The default value returned for null values is the empty string (i.e. ""). If an other value is needed, e.g. 'null, one can set an alternative value using the sqld-psql-null-value function on an sqld object.

(define (sqld-psql-null-value sqld . v)
  (apply sqld (cons 'null-value v)))

If you want to have some information on what's going on with the server, turn debugging on, e.g. using (sqld-psql-debug sqld #t).

(define (sqld-psql-debug sqld . v)
  (apply sqld (cons 'debug v)))