(module sqld-i-psql mzscheme
(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 1 2)))
(require (planet "private/connection-structures.ss" ("schematics" "spgsql.plt" 1 2)))
(require (lib "pregexp.ss"))
(require (lib "class.ss"))
(provide c-psql-version
c-psql-open
c-psql-close
c-psql-query
c-psql-nrows
c-psql-ncols
c-psql-cell
c-psql-lasterr
c-psql-string2db)
(define-struct psql-result (fields ncols nrows handle))
(define-struct psql-handle (conn err-message err))
(define (c-psql-open connection-string)
(let ((items (pregexp-split "[ \t]+" connection-string)))
(let ((host "localhost")
(port 5432)
(database #f)
(user #f)
(password #f))
(for-each (lambda (item)
(let ((keyval (pregexp-split "[ \t]*=[ \t]*" item)))
(let ((key (string->symbol (car keyval)))
(val (cadr keyval)))
(cond ((eq? key 'host) (set! host val))
((eq? key 'port) (set! port (string->number val)))
((eq? key 'dbname) (set! database val))
((eq? key 'user) (set! user val))
((eq? key 'password) (set! password val))
(else (error (format "sqld-psql:connect:unknown keyword: ~a" key)))))))
items)
(if (and (eq? database #f) (not (eq? user #f))) (set! database user))
(if (eq? user #f) (error "sqld-psql:connect:the user keyword is mandatory"))
(with-handlers ((exn:fail? (lambda (exn)
(make-psql-handle #f (exn-message exn) #t))))
(make-psql-handle
(if (eq? password #f)
(connect host port database user)
(connect host port database user password))
""
#f)))))
(define (c-psql-close handle)
(if (not (eq? (psql-handle-conn handle) #f))
(send (psql-handle-conn handle) disconnect)))
(define (c-psql-query handle query)
(if (eq? (psql-handle-conn handle) #f)
(error "sqld-psql:c-psql-query:invalid connection"))
(set-psql-handle-err! handle #f)
(set-psql-handle-err-message! handle "")
(let ((res (send (psql-handle-conn handle) query-general query)))
(let ((R (if (list? res) (car res) res)))
(if (Recordset? R)
(make-psql-result (list->vector (Recordset-rows R))
(if (null? (Recordset-rows R))
0
(length (Recordset-fields R)))
(length (Recordset-rows R))
handle)
(if (ErrorResult? R)
(begin
(set-psql-handle-err-message! handle (ErrorResult-message R))
(set-psql-handle-err! handle #t)
(make-psql-result (vector) 0 0 handle))
(make-psql-result (vector) 0 0 handle))))))
(define (c-psql-nrows resultset)
(psql-result-nrows resultset))
(define (c-psql-ncols resultset)
(psql-result-ncols resultset))
(define (c-psql-cell resultset row col)
(vector-ref (vector-ref (psql-result-fields resultset) row) col))
(define (c-psql-version)
100)
(define (c-psql-lasterr handle)
(if (psql-result? handle)
(c-psql-lasterr (psql-result-handle handle))
(psql-handle-err-message handle)))
(define re-quote (regexp "[']"))
(define (c-psql-string2db s)
(regexp-replace* re-quote s "''"))
)