From: Kevin M. Rosenberg Date: Sat, 23 Mar 2002 17:10:48 +0000 (+0000) Subject: r1647: *** empty log message *** X-Git-Tag: v3.8.6~1227 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=b06cb6d32e2a334f7dc72e8fb583a5b9609136b7 r1647: *** empty log message *** --- diff --git a/clsql-mysql.system b/clsql-mysql.system index 4122b47..795d8d9 100644 --- a/clsql-mysql.system +++ b/clsql-mysql.system @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql-mysql.system,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; $Id: clsql-mysql.system,v 1.2 2002/03/23 17:10:47 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -28,8 +28,8 @@ :binary-pathname "CLSQL:interfaces;mysql;bin;" :components ((:file "mysql-package") (:file "mysql-loader" :depends-on ("mysql-package")) - (:file "mysql-uffi" :depends-on ("mysql-loader")) - (:file "mysql-sql" :depends-on ("mysql-uffi"))) + (:file "mysql-api" :depends-on ("mysql-loader")) + (:file "mysql-sql" :depends-on ("mysql-api"))) :depends-on (:uffi :clsql) :finally-do (progn diff --git a/clsql-postgresql-socket.system b/clsql-postgresql-socket.system index 98467af..2701c36 100644 --- a/clsql-postgresql-socket.system +++ b/clsql-postgresql-socket.system @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql-postgresql-socket.system,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; $Id: clsql-postgresql-socket.system,v 1.2 2002/03/23 17:10:47 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -26,8 +26,8 @@ :source-extension "cl" :binary-pathname "CLSQL:interfaces;postgresql-socket;bin;" :components ((:file "postgresql-socket-package") - (:file "postgresql-socket-uffi" + (:file "postgresql-socket-api" :depends-on ("postgresql-socket-package")) (:file "postgresql-socket-sql" - :depends-on ("postgresql-socket-uffi"))) + :depends-on ("postgresql-socket-api"))) :depends-on (:clsql)) diff --git a/clsql-postgresql.system b/clsql-postgresql.system index c956d76..ae3a9a7 100644 --- a/clsql-postgresql.system +++ b/clsql-postgresql.system @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql-postgresql.system,v 1.1 2002/03/23 14:04:49 kevin Exp $ +;;;; $Id: clsql-postgresql.system,v 1.2 2002/03/23 17:10:47 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -26,6 +26,6 @@ :source-extension "cl" :components ((:file "postgresql-package") (:file "postgresql-loader" :depends-on ("postgresql-package")) - (:file "postgresql-uffi" :depends-on ("postgresql-loader")) - (:file "postgresql-sql" :depends-on ("postgresql-uffi"))) + (:file "postgresql-api" :depends-on ("postgresql-loader")) + (:file "postgresql-sql" :depends-on ("postgresql-api"))) :depends-on (:uffi :clsql)) diff --git a/interfaces/mysql/mysql-api.cl b/interfaces/mysql/mysql-api.cl new file mode 100644 index 0000000..2a3b911 --- /dev/null +++ b/interfaces/mysql/mysql-api.cl @@ -0,0 +1,579 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: mysql.cl +;;;; Purpose: Low-level MySQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: mysql-api.cl,v 1.1 2002/03/23 17:10:47 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and Copyright (c) 1999-2001 by Pierre R. Mai +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + +(in-package :mysql) + +;;;; Modifications from original code +;;;; - Updated C-structures to conform to structures in MySQL 3.23.46 +;;;; - Changed from CMUCL interface to UFFI +;;;; - Added and call a C-helper file to support 64-bit integers +;;;; that are used in a few routines. +;;;; - Removed all references to interiors of C-structions, this will +;;;; increase robustness when MySQL's internal structures change. + +;;;; Type definitions + +;;; Basic Types + +(uffi:def-foreign-type mysql-socket :int) +(uffi:def-foreign-type mysql-bool :char) +(uffi:def-foreign-type mysql-byte :unsigned-char) + +(uffi:def-enum mysql-net-type + (:tcp-ip + :socket + :named-pipe)) + +(uffi:def-struct mysql-net + (vio :pointer-void) + (fd mysql-socket) + (fcntl :int) + (buff (* :unsigned-char)) + (buff-end (* :unsigned-char)) + (write-pos (* :unsigned-char)) + (read-pos (* :unsigned-char)) + (last-error (:array :char 200)) + (last-errno :unsigned-int) + (max-packet :unsigned-int) + (timeout :unsigned-int) + (pkt-nr :unsigned-int) + (error mysql-bool) + (return-errno mysql-bool) + (compress mysql-bool) + (no-send-ok mysql-bool) + (remain-in-buf :unsigned-long) + (length :unsigned-long) + (buf-length :unsigned-long) + (where-b :unsigned-long) + (return-status (* :unsigned-int)) + (reading-or-writing :unsigned-char) + (save-char :char)) + +;;; Mem-Root +(uffi:def-struct mysql-used-mem + (next :pointer-self) + (left :unsigned-int) + (size :unsigned-int)) + +(uffi:def-struct mysql-mem-root + (free (* mysql-used-mem)) + (used (* mysql-used-mem)) + (pre-alloc (* mysql-used-mem)) + (min-alloc :unsigned-int) + (block-size :unsigned-int) + (error-handler :pointer-void)) + +;;; MYSQL-FIELD +(uffi:def-enum mysql-field-types + (:decimal + :tiny + :short + :long + :float + :double + :null + :timestamp + :longlong + :int24 + :date + :time + :datetime + :year + :newdate + (:enum 247) + (:set 248) + (:tiny-blob 249) + (:medium-blob 250) + (:long-blob 251) + (:blob 252) + (:var-string 253) + (:string 254))) + +(uffi:def-struct mysql-field + (name (* :char)) + (table (* :char)) + (def (* :char)) + (type mysql-field-types) + (length :unsigned-int) + (max-length :unsigned-int) + (flags :unsigned-int) + (decimals :unsigned-int)) + +;;; MYSQL-ROWS + +(uffi:def-array-pointer mysql-row (* :unsigned-char)) + +(uffi:def-foreign-type mysql-field-offset :unsigned-int) + +(uffi:def-struct mysql-rows + (next :pointer-self) + (data mysql-row)) + +(uffi:def-foreign-type mysql-row-offset (* mysql-rows)) + +(uffi:def-struct mysql-data + (rows-high32 :unsigned-long) + (rows-low32 :unsigned-long) + (fields :unsigned-int) + (data (* mysql-rows)) + (alloc mysql-mem-root)) + +;;; MYSQL +(uffi:def-struct mysql-options + (connect-timeout :unsigned-int) + (client-flag :unsigned-int) + (compress mysql-bool) + (named-pipe mysql-bool) + (port :unsigned-int) + (host (* :char)) + (init-command (* :char)) + (user (* :char)) + (password (* :char)) + (unix-socket (* :char)) + (db (* :char)) + (my-cnf-file (* :char)) + (my-cnf-group (* :char)) + (charset-dir (* :char)) + (charset-name (* :char)) + (use-ssl mysql-bool) + (ssl-key (* :char)) + (ssl-cert (* :char)) + (ssl-ca (* :char)) + (ssl-capath (* :char))) + +(uffi:def-enum mysql-option + (:connect-timeout + :compress + :named-pipe + :init-command + :read-default-file + :read-default-group)) + +(uffi:def-enum mysql-status + (:ready + :get-result + :use-result)) + +(uffi:def-struct mysql-mysql + (net mysql-net) + (connected-fd (* :char)) + (host (* :char)) + (user (* :char)) + (passwd (* :char)) + (unix-socket (* :char)) + (server-version (* :char)) + (host-info (* :char)) + (info (* :char)) + (db (* :char)) + (port :unsigned-int) + (client-flag :unsigned-int) + (server-capabilities :unsigned-int) + (protocol-version :unsigned-int) + (field-count :unsigned-int) + (server-status :unsigned-int) + (thread-id :unsigned-long) + (affected-rows-high32 :unsigned-long) + (affected-rows-low32 :unsigned-long) + (insert-id-high32 :unsigned-long) + (insert-id-low32 :unsigned-long) + (extra-info-high32 :unsigned-long) + (extra-info-low32 :unsigned-long) + (packet-length :unsigned-long) + (status mysql-status) + (fields (* mysql-field)) + (field-alloc mysql-mem-root) + (free-me mysql-bool) + (reconnect mysql-bool) + (options mysql-options) + (scramble-buff (:array :char 9)) + (charset :pointer-void) + (server-language :unsigned-int)) + + +;;; MYSQL-RES +(uffi:def-struct mysql-mysql-res + (row-count-high32 :unsigned-long) + (row-count-low32 :unsigned-long) + (field-count :unsigned-int) + (current-field :unsigned-int) + (fields (* mysql-field)) + (data (* mysql-data)) + (data-cursor (* mysql-rows)) + (field-alloc mysql-mem-root) + (row mysql-row) + (current-row mysql-row) + (lengths (* :unsigned-long)) + (handle (* mysql-mysql)) + (eof mysql-bool)) + +;;;; The Foreign C routines +(declaim (inline mysql-init)) +(uffi:def-function "mysql_init" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql)) + +(declaim (inline mysql-connect)) +(uffi:def-function "mysql_connect" + ((mysql (* mysql-mysql)) + (host :cstring) + (user :cstring) + (passwd :cstring)) + :module "mysql" + :returning (* mysql-mysql)) + +(declaim (inline mysql-real-connect)) +(uffi:def-function "mysql_real_connect" + ((mysql (* mysql-mysql)) + (host :cstring) + (user :cstring) + (passwd :cstring) + (db :cstring) + (port :unsigned-int) + (unix-socket :cstring) + (clientflag :unsigned-int)) + :module "mysql" + :returning (* mysql-mysql)) + +(declaim (inline mysql-close)) +(uffi:def-function "mysql_close" + ((sock (* mysql-mysql))) + :module "mysql" + :returning :void) + +(declaim (inline mysql-select-db)) +(uffi:def-function "mysql_select_db" + ((mysql (* mysql-mysql)) + (db :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-query)) +(uffi:def-function "mysql_query" + ((mysql (* mysql-mysql)) + (query :cstring)) + :module "mysql" + :returning :int) + + ;;; I doubt that this function is really useful for direct Lisp usage, +;;; but it is here for completeness... + +(declaim (inline mysql-real-query)) +(uffi:def-function "mysql_real_query" + ((mysql (* mysql-mysql)) + (query :cstring) + (length :unsigned-int)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-create-db)) +(uffi:def-function "mysql_create_db" + ((mysql (* mysql-mysql)) + (db :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-drop-db)) +(uffi:def-function "mysql_drop_db" + ((mysql (* mysql-mysql)) + (db :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-shutdown)) +(uffi:def-function "mysql_shutdown" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :int) + +(declaim (inline mysql-dump-debug-info)) +(uffi:def-function "mysql_dump_debug_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :int) + +(declaim (inline mysql-refresh)) +(uffi:def-function "mysql_refresh" + ((mysql (* mysql-mysql)) + (refresh-options :unsigned-int)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-kill)) +(uffi:def-function "mysql_kill" + ((mysql (* mysql-mysql)) + (pid :unsigned-long)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-ping)) +(uffi:def-function "mysql_ping" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :int) + +(declaim (inline mysql-stat)) +(uffi:def-function "mysql_stat" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-server-info)) +(uffi:def-function "mysql_get_server_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-client-info)) +(uffi:def-function "mysql_get_client_info" + () + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-host-info)) +(uffi:def-function "mysql_get_host_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :cstring) + +(declaim (inline mysql-get-proto-info)) +(uffi:def-function "mysql_get_proto_info" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning :unsigned-int) + +(declaim (inline mysql-list-dbs)) +(uffi:def-function "mysql_list_dbs" + ((mysql (* mysql-mysql)) + (wild :cstring)) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-list-tables)) +(uffi:def-function "mysql_list_tables" + ((mysql (* mysql-mysql)) + (wild :cstring)) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-list-fields)) +(uffi:def-function "mysql_list_fields" + ((mysql (* mysql-mysql)) + (table :cstring) + (wild :cstring)) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-list-processes)) +(uffi:def-function "mysql_list_processes" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-store-result)) +(uffi:def-function "mysql_store_result" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-use-result)) +(uffi:def-function "mysql_use_result" + ((mysql (* mysql-mysql))) + :module "mysql" + :returning (* mysql-mysql-res)) + +(declaim (inline mysql-options)) +(uffi:def-function "mysql_options" + ((mysql (* mysql-mysql)) + (option mysql-option) + (arg :cstring)) + :module "mysql" + :returning :int) + +(declaim (inline mysql-free-result)) +(uffi:def-function "mysql_free_result" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning :void) + +(declaim (inline mysql-row-seek)) +(uffi:def-function "mysql_row_seek" + ((res (* mysql-mysql-res)) + (offset mysql-row-offset)) + :module "mysql" + :returning mysql-row-offset) + +(declaim (inline mysql-field-seek)) +(uffi:def-function "mysql_field_seek" + ((res (* mysql-mysql-res)) + (offset mysql-field-offset)) + :module "mysql" + :returning mysql-field-offset) + +(declaim (inline mysql-fetch-row)) +(uffi:def-function "mysql_fetch_row" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning mysql-row) + +(declaim (inline mysql-fetch-lengths)) +(uffi:def-function "mysql_fetch_lengths" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning (* :unsigned-long)) + +(declaim (inline mysql-fetch-field)) +(uffi:def-function "mysql_fetch_field" + ((res (* mysql-mysql-res))) + :module "mysql" + :returning (* mysql-field)) + +(declaim (inline mysql-escape-string)) +(uffi:def-function "mysql_escape_string" + ((to :cstring) + (from :cstring) + (length :unsigned-int)) + :module "mysql" + :returning :unsigned-int) + +(declaim (inline mysql-debug)) +(uffi:def-function "mysql_debug" + ((debug :cstring)) + :module "mysql" + :returning :void) + +(declaim (inline clsql-mysql-num-rows)) +(uffi:def-function "clsql_mysql_num_rows" + ((res (* mysql-mysql-res)) + (p-high32 (* :unsigned-int))) + :module "clsql-mysql" + :returning :unsigned-int) + + +;;;; Equivalents of C Macro definitions for accessing various fields +;;;; in the internal MySQL Datastructures + +(uffi:def-constant +2^32+ 4294967296) +(uffi:def-constant +2^32-1+ (1- +2^32+)) + +(defmacro make-64-bit-integer (high32 low32) + `(+ ,low32 (* ,high32 +2^32+))) + +(declaim (inline mysql-num-rows)) +(defun mysql-num-rows (res) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-num-rows res p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + +(uffi:def-function "clsql_mysql_affected_rows" + ((mysql (* mysql-mysql)) + (p-high32 (* :unsigned-int))) + :returning :unsigned-int + :module "clsql-mysql") + +(defun mysql-affected-rows (mysql) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-affected-rows mysql p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + +(uffi:def-function "clsql_mysql_insert_id" + ((res (* mysql-mysql)) + (p-high32 (* :unsigned-int))) + :returning :unsigned-int + :module "clsql-mysql") + +(defun mysql-insert-id (mysql) + (uffi:with-foreign-object (p-high32 :unsigned-int) + (let ((low32 (clsql-mysql-insert-id mysql p-high32)) + (high32 (uffi:deref-pointer p-high32 :unsigned-int))) + (if (zerop high32) + low32 + (make-64-bit-integer high32 low32))))) + + +(declaim (inline mysql-num-fields)) +(uffi:def-function "mysql_num_fields" + ((res (* mysql-mysql-res))) + :returning :unsigned-int + :module "mysql") + +(declaim (inline clsql-mysql-eof)) +(uffi:def-function ("mysql_eof" clsql-mysql-eof) + ((res (* mysql-mysql-res))) + :returning :char + :module "mysql") + +(declaim (inline mysql-eof)) +(defun mysql-eof (res) + (if (zerop (clsql-mysql-eof res)) + nil + t)) + +(declaim (inline mysql-error)) +(uffi:def-function ("mysql_error" mysql-error) + ((mysql (* mysql-mysql))) + :returning :cstring + :module "mysql") + +(declaim (inline mysql-error-string)) +(defun mysql-error-string (mysql) + (uffi:convert-from-cstring (mysql-error mysql))) + +(declaim (inline mysql-errno)) +(uffi:def-function "mysql_errno" + ((mysql (* mysql-mysql))) + :returning :unsigned-int + :module "mysql") + +(declaim (inline mysql-info)) +(uffi:def-function ("mysql_info" mysql-info) + ((mysql (* mysql-mysql))) + :returning :cstring + :module "mysql") + +(declaim (inline mysql-info-string)) +(defun mysql-info-string (mysql) + (uffi:convert-from-cstring (mysql-info mysql))) + +(declaim (inline clsql-mysql-data-seek)) +(uffi:def-function "clsql_mysql_data_seek" + ((res (* mysql-mysql-res)) + (offset-high32 :unsigned-int) + (offset-low32 :unsigned-int)) + :module "clsql-mysql" + :returning :void) + + +(declaim (inline split-64bit-integer)) +(defun split-64bit-integer (int64) + (values (ash int64 -32) (logand int64 +2^32-1+))) + +(defun mysql-data-seek (res offset) + (multiple-value-bind (high32 low32) (split-64bit-integer offset) + (clsql-mysql-data-seek res high32 low32))) + diff --git a/interfaces/mysql/mysql-sql.cl b/interfaces/mysql/mysql-sql.cl index 20cac08..37b88eb 100644 --- a/interfaces/mysql/mysql-sql.cl +++ b/interfaces/mysql/mysql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: mysql-sql.cl,v 1.1 2002/03/23 14:04:52 kevin Exp $ +;;;; $Id: mysql-sql.cl,v 1.2 2002/03/23 17:07:40 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -63,29 +63,29 @@ :connection-spec connection-spec :errno (mysql-errno mysql-ptr) :error (mysql-error-string mysql-ptr)) - (uffi:with-cstring (host-native host) - (uffi:with-cstring (user-native user) - (uffi:with-cstring (password-native password) - (uffi:with-cstring (db-native db) - (uffi:with-cstring (socket-native socket) - (let ((error-occurred nil)) - (unwind-protect - (if (uffi:null-pointer-p - (mysql-real-connect - mysql-ptr host-native user-native password-native - db-native 0 socket-native 0)) - (progn - (setq error-occurred t) - (error 'clsql-connect-error - :database-type database-type - :connection-spec connection-spec - :errno (mysql-errno mysql-ptr) - :error (mysql-error-string mysql-ptr))) - (make-instance 'mysql-database - :name (database-name-from-spec connection-spec - database-type) - :mysql-ptr mysql-ptr)) - (when error-occurred (mysql-close mysql-ptr))))))))))))) + (uffi:with-cstrings ((host-native host) + (user-native user) + (password-native password) + (db-native db) + (socket-native socket)) + (let ((error-occurred nil)) + (unwind-protect + (if (uffi:null-pointer-p + (mysql-real-connect + mysql-ptr host-native user-native password-native + db-native 0 socket-native 0)) + (progn + (setq error-occurred t) + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno (mysql-errno mysql-ptr) + :error (mysql-error-string mysql-ptr))) + (make-instance 'mysql-database + :name (database-name-from-spec connection-spec + database-type) + :mysql-ptr mysql-ptr)) + (when error-occurred (mysql-close mysql-ptr))))))))) (defmethod database-disconnect ((database mysql-database)) diff --git a/interfaces/mysql/mysql-uffi.cl b/interfaces/mysql/mysql-uffi.cl deleted file mode 100644 index db33d9d..0000000 --- a/interfaces/mysql/mysql-uffi.cl +++ /dev/null @@ -1,579 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: mysql.cl -;;;; Purpose: Low-level MySQL interface using UFFI -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: mysql-uffi.cl,v 1.1 2002/03/23 14:04:53 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) - -(in-package :mysql) - -;;;; Modifications from original code -;;;; - Updated C-structures to conform to structures in MySQL 3.23.46 -;;;; - Changed from CMUCL interface to UFFI -;;;; - Added and call a C-helper file to support 64-bit integers -;;;; that are used in a few routines. -;;;; - Removed all references to interiors of C-structions, this will -;;;; increase robustness when MySQL's internal structures change. - -;;;; Type definitions - -;;; Basic Types - -(uffi:def-foreign-type mysql-socket :int) -(uffi:def-foreign-type mysql-bool :char) -(uffi:def-foreign-type mysql-byte :unsigned-char) - -(uffi:def-enum mysql-net-type - (:tcp-ip - :socket - :named-pipe)) - -(uffi:def-struct mysql-net - (vio :pointer-void) - (fd mysql-socket) - (fcntl :int) - (buff (* :unsigned-char)) - (buff-end (* :unsigned-char)) - (write-pos (* :unsigned-char)) - (read-pos (* :unsigned-char)) - (last-error (:array :char 200)) - (last-errno :unsigned-int) - (max-packet :unsigned-int) - (timeout :unsigned-int) - (pkt-nr :unsigned-int) - (error mysql-bool) - (return-errno mysql-bool) - (compress mysql-bool) - (no-send-ok mysql-bool) - (remain-in-buf :unsigned-long) - (length :unsigned-long) - (buf-length :unsigned-long) - (where-b :unsigned-long) - (return-status (* :unsigned-int)) - (reading-or-writing :unsigned-char) - (save-char :char)) - -;;; Mem-Root -(uffi:def-struct mysql-used-mem - (next :pointer-self) - (left :unsigned-int) - (size :unsigned-int)) - -(uffi:def-struct mysql-mem-root - (free (* mysql-used-mem)) - (used (* mysql-used-mem)) - (pre-alloc (* mysql-used-mem)) - (min-alloc :unsigned-int) - (block-size :unsigned-int) - (error-handler :pointer-void)) - -;;; MYSQL-FIELD -(uffi:def-enum mysql-field-types - (:decimal - :tiny - :short - :long - :float - :double - :null - :timestamp - :longlong - :int24 - :date - :time - :datetime - :year - :newdate - (:enum 247) - (:set 248) - (:tiny-blob 249) - (:medium-blob 250) - (:long-blob 251) - (:blob 252) - (:var-string 253) - (:string 254))) - -(uffi:def-struct mysql-field - (name (* :char)) - (table (* :char)) - (def (* :char)) - (type mysql-field-types) - (length :unsigned-int) - (max-length :unsigned-int) - (flags :unsigned-int) - (decimals :unsigned-int)) - -;;; MYSQL-ROWS - -(uffi:def-array-pointer mysql-row (* :unsigned-char)) - -(uffi:def-foreign-type mysql-field-offset :unsigned-int) - -(uffi:def-struct mysql-rows - (next :pointer-self) - (data mysql-row)) - -(uffi:def-foreign-type mysql-row-offset (* mysql-rows)) - -(uffi:def-struct mysql-data - (rows-high32 :unsigned-long) - (rows-low32 :unsigned-long) - (fields :unsigned-int) - (data (* mysql-rows)) - (alloc mysql-mem-root)) - -;;; MYSQL -(uffi:def-struct mysql-options - (connect-timeout :unsigned-int) - (client-flag :unsigned-int) - (compress mysql-bool) - (named-pipe mysql-bool) - (port :unsigned-int) - (host (* :char)) - (init-command (* :char)) - (user (* :char)) - (password (* :char)) - (unix-socket (* :char)) - (db (* :char)) - (my-cnf-file (* :char)) - (my-cnf-group (* :char)) - (charset-dir (* :char)) - (charset-name (* :char)) - (use-ssl mysql-bool) - (ssl-key (* :char)) - (ssl-cert (* :char)) - (ssl-ca (* :char)) - (ssl-capath (* :char))) - -(uffi:def-enum mysql-option - (:connect-timeout - :compress - :named-pipe - :init-command - :read-default-file - :read-default-group)) - -(uffi:def-enum mysql-status - (:ready - :get-result - :use-result)) - -(uffi:def-struct mysql-mysql - (net mysql-net) - (connected-fd (* :char)) - (host (* :char)) - (user (* :char)) - (passwd (* :char)) - (unix-socket (* :char)) - (server-version (* :char)) - (host-info (* :char)) - (info (* :char)) - (db (* :char)) - (port :unsigned-int) - (client-flag :unsigned-int) - (server-capabilities :unsigned-int) - (protocol-version :unsigned-int) - (field-count :unsigned-int) - (server-status :unsigned-int) - (thread-id :unsigned-long) - (affected-rows-high32 :unsigned-long) - (affected-rows-low32 :unsigned-long) - (insert-id-high32 :unsigned-long) - (insert-id-low32 :unsigned-long) - (extra-info-high32 :unsigned-long) - (extra-info-low32 :unsigned-long) - (packet-length :unsigned-long) - (status mysql-status) - (fields (* mysql-field)) - (field-alloc mysql-mem-root) - (free-me mysql-bool) - (reconnect mysql-bool) - (options mysql-options) - (scramble-buff (:array :char 9)) - (charset :pointer-void) - (server-language :unsigned-int)) - - -;;; MYSQL-RES -(uffi:def-struct mysql-mysql-res - (row-count-high32 :unsigned-long) - (row-count-low32 :unsigned-long) - (field-count :unsigned-int) - (current-field :unsigned-int) - (fields (* mysql-field)) - (data (* mysql-data)) - (data-cursor (* mysql-rows)) - (field-alloc mysql-mem-root) - (row mysql-row) - (current-row mysql-row) - (lengths (* :unsigned-long)) - (handle (* mysql-mysql)) - (eof mysql-bool)) - -;;;; The Foreign C routines -(declaim (inline mysql-init)) -(uffi:def-function "mysql_init" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning (* mysql-mysql)) - -(declaim (inline mysql-connect)) -(uffi:def-function "mysql_connect" - ((mysql (* mysql-mysql)) - (host :cstring) - (user :cstring) - (passwd :cstring)) - :module "mysql" - :returning (* mysql-mysql)) - -(declaim (inline mysql-real-connect)) -(uffi:def-function "mysql_real_connect" - ((mysql (* mysql-mysql)) - (host :cstring) - (user :cstring) - (passwd :cstring) - (db :cstring) - (port :unsigned-int) - (unix-socket :cstring) - (clientflag :unsigned-int)) - :module "mysql" - :returning (* mysql-mysql)) - -(declaim (inline mysql-close)) -(uffi:def-function "mysql_close" - ((sock (* mysql-mysql))) - :module "mysql" - :returning :void) - -(declaim (inline mysql-select-db)) -(uffi:def-function "mysql_select_db" - ((mysql (* mysql-mysql)) - (db :cstring)) - :module "mysql" - :returning :int) - -(declaim (inline mysql-query)) -(uffi:def-function "mysql_query" - ((mysql (* mysql-mysql)) - (query :cstring)) - :module "mysql" - :returning :int) - - ;;; I doubt that this function is really useful for direct Lisp usage, -;;; but it is here for completeness... - -(declaim (inline mysql-real-query)) -(uffi:def-function "mysql_real_query" - ((mysql (* mysql-mysql)) - (query :cstring) - (length :unsigned-int)) - :module "mysql" - :returning :int) - -(declaim (inline mysql-create-db)) -(uffi:def-function "mysql_create_db" - ((mysql (* mysql-mysql)) - (db :cstring)) - :module "mysql" - :returning :int) - -(declaim (inline mysql-drop-db)) -(uffi:def-function "mysql_drop_db" - ((mysql (* mysql-mysql)) - (db :cstring)) - :module "mysql" - :returning :int) - -(declaim (inline mysql-shutdown)) -(uffi:def-function "mysql_shutdown" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning :int) - -(declaim (inline mysql-dump-debug-info)) -(uffi:def-function "mysql_dump_debug_info" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning :int) - -(declaim (inline mysql-refresh)) -(uffi:def-function "mysql_refresh" - ((mysql (* mysql-mysql)) - (refresh-options :unsigned-int)) - :module "mysql" - :returning :int) - -(declaim (inline mysql-kill)) -(uffi:def-function "mysql_kill" - ((mysql (* mysql-mysql)) - (pid :unsigned-long)) - :module "mysql" - :returning :int) - -(declaim (inline mysql-ping)) -(uffi:def-function "mysql_ping" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning :int) - -(declaim (inline mysql-stat)) -(uffi:def-function "mysql_stat" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning :cstring) - -(declaim (inline mysql-get-server-info)) -(uffi:def-function "mysql_get_server_info" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning :cstring) - -(declaim (inline mysql-get-client-info)) -(uffi:def-function "mysql_get_client_info" - () - :module "mysql" - :returning :cstring) - -(declaim (inline mysql-get-host-info)) -(uffi:def-function "mysql_get_host_info" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning :cstring) - -(declaim (inline mysql-get-proto-info)) -(uffi:def-function "mysql_get_proto_info" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning :unsigned-int) - -(declaim (inline mysql-list-dbs)) -(uffi:def-function "mysql_list_dbs" - ((mysql (* mysql-mysql)) - (wild :cstring)) - :module "mysql" - :returning (* mysql-mysql-res)) - -(declaim (inline mysql-list-tables)) -(uffi:def-function "mysql_list_tables" - ((mysql (* mysql-mysql)) - (wild :cstring)) - :module "mysql" - :returning (* mysql-mysql-res)) - -(declaim (inline mysql-list-fields)) -(uffi:def-function "mysql_list_fields" - ((mysql (* mysql-mysql)) - (table :cstring) - (wild :cstring)) - :module "mysql" - :returning (* mysql-mysql-res)) - -(declaim (inline mysql-list-processes)) -(uffi:def-function "mysql_list_processes" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning (* mysql-mysql-res)) - -(declaim (inline mysql-store-result)) -(uffi:def-function "mysql_store_result" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning (* mysql-mysql-res)) - -(declaim (inline mysql-use-result)) -(uffi:def-function "mysql_use_result" - ((mysql (* mysql-mysql))) - :module "mysql" - :returning (* mysql-mysql-res)) - -(declaim (inline mysql-options)) -(uffi:def-function "mysql_options" - ((mysql (* mysql-mysql)) - (option mysql-option) - (arg :cstring)) - :module "mysql" - :returning :int) - -(declaim (inline mysql-free-result)) -(uffi:def-function "mysql_free_result" - ((res (* mysql-mysql-res))) - :module "mysql" - :returning :void) - -(declaim (inline mysql-row-seek)) -(uffi:def-function "mysql_row_seek" - ((res (* mysql-mysql-res)) - (offset mysql-row-offset)) - :module "mysql" - :returning mysql-row-offset) - -(declaim (inline mysql-field-seek)) -(uffi:def-function "mysql_field_seek" - ((res (* mysql-mysql-res)) - (offset mysql-field-offset)) - :module "mysql" - :returning mysql-field-offset) - -(declaim (inline mysql-fetch-row)) -(uffi:def-function "mysql_fetch_row" - ((res (* mysql-mysql-res))) - :module "mysql" - :returning mysql-row) - -(declaim (inline mysql-fetch-lengths)) -(uffi:def-function "mysql_fetch_lengths" - ((res (* mysql-mysql-res))) - :module "mysql" - :returning (* :unsigned-long)) - -(declaim (inline mysql-fetch-field)) -(uffi:def-function "mysql_fetch_field" - ((res (* mysql-mysql-res))) - :module "mysql" - :returning (* mysql-field)) - -(declaim (inline mysql-escape-string)) -(uffi:def-function "mysql_escape_string" - ((to :cstring) - (from :cstring) - (length :unsigned-int)) - :module "mysql" - :returning :unsigned-int) - -(declaim (inline mysql-debug)) -(uffi:def-function "mysql_debug" - ((debug :cstring)) - :module "mysql" - :returning :void) - -(declaim (inline clsql-mysql-num-rows)) -(uffi:def-function "clsql_mysql_num_rows" - ((res (* mysql-mysql-res)) - (p-high32 (* :unsigned-int))) - :module "clsql-mysql" - :returning :unsigned-int) - - -;;;; Equivalents of C Macro definitions for accessing various fields -;;;; in the internal MySQL Datastructures - -(uffi:def-constant +2^32+ 4294967296) -(uffi:def-constant +2^32-1+ (1- +2^32+)) - -(defmacro make-64-bit-integer (high32 low32) - `(+ ,low32 (* ,high32 +2^32+))) - -(declaim (inline mysql-num-rows)) -(defun mysql-num-rows (res) - (uffi:with-foreign-object (p-high32 :unsigned-int) - (let ((low32 (clsql-mysql-num-rows res p-high32)) - (high32 (uffi:deref-pointer p-high32 :unsigned-int))) - (if (zerop high32) - low32 - (make-64-bit-integer high32 low32))))) - -(uffi:def-function "clsql_mysql_affected_rows" - ((mysql (* mysql-mysql)) - (p-high32 (* :unsigned-int))) - :returning :unsigned-int - :module "clsql-mysql") - -(defun mysql-affected-rows (mysql) - (uffi:with-foreign-object (p-high32 :unsigned-int) - (let ((low32 (clsql-mysql-affected-rows mysql p-high32)) - (high32 (uffi:deref-pointer p-high32 :unsigned-int))) - (if (zerop high32) - low32 - (make-64-bit-integer high32 low32))))) - -(uffi:def-function "clsql_mysql_insert_id" - ((res (* mysql-mysql)) - (p-high32 (* :unsigned-int))) - :returning :unsigned-int - :module "clsql-mysql") - -(defun mysql-insert-id (mysql) - (uffi:with-foreign-object (p-high32 :unsigned-int) - (let ((low32 (clsql-mysql-insert-id mysql p-high32)) - (high32 (uffi:deref-pointer p-high32 :unsigned-int))) - (if (zerop high32) - low32 - (make-64-bit-integer high32 low32))))) - - -(declaim (inline mysql-num-fields)) -(uffi:def-function "mysql_num_fields" - ((res (* mysql-mysql-res))) - :returning :unsigned-int - :module "mysql") - -(declaim (inline clsql-mysql-eof)) -(uffi:def-function ("mysql_eof" clsql-mysql-eof) - ((res (* mysql-mysql-res))) - :returning :char - :module "mysql") - -(declaim (inline mysql-eof)) -(defun mysql-eof (res) - (if (zerop (clsql-mysql-eof res)) - nil - t)) - -(declaim (inline mysql-error)) -(uffi:def-function ("mysql_error" mysql-error) - ((mysql (* mysql-mysql))) - :returning :cstring - :module "mysql") - -(declaim (inline mysql-error-string)) -(defun mysql-error-string (mysql) - (uffi:convert-from-cstring (mysql-error mysql))) - -(declaim (inline mysql-errno)) -(uffi:def-function "mysql_errno" - ((mysql (* mysql-mysql))) - :returning :unsigned-int - :module "mysql") - -(declaim (inline mysql-info)) -(uffi:def-function ("mysql_info" mysql-info) - ((mysql (* mysql-mysql))) - :returning :cstring - :module "mysql") - -(declaim (inline mysql-info-string)) -(defun mysql-info-string (mysql) - (uffi:convert-from-cstring (mysql-info mysql))) - -(declaim (inline clsql-mysql-data-seek)) -(uffi:def-function "clsql_mysql_data_seek" - ((res (* mysql-mysql-res)) - (offset-high32 :unsigned-int) - (offset-low32 :unsigned-int)) - :module "clsql-mysql" - :returning :void) - - -(declaim (inline split-64bit-integer)) -(defun split-64bit-integer (int64) - (values (ash int64 -32) (logand int64 +2^32-1+))) - -(defun mysql-data-seek (res offset) - (multiple-value-bind (high32 low32) (split-64bit-integer offset) - (clsql-mysql-data-seek res high32 low32))) - diff --git a/interfaces/postgresql-socket/postgresql-socket-api.cl b/interfaces/postgresql-socket/postgresql-socket-api.cl new file mode 100644 index 0000000..c97eda1 --- /dev/null +++ b/interfaces/postgresql-socket/postgresql-socket-api.cl @@ -0,0 +1,686 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket.cl +;;;; Purpose: Low-level PostgreSQL interface using sockets +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-socket-api.cl,v 1.1 2002/03/23 17:10:48 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and Copyright (c) 1999-2001 by Pierre R. Mai +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +;;;; Changes by Kevin Rosenberg +;;;; - Added socket open functions for Allegro and Lispworks +;;;; - Changed CMUCL FFI to UFFI +;;;; - Added necessary (force-output) for socket streams on +;;;; Allegro and Lispworks + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :postgresql-socket) + + +;;; Message I/O stuff + +(defmacro define-message-constants (description &rest clauses) + (assert (evenp (length clauses))) + (loop with seen-characters = nil + for (name char) on clauses by #'cddr + for char-code = (char-code char) + for doc-string = (format nil "~A (~:C): ~A" description char name) + if (member char seen-characters) + do (error "Duplicate message type ~@C for group ~A" char description) + else + collect + `(defconstant ,name ,char-code ,doc-string) + into result-clauses + and do (push char seen-characters) + finally + (return `(progn ,@result-clauses)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(define-message-constants "Backend Message Constants" + +ascii-row-message+ #\D + +authentication-message+ #\R + +backend-key-message+ #\K + +binary-row-message+ #\B + +completed-response-message+ #\C + +copy-in-response-message+ #\G + +copy-out-response-message+ #\H + +cursor-response-message+ #\P + +empty-query-response-message+ #\I + +error-response-message+ #\E + +function-response-message+ #\V + +notice-response-message+ #\N + +notification-response-message+ #\A + +ready-for-query-message+ #\Z + +row-description-message+ #\T)) + +(defgeneric send-socket-value (type socket value)) + +(defmethod send-socket-value ((type (eql 'int32)) socket (value integer)) + (write-byte (ldb (byte 8 24) value) socket) + (write-byte (ldb (byte 8 16) value) socket) + (write-byte (ldb (byte 8 8) value) socket) + (write-byte (ldb (byte 8 0) value) socket)) + +(defmethod send-socket-value ((type (eql 'int16)) socket (value integer)) + (write-byte (ldb (byte 8 8) value) socket) + (write-byte (ldb (byte 8 0) value) socket)) + +(defmethod send-socket-value ((type (eql 'int8)) socket (value integer)) + (write-byte (ldb (byte 8 0) value) socket)) + +(defmethod send-socket-value ((type (eql 'string)) socket (value string)) + (loop for char across value + for code = (char-code char) + do (write-byte code socket) + finally (write-byte 0 socket))) + +(defmethod send-socket-value ((type (eql 'limstring)) socket (value string)) + (loop for char across value + for code = (char-code char) + do (write-byte code socket))) + +(defmethod send-socket-value ((type (eql 'byte)) socket (value integer)) + (write-byte value socket)) + +(defmethod send-socket-value ((type (eql 'byte)) socket (value character)) + (write-byte (char-code value) socket)) + +(defmethod send-socket-value ((type (eql 'byte)) socket value) + (write-sequence value socket)) + +(defgeneric read-socket-value (type socket)) + +(defmethod read-socket-value ((type (eql 'int32)) socket) + (let ((result 0)) + (setf (ldb (byte 8 24) result) (read-byte socket)) + (setf (ldb (byte 8 16) result) (read-byte socket)) + (setf (ldb (byte 8 8) result) (read-byte socket)) + (setf (ldb (byte 8 0) result) (read-byte socket)) + result)) + +(defmethod read-socket-value ((type (eql 'int16)) socket) + (let ((result 0)) + (setf (ldb (byte 8 8) result) (read-byte socket)) + (setf (ldb (byte 8 0) result) (read-byte socket)) + result)) + +(defmethod read-socket-value ((type (eql 'int8)) socket) + (read-byte socket)) + +(defmethod read-socket-value ((type (eql 'string)) socket) + (with-output-to-string (out) + (loop for code = (read-byte socket) + until (zerop code) + do (write-char (code-char code) out)))) + +(defgeneric skip-socket-value (type socket)) + +(defmethod skip-socket-value ((type (eql 'int32)) socket) + (dotimes (i 4) (read-byte socket))) + +(defmethod skip-socket-value ((type (eql 'int16)) socket) + (dotimes (i 2) (read-byte socket))) + +(defmethod skip-socket-value ((type (eql 'int8)) socket) + (read-byte socket)) + +(defmethod skip-socket-value ((type (eql 'string)) socket) + (loop until (zerop (read-byte socket)))) + +(defmacro define-message-sender (name (&rest args) &rest clauses) + (loop with socket-var = (gensym) + for (type value) in clauses + collect + `(send-socket-value ',type ,socket-var ,value) + into body + finally + (return + `(defun ,name (,socket-var ,@args) + ,@body)))) + +(defun pad-limstring (string limit) + (let ((result (make-string limit :initial-element #\NULL))) + (loop for char across string + for index from 0 below limit + do (setf (char result index) char)) + result)) + +(define-message-sender send-startup-message + (database user &optional (command-line "") (backend-tty "")) + (int32 296) ; Length + (int32 #x00020000) ; Version 2.0 + (limstring (pad-limstring database 64)) + (limstring (pad-limstring user 32)) + (limstring (pad-limstring command-line 64)) + (limstring (pad-limstring "" 64)) ; Unused + (limstring (pad-limstring backend-tty 64))) + +(define-message-sender send-terminate-message () + (byte #\X)) + +(define-message-sender send-unencrypted-password-message (password) + (int32 (+ 5 (length password))) + (string password)) + +(define-message-sender send-query-message (query) + (byte #\Q) + (string query)) + +(define-message-sender send-encrypted-password-message (crypted-password) + (int32 (+ 5 (length crypted-password))) + (string crypted-password)) + +(define-message-sender send-cancel-request (pid key) + (int32 16) ; Length + (int32 80877102) ; Magic + (int32 pid) + (int32 key)) + + +(defun read-socket-sequence (string stream) +"KMR -- Added to support reading from binary stream into a string" + (declare (optimize (speed 3) (safety 0))) + (dotimes (i (length string)) + (declare (fixnum i)) + (setf (char string i) (code-char (read-byte stream)))) + string) + + +;;; Support for encrypted password transmission + +(defconstant +crypt-library+ "/usr/lib/libcrypt.so" + "Name of the shared library to load in order to access the crypt +function named by `*crypt-function-name*'.") + +(defvar *crypt-library-loaded* nil) + +(defun crypt-password (password salt) + "Encrypt a password for transmission to a PostgreSQL server." + (unless *crypt-library-loaded* + (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c")) + (eval (uffi:def-function "crypt" + ((key :cstring) + (salt :cstring)) + :returning :cstring)) + (setq *crypt-library-loaded* t)) + (uffi:with-cstring (password-cstring password) + (uffi:with-cstring (salt-cstring salt) + (uffi:convert-from-cstring (crypt password-cstring salt-cstring))))) +;;; Condition hierarchy + +(define-condition postgresql-condition (condition) + ((connection :initarg :connection :reader postgresql-condition-connection) + (message :initarg :message :reader postgresql-condition-message)) + (:report + (lambda (c stream) + (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>" + (type-of c) + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +(define-condition postgresql-error (error postgresql-condition) + ()) + +(define-condition postgresql-fatal-error (postgresql-error) + ()) + +(define-condition postgresql-login-error (postgresql-fatal-error) + ()) + +(define-condition postgresql-warning (warning postgresql-condition) + ()) + +(define-condition postgresql-notification (postgresql-condition) + () + (:report + (lambda (c stream) + (format stream "~@" + (postgresql-condition-connection c) + (postgresql-condition-message c))))) + +;;; Structures + +(defstruct postgresql-connection + host + port + database + user + password + options + tty + socket + pid + key) + +(defstruct postgresql-cursor + connection + name + fields) + +;;; Socket stuff + +(defconstant +postgresql-server-default-port+ 5432 + "Default port of PostgreSQL server.") + +(defvar *postgresql-server-socket-timeout* 60 + "Timeout in seconds for reads from the PostgreSQL server.") + + +#+cmu +(defun open-postgresql-socket (host port) + (etypecase host + (pathname + ;; Directory to unix-domain socket + (ext:connect-to-unix-socket + (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) + (string + (ext:connect-to-inet-socket host port)))) + +#+cmu +(defun open-postgresql-socket-stream (host port) + (system:make-fd-stream + (open-postgresql-socket host port) + :input t :output t :element-type '(unsigned-byte 8) + :buffering :none + :timeout *postgresql-server-socket-timeout*)) + +#+allegro +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (let ((path (namestring + (make-pathname :name ".s.PGSQL" :type (princ-to-string port) + :defaults host)))) + (socket:make-socket :type :stream :address-family :file + :connect :active + :remote-filename path :local-filename path))) + (string + (socket:with-pending-connect + (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed")) + (socket:make-socket :type :stream :address-family :internet + :remote-port port :remote-host host + :connect :active :nodelay t)))) + )) + +#+lispworks +(defun open-postgresql-socket-stream (host port) + (etypecase host + (pathname + (error "File sockets not supported on Lispworks.")) + (string + (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8) + :read-timeout *postgresql-server-socket-timeout*)) + )) + +;;; Interface Functions + +(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument)) + (port +postgresql-server-default-port+) + (database (cmucl-compat:required-argument)) + (user (cmucl-compat:required-argument)) + options tty password) + "Open a connection to a PostgreSQL server with the given parameters. +Note that host, database and user arguments must be supplied. + +If host is a pathname, it is assumed to name a directory containing +the local unix-domain sockets of the server, with port selecting which +of those sockets to open. If host is a string, it is assumed to be +the name of the host running the PostgreSQL server. In that case a +TCP connection to the given port on that host is opened in order to +communicate with the server. In either case the port argument +defaults to `+postgresql-server-default-port+'. + +Password is the clear-text password to be passed in the authentication +phase to the server. Depending on the server set-up, it is either +passed in the clear, or encrypted via crypt and a server-supplied +salt. In that case the alien function specified by `*crypt-library*' +and `*crypt-function-name*' is used for encryption. + +Note that all the arguments (including the clear-text password +argument) are stored in the `postgresql-connection' structure, in +order to facilitate automatic reconnection in case of communication +troubles." + (reopen-postgresql-connection + (make-postgresql-connection :host host :port port + :options (or options "") :tty (or tty "") + :database database :user user + :password (or password "")))) + +(defun reopen-postgresql-connection (connection) + "Reopen the given PostgreSQL connection. Closes any existing +connection, if it is still open." + (when (postgresql-connection-open-p connection) + (close-postgresql-connection connection)) + (let ((socket (open-postgresql-socket-stream + (postgresql-connection-host connection) + (postgresql-connection-port connection)))) + (unwind-protect + (progn + (setf (postgresql-connection-socket connection) socket) + (send-startup-message socket + (postgresql-connection-database connection) + (postgresql-connection-user connection) + (postgresql-connection-options connection) + (postgresql-connection-tty connection)) + (force-output socket) + (loop + (case (read-socket-value 'int8 socket) + (#.+authentication-message+ + (case (read-socket-value 'int32 socket) + (0 (return)) + ((1 2) + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unsupported Kerberos authentication.")) + (3 + (send-unencrypted-password-message + socket + (postgresql-connection-password connection))) + (4 + (let ((salt (make-string 2))) + (read-socket-sequence salt socket) + (send-encrypted-password-message + socket + (crypt-password + (postgresql-connection-password connection) salt)))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Postmaster expects unknown authentication method.")))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-login-error + :connection connection :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster")))) + ;; Start backend communication + (force-output socket) + (loop + (case (read-socket-value 'int8 socket) + (#.+backend-key-message+ + (setf (postgresql-connection-pid connection) + (read-socket-value 'int32 socket) + (postgresql-connection-key connection) + (read-socket-value 'int32 socket))) + (#.+ready-for-query-message+ + (setq socket nil) + (return connection)) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-login-error + :connection connection + :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (t + (error 'postgresql-login-error + :connection connection + :message + "Received garbled message from Postmaster"))))) + (when socket + (close socket))))) + +(defun close-postgresql-connection (connection &optional abort) + (unless abort + (ignore-errors + (send-terminate-message (postgresql-connection-socket connection)))) + (close (postgresql-connection-socket connection))) + +(defun postgresql-connection-open-p (connection) + (let ((socket (postgresql-connection-socket connection))) + (and socket (streamp socket) (open-stream-p socket)))) + +(defun ensure-open-postgresql-connection (connection) + (unless (postgresql-connection-open-p connection) + (reopen-postgresql-connection connection))) + +(defun process-async-messages (connection) + (assert (postgresql-connection-open-p connection)) + ;; Process any asnychronous messages + (loop with socket = (postgresql-connection-socket connection) + while (listen socket) + do + (case (read-socket-value 'int8 socket) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning :connection connection + :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))) + +(defun start-query-execution (connection query) + (ensure-open-postgresql-connection connection) + (process-async-messages connection) + (send-query-message (postgresql-connection-socket connection) query) + (force-output (postgresql-connection-socket connection))) + +(defun wait-for-query-results (connection) + (assert (postgresql-connection-open-p connection)) + (let ((socket (postgresql-connection-socket connection)) + (cursor-name nil) + (error nil)) + (loop + (case (read-socket-value 'int8 socket) + (#.+completed-response-message+ + (return (values :completed (read-socket-value 'string socket)))) + (#.+cursor-response-message+ + (setq cursor-name (read-socket-value 'string socket))) + (#.+row-description-message+ + (let* ((count (read-socket-value 'int16 socket)) + (fields + (loop repeat count + collect + (list + (read-socket-value 'string socket) + (read-socket-value 'int32 socket) + (read-socket-value 'int16 socket) + (read-socket-value 'int32 socket))))) + (return + (values :cursor + (make-postgresql-cursor :connection connection + :name cursor-name + :fields fields))))) + (#.+copy-in-response-message+ + (return :copy-in)) + (#.+copy-out-response-message+ + (return :copy-out)) + (#.+ready-for-query-message+ + (when error + (error error)) + (return nil)) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (setq error + (make-condition 'postgresql-error + :connection connection :message message)))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend")))))) + +(defun read-null-bit-vector (socket count) + (let ((result (make-array count :element-type 'bit))) + (dotimes (offset (ceiling count 8)) + (loop with byte = (read-byte socket) + for index from (* offset 8) below (min count (* (1+ offset) 8)) + for weight downfrom 7 + do (setf (aref result index) (ldb (byte 1 weight) byte)))) + result)) + +(defun read-cursor-row (cursor) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (assert (postgresql-connection-open-p connection)) + (loop + (let ((code (read-socket-value 'int8 socket))) + (case code + (#.+ascii-row-message+ + (return + (loop with count = (length fields) + with null-vector = (read-null-bit-vector socket count) + repeat count + for null-bit across null-vector + for null-p = (zerop null-bit) + if null-p + collect nil + else + collect + (let* ((length (read-socket-value 'int32 socket)) + (result (make-string (- length 4)))) + (read-socket-sequence result socket) + result)))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value 'string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun copy-cursor-row (cursor sequence) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (assert (= (length fields) (length sequence))) + (loop + (let ((code (read-socket-value 'int8 socket))) + (case code + (#.+ascii-row-message+ + (return + (map-into + sequence + #'(lambda (null-bit) + (if (zerop null-bit) + nil + (let* ((length (read-socket-value 'int32 socket)) + (result (make-string (- length 4)))) + (read-socket-sequence result socket) + result))) + (read-null-bit-vector socket (length sequence))))) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value 'string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun skip-cursor-row (cursor) + (let* ((connection (postgresql-cursor-connection cursor)) + (socket (postgresql-connection-socket connection)) + (fields (postgresql-cursor-fields cursor))) + (loop + (let ((code (read-socket-value 'int8 socket))) + (case code + (#.+ascii-row-message+ + (loop for null-bit across + (read-null-bit-vector socket (length fields)) + do + (unless (zerop null-bit) + (let* ((length (read-socket-value 'int32 socket))) + (loop repeat (- length 4) do (read-byte socket))))) + (return t)) + (#.+binary-row-message+ + (error "NYI")) + (#.+completed-response-message+ + (return (values nil (read-socket-value 'string socket)))) + (#.+error-response-message+ + (let ((message (read-socket-value 'string socket))) + (error 'postgresql-error + :connection connection :message message))) + (#.+notice-response-message+ + (let ((message (read-socket-value 'string socket))) + (warn 'postgresql-warning + :connection connection :message message))) + (#.+notification-response-message+ + (let ((pid (read-socket-value 'int32 socket)) + (message (read-socket-value 'string socket))) + (when (= pid (postgresql-connection-pid connection)) + (signal 'postgresql-notification :connection connection + :message message)))) + (t + (close-postgresql-connection connection) + (error 'postgresql-fatal-error :connection connection + :message "Received garbled message from backend"))))))) + +(defun run-query (connection query) + (start-query-execution connection query) + (multiple-value-bind (status cursor) + (wait-for-query-results connection) + (assert (eq status :cursor)) + (loop for row = (read-cursor-row cursor) + while row + collect row + finally + (wait-for-query-results connection)))) diff --git a/interfaces/postgresql-socket/postgresql-socket-uffi.cl b/interfaces/postgresql-socket/postgresql-socket-uffi.cl deleted file mode 100644 index 1c643c6..0000000 --- a/interfaces/postgresql-socket/postgresql-socket-uffi.cl +++ /dev/null @@ -1,686 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: postgresql-socket.cl -;;;; Purpose: Low-level PostgreSQL interface using sockets -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: postgresql-socket-uffi.cl,v 1.2 2002/03/23 16:42:06 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - - -;;;; Changes by Kevin Rosenberg -;;;; - Added socket open functions for Allegro and Lispworks -;;;; - Changed CMUCL FFI to UFFI -;;;; - Added necessary (force-output) for socket streams on -;;;; Allegro and Lispworks - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :postgresql-socket) - - -;;; Message I/O stuff - -(defmacro define-message-constants (description &rest clauses) - (assert (evenp (length clauses))) - (loop with seen-characters = nil - for (name char) on clauses by #'cddr - for char-code = (char-code char) - for doc-string = (format nil "~A (~:C): ~A" description char name) - if (member char seen-characters) - do (error "Duplicate message type ~@C for group ~A" char description) - else - collect - `(defconstant ,name ,char-code ,doc-string) - into result-clauses - and do (push char seen-characters) - finally - (return `(progn ,@result-clauses)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(define-message-constants "Backend Message Constants" - +ascii-row-message+ #\D - +authentication-message+ #\R - +backend-key-message+ #\K - +binary-row-message+ #\B - +completed-response-message+ #\C - +copy-in-response-message+ #\G - +copy-out-response-message+ #\H - +cursor-response-message+ #\P - +empty-query-response-message+ #\I - +error-response-message+ #\E - +function-response-message+ #\V - +notice-response-message+ #\N - +notification-response-message+ #\A - +ready-for-query-message+ #\Z - +row-description-message+ #\T)) - -(defgeneric send-socket-value (type socket value)) - -(defmethod send-socket-value ((type (eql 'int32)) socket (value integer)) - (write-byte (ldb (byte 8 24) value) socket) - (write-byte (ldb (byte 8 16) value) socket) - (write-byte (ldb (byte 8 8) value) socket) - (write-byte (ldb (byte 8 0) value) socket)) - -(defmethod send-socket-value ((type (eql 'int16)) socket (value integer)) - (write-byte (ldb (byte 8 8) value) socket) - (write-byte (ldb (byte 8 0) value) socket)) - -(defmethod send-socket-value ((type (eql 'int8)) socket (value integer)) - (write-byte (ldb (byte 8 0) value) socket)) - -(defmethod send-socket-value ((type (eql 'string)) socket (value string)) - (loop for char across value - for code = (char-code char) - do (write-byte code socket) - finally (write-byte 0 socket))) - -(defmethod send-socket-value ((type (eql 'limstring)) socket (value string)) - (loop for char across value - for code = (char-code char) - do (write-byte code socket))) - -(defmethod send-socket-value ((type (eql 'byte)) socket (value integer)) - (write-byte value socket)) - -(defmethod send-socket-value ((type (eql 'byte)) socket (value character)) - (write-byte (char-code value) socket)) - -(defmethod send-socket-value ((type (eql 'byte)) socket value) - (write-sequence value socket)) - -(defgeneric read-socket-value (type socket)) - -(defmethod read-socket-value ((type (eql 'int32)) socket) - (let ((result 0)) - (setf (ldb (byte 8 24) result) (read-byte socket)) - (setf (ldb (byte 8 16) result) (read-byte socket)) - (setf (ldb (byte 8 8) result) (read-byte socket)) - (setf (ldb (byte 8 0) result) (read-byte socket)) - result)) - -(defmethod read-socket-value ((type (eql 'int16)) socket) - (let ((result 0)) - (setf (ldb (byte 8 8) result) (read-byte socket)) - (setf (ldb (byte 8 0) result) (read-byte socket)) - result)) - -(defmethod read-socket-value ((type (eql 'int8)) socket) - (read-byte socket)) - -(defmethod read-socket-value ((type (eql 'string)) socket) - (with-output-to-string (out) - (loop for code = (read-byte socket) - until (zerop code) - do (write-char (code-char code) out)))) - -(defgeneric skip-socket-value (type socket)) - -(defmethod skip-socket-value ((type (eql 'int32)) socket) - (dotimes (i 4) (read-byte socket))) - -(defmethod skip-socket-value ((type (eql 'int16)) socket) - (dotimes (i 2) (read-byte socket))) - -(defmethod skip-socket-value ((type (eql 'int8)) socket) - (read-byte socket)) - -(defmethod skip-socket-value ((type (eql 'string)) socket) - (loop until (zerop (read-byte socket)))) - -(defmacro define-message-sender (name (&rest args) &rest clauses) - (loop with socket-var = (gensym) - for (type value) in clauses - collect - `(send-socket-value ',type ,socket-var ,value) - into body - finally - (return - `(defun ,name (,socket-var ,@args) - ,@body)))) - -(defun pad-limstring (string limit) - (let ((result (make-string limit :initial-element #\NULL))) - (loop for char across string - for index from 0 below limit - do (setf (char result index) char)) - result)) - -(define-message-sender send-startup-message - (database user &optional (command-line "") (backend-tty "")) - (int32 296) ; Length - (int32 #x00020000) ; Version 2.0 - (limstring (pad-limstring database 64)) - (limstring (pad-limstring user 32)) - (limstring (pad-limstring command-line 64)) - (limstring (pad-limstring "" 64)) ; Unused - (limstring (pad-limstring backend-tty 64))) - -(define-message-sender send-terminate-message () - (byte #\X)) - -(define-message-sender send-unencrypted-password-message (password) - (int32 (+ 5 (length password))) - (string password)) - -(define-message-sender send-query-message (query) - (byte #\Q) - (string query)) - -(define-message-sender send-encrypted-password-message (crypted-password) - (int32 (+ 5 (length crypted-password))) - (string crypted-password)) - -(define-message-sender send-cancel-request (pid key) - (int32 16) ; Length - (int32 80877102) ; Magic - (int32 pid) - (int32 key)) - - -(defun read-socket-sequence (string stream) -"KMR -- Added to support reading from binary stream into a string" - (declare (optimize (speed 3) (safety 0))) - (dotimes (i (length string)) - (declare (fixnum i)) - (setf (char string i) (code-char (read-byte stream)))) - string) - - -;;; Support for encrypted password transmission - -(defconstant +crypt-library+ "/usr/lib/libcrypt.so" - "Name of the shared library to load in order to access the crypt -function named by `*crypt-function-name*'.") - -(defvar *crypt-library-loaded* nil) - -(defun crypt-password (password salt) - "Encrypt a password for transmission to a PostgreSQL server." - (unless *crypt-library-loaded* - (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c")) - (eval (uffi:def-function "crypt" - ((key :cstring) - (salt :cstring)) - :returning :cstring)) - (setq *crypt-library-loaded* t)) - (uffi:with-cstring (password-cstring password) - (uffi:with-cstring (salt-cstring salt) - (uffi:convert-from-cstring (crypt password-cstring salt-cstring))))) -;;; Condition hierarchy - -(define-condition postgresql-condition (condition) - ((connection :initarg :connection :reader postgresql-condition-connection) - (message :initarg :message :reader postgresql-condition-message)) - (:report - (lambda (c stream) - (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>" - (type-of c) - (postgresql-condition-connection c) - (postgresql-condition-message c))))) - -(define-condition postgresql-error (error postgresql-condition) - ()) - -(define-condition postgresql-fatal-error (postgresql-error) - ()) - -(define-condition postgresql-login-error (postgresql-fatal-error) - ()) - -(define-condition postgresql-warning (warning postgresql-condition) - ()) - -(define-condition postgresql-notification (postgresql-condition) - () - (:report - (lambda (c stream) - (format stream "~@" - (postgresql-condition-connection c) - (postgresql-condition-message c))))) - -;;; Structures - -(defstruct postgresql-connection - host - port - database - user - password - options - tty - socket - pid - key) - -(defstruct postgresql-cursor - connection - name - fields) - -;;; Socket stuff - -(defconstant +postgresql-server-default-port+ 5432 - "Default port of PostgreSQL server.") - -(defvar *postgresql-server-socket-timeout* 60 - "Timeout in seconds for reads from the PostgreSQL server.") - - -#+cmu -(defun open-postgresql-socket (host port) - (etypecase host - (pathname - ;; Directory to unix-domain socket - (ext:connect-to-unix-socket - (namestring - (make-pathname :name ".s.PGSQL" :type (princ-to-string port) - :defaults host)))) - (string - (ext:connect-to-inet-socket host port)))) - -#+cmu -(defun open-postgresql-socket-stream (host port) - (system:make-fd-stream - (open-postgresql-socket host port) - :input t :output t :element-type '(unsigned-byte 8) - :buffering :none - :timeout *postgresql-server-socket-timeout*)) - -#+allegro -(defun open-postgresql-socket-stream (host port) - (etypecase host - (pathname - (let ((path (namestring - (make-pathname :name ".s.PGSQL" :type (princ-to-string port) - :defaults host)))) - (socket:make-socket :type :stream :address-family :file - :connect :active - :remote-filename path :local-filename path))) - (string - (socket:with-pending-connect - (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed")) - (socket:make-socket :type :stream :address-family :internet - :remote-port port :remote-host host - :connect :active :nodelay t)))) - )) - -#+lispworks -(defun open-postgresql-socket-stream (host port) - (etypecase host - (pathname - (error "File sockets not supported on Lispworks.")) - (string - (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8) - :read-timeout *postgresql-server-socket-timeout*)) - )) - -;;; Interface Functions - -(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument)) - (port +postgresql-server-default-port+) - (database (cmucl-compat:required-argument)) - (user (cmucl-compat:required-argument)) - options tty password) - "Open a connection to a PostgreSQL server with the given parameters. -Note that host, database and user arguments must be supplied. - -If host is a pathname, it is assumed to name a directory containing -the local unix-domain sockets of the server, with port selecting which -of those sockets to open. If host is a string, it is assumed to be -the name of the host running the PostgreSQL server. In that case a -TCP connection to the given port on that host is opened in order to -communicate with the server. In either case the port argument -defaults to `+postgresql-server-default-port+'. - -Password is the clear-text password to be passed in the authentication -phase to the server. Depending on the server set-up, it is either -passed in the clear, or encrypted via crypt and a server-supplied -salt. In that case the alien function specified by `*crypt-library*' -and `*crypt-function-name*' is used for encryption. - -Note that all the arguments (including the clear-text password -argument) are stored in the `postgresql-connection' structure, in -order to facilitate automatic reconnection in case of communication -troubles." - (reopen-postgresql-connection - (make-postgresql-connection :host host :port port - :options (or options "") :tty (or tty "") - :database database :user user - :password (or password "")))) - -(defun reopen-postgresql-connection (connection) - "Reopen the given PostgreSQL connection. Closes any existing -connection, if it is still open." - (when (postgresql-connection-open-p connection) - (close-postgresql-connection connection)) - (let ((socket (open-postgresql-socket-stream - (postgresql-connection-host connection) - (postgresql-connection-port connection)))) - (unwind-protect - (progn - (setf (postgresql-connection-socket connection) socket) - (send-startup-message socket - (postgresql-connection-database connection) - (postgresql-connection-user connection) - (postgresql-connection-options connection) - (postgresql-connection-tty connection)) - (force-output socket) - (loop - (case (read-socket-value 'int8 socket) - (#.+authentication-message+ - (case (read-socket-value 'int32 socket) - (0 (return)) - ((1 2) - (error 'postgresql-login-error - :connection connection - :message - "Postmaster expects unsupported Kerberos authentication.")) - (3 - (send-unencrypted-password-message - socket - (postgresql-connection-password connection))) - (4 - (let ((salt (make-string 2))) - (read-socket-sequence salt socket) - (send-encrypted-password-message - socket - (crypt-password - (postgresql-connection-password connection) salt)))) - (t - (error 'postgresql-login-error - :connection connection - :message - "Postmaster expects unknown authentication method.")))) - (#.+error-response-message+ - (let ((message (read-socket-value 'string socket))) - (error 'postgresql-login-error - :connection connection :message message))) - (t - (error 'postgresql-login-error - :connection connection - :message - "Received garbled message from Postmaster")))) - ;; Start backend communication - (force-output socket) - (loop - (case (read-socket-value 'int8 socket) - (#.+backend-key-message+ - (setf (postgresql-connection-pid connection) - (read-socket-value 'int32 socket) - (postgresql-connection-key connection) - (read-socket-value 'int32 socket))) - (#.+ready-for-query-message+ - (setq socket nil) - (return connection)) - (#.+error-response-message+ - (let ((message (read-socket-value 'string socket))) - (error 'postgresql-login-error - :connection connection - :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value 'string socket))) - (warn 'postgresql-warning :connection connection - :message message))) - (t - (error 'postgresql-login-error - :connection connection - :message - "Received garbled message from Postmaster"))))) - (when socket - (close socket))))) - -(defun close-postgresql-connection (connection &optional abort) - (unless abort - (ignore-errors - (send-terminate-message (postgresql-connection-socket connection)))) - (close (postgresql-connection-socket connection))) - -(defun postgresql-connection-open-p (connection) - (let ((socket (postgresql-connection-socket connection))) - (and socket (streamp socket) (open-stream-p socket)))) - -(defun ensure-open-postgresql-connection (connection) - (unless (postgresql-connection-open-p connection) - (reopen-postgresql-connection connection))) - -(defun process-async-messages (connection) - (assert (postgresql-connection-open-p connection)) - ;; Process any asnychronous messages - (loop with socket = (postgresql-connection-socket connection) - while (listen socket) - do - (case (read-socket-value 'int8 socket) - (#.+notice-response-message+ - (let ((message (read-socket-value 'string socket))) - (warn 'postgresql-warning :connection connection - :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value 'int32 socket)) - (message (read-socket-value 'string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))) - -(defun start-query-execution (connection query) - (ensure-open-postgresql-connection connection) - (process-async-messages connection) - (send-query-message (postgresql-connection-socket connection) query) - (force-output (postgresql-connection-socket connection))) - -(defun wait-for-query-results (connection) - (assert (postgresql-connection-open-p connection)) - (let ((socket (postgresql-connection-socket connection)) - (cursor-name nil) - (error nil)) - (loop - (case (read-socket-value 'int8 socket) - (#.+completed-response-message+ - (return (values :completed (read-socket-value 'string socket)))) - (#.+cursor-response-message+ - (setq cursor-name (read-socket-value 'string socket))) - (#.+row-description-message+ - (let* ((count (read-socket-value 'int16 socket)) - (fields - (loop repeat count - collect - (list - (read-socket-value 'string socket) - (read-socket-value 'int32 socket) - (read-socket-value 'int16 socket) - (read-socket-value 'int32 socket))))) - (return - (values :cursor - (make-postgresql-cursor :connection connection - :name cursor-name - :fields fields))))) - (#.+copy-in-response-message+ - (return :copy-in)) - (#.+copy-out-response-message+ - (return :copy-out)) - (#.+ready-for-query-message+ - (when error - (error error)) - (return nil)) - (#.+error-response-message+ - (let ((message (read-socket-value 'string socket))) - (setq error - (make-condition 'postgresql-error - :connection connection :message message)))) - (#.+notice-response-message+ - (let ((message (read-socket-value 'string socket))) - (warn 'postgresql-warning - :connection connection :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value 'int32 socket)) - (message (read-socket-value 'string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend")))))) - -(defun read-null-bit-vector (socket count) - (let ((result (make-array count :element-type 'bit))) - (dotimes (offset (ceiling count 8)) - (loop with byte = (read-byte socket) - for index from (* offset 8) below (min count (* (1+ offset) 8)) - for weight downfrom 7 - do (setf (aref result index) (ldb (byte 1 weight) byte)))) - result)) - -(defun read-cursor-row (cursor) - (let* ((connection (postgresql-cursor-connection cursor)) - (socket (postgresql-connection-socket connection)) - (fields (postgresql-cursor-fields cursor))) - (assert (postgresql-connection-open-p connection)) - (loop - (let ((code (read-socket-value 'int8 socket))) - (case code - (#.+ascii-row-message+ - (return - (loop with count = (length fields) - with null-vector = (read-null-bit-vector socket count) - repeat count - for null-bit across null-vector - for null-p = (zerop null-bit) - if null-p - collect nil - else - collect - (let* ((length (read-socket-value 'int32 socket)) - (result (make-string (- length 4)))) - (read-socket-sequence result socket) - result)))) - (#.+binary-row-message+ - (error "NYI")) - (#.+completed-response-message+ - (return (values nil (read-socket-value 'string socket)))) - (#.+error-response-message+ - (let ((message (read-socket-value 'string socket))) - (error 'postgresql-error - :connection connection :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value 'string socket))) - (warn 'postgresql-warning - :connection connection :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value 'int32 socket)) - (message (read-socket-value 'string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))))) - -(defun copy-cursor-row (cursor sequence) - (let* ((connection (postgresql-cursor-connection cursor)) - (socket (postgresql-connection-socket connection)) - (fields (postgresql-cursor-fields cursor))) - (assert (= (length fields) (length sequence))) - (loop - (let ((code (read-socket-value 'int8 socket))) - (case code - (#.+ascii-row-message+ - (return - (map-into - sequence - #'(lambda (null-bit) - (if (zerop null-bit) - nil - (let* ((length (read-socket-value 'int32 socket)) - (result (make-string (- length 4)))) - (read-socket-sequence result socket) - result))) - (read-null-bit-vector socket (length sequence))))) - (#.+binary-row-message+ - (error "NYI")) - (#.+completed-response-message+ - (return (values nil (read-socket-value 'string socket)))) - (#.+error-response-message+ - (let ((message (read-socket-value 'string socket))) - (error 'postgresql-error - :connection connection :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value 'string socket))) - (warn 'postgresql-warning - :connection connection :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value 'int32 socket)) - (message (read-socket-value 'string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))))) - -(defun skip-cursor-row (cursor) - (let* ((connection (postgresql-cursor-connection cursor)) - (socket (postgresql-connection-socket connection)) - (fields (postgresql-cursor-fields cursor))) - (loop - (let ((code (read-socket-value 'int8 socket))) - (case code - (#.+ascii-row-message+ - (loop for null-bit across - (read-null-bit-vector socket (length fields)) - do - (unless (zerop null-bit) - (let* ((length (read-socket-value 'int32 socket))) - (loop repeat (- length 4) do (read-byte socket))))) - (return t)) - (#.+binary-row-message+ - (error "NYI")) - (#.+completed-response-message+ - (return (values nil (read-socket-value 'string socket)))) - (#.+error-response-message+ - (let ((message (read-socket-value 'string socket))) - (error 'postgresql-error - :connection connection :message message))) - (#.+notice-response-message+ - (let ((message (read-socket-value 'string socket))) - (warn 'postgresql-warning - :connection connection :message message))) - (#.+notification-response-message+ - (let ((pid (read-socket-value 'int32 socket)) - (message (read-socket-value 'string socket))) - (when (= pid (postgresql-connection-pid connection)) - (signal 'postgresql-notification :connection connection - :message message)))) - (t - (close-postgresql-connection connection) - (error 'postgresql-fatal-error :connection connection - :message "Received garbled message from backend"))))))) - -(defun run-query (connection query) - (start-query-execution connection query) - (multiple-value-bind (status cursor) - (wait-for-query-results connection) - (assert (eq status :cursor)) - (loop for row = (read-cursor-row cursor) - while row - collect row - finally - (wait-for-query-results connection)))) diff --git a/interfaces/postgresql/postgresql-api.cl b/interfaces/postgresql/postgresql-api.cl new file mode 100644 index 0000000..a29a546 --- /dev/null +++ b/interfaces/postgresql/postgresql-api.cl @@ -0,0 +1,190 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql.cl +;;;; Purpose: Low-level PostgreSQL interface using UFFI +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: postgresql-api.cl,v 1.1 2002/03/23 17:10:48 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and Copyright (c) 1999-2001 by Pierre R. Mai +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :postgresql) + + +;;;; This file implements as little of the FFI bindings to the +;;;; PostgreSQL client libraries as we could get away with. +;;;; Especially all the PostgreSQL-specific goodies aren't there, and +;;;; we just use void pointers where we can get away with it, which +;;;; thanks to the design of the PostgreSQL client libraries is pretty +;;;; much everywhere, in contrast to the MySQL client libraries for +;;;; example. + +;;;; Type definitions + +;;; Basic Types + +(uffi:def-foreign-type pgsql-oid :unsigned-int) + +(uffi:def-enum pgsql-conn-status-type + (:connection-ok + :connection-bad)) + +(uffi:def-enum pgsql-exec-status-type + (:empty-query + :command-ok + :tuples-ok + :copy-out + :copy-in + :bad-response + :nonfatal-error + :fatal-error)) + +(uffi:def-foreign-type pgsql-conn :pointer-void) +(uffi:def-foreign-type pgsql-result :pointer-void) + +;;(declaim (inline PQsetdbLogin)) ;; causes compile error in LW 4.2.0 +(uffi:def-function ("PQsetdbLogin" PQsetdbLogin) + ((pghost :cstring) + (pgport :cstring) + (pgoptions :cstring) + (pgtty :cstring) + (dbName :cstring) + (login :cstring) + (pwd :cstring)) + :returning pgsql-conn) + +(declaim (inline PQfinish)) +(uffi:def-function ("PQfinish" PQfinish) + ((conn pgsql-conn)) + :module "postgresql" + :returning :void) + +(declaim (inline PQstatus)) +(uffi:def-function ("PQstatus" PQstatus) + ((conn pgsql-conn)) + :module "postgresql" + :returning pgsql-conn-status-type) + +(declaim (inline PQerrorMessage)) +(uffi:def-function ("PQerrorMessage" PQerrorMessage) + ((conn pgsql-conn)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQexec)) +(uffi:def-function ("PQexec" PQexec) + ((conn pgsql-conn) + (query :cstring)) + :module "postgresql" + :returning pgsql-result) + +(declaim (inline PQresultStatus)) +(uffi:def-function ("PQresultStatus" PQresultStatus) + ((res pgsql-result)) + :module "postgresql" + :returning pgsql-exec-status-type) + +(declaim (inline PQresultErrorMessage)) +(uffi:def-function ("PQresultErrorMessage" PQresultErrorMessage) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQntuples)) +(uffi:def-function ("PQntuples" PQntuples) + ((res pgsql-result)) + :module "postgresql" + :returning :int) + +(declaim (inline PQnfields)) +(uffi:def-function ("PQnfields" PQnfields) + ((res pgsql-result)) + :module "postgresql" + :returning :int) + +(declaim (inline PQfname)) +(uffi:def-function ("PQfname" PQfname) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQfnumber)) +(uffi:def-function ("PQfnumber" PQfnumber) + ((res pgsql-result) + (field-name :cstring)) + :module "postgresql" + :returning :int) + +(declaim (inline PQftype)) +(uffi:def-function ("PQftype" PQftype) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning pgsql-oid) + +(declaim (inline PQfsize)) +(uffi:def-function ("PQfsize" PQfsize) + ((res pgsql-result) + (field-num :int)) + :module "postgresql" + :returning :short) + +(declaim (inline PQcmdStatus)) +(uffi:def-function ("PQcmdStatus" PQcmdStatus) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQoidStatus)) +(uffi:def-function ("PQoidStatus" PQoidStatus) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQcmdTuples)) +(uffi:def-function ("PQcmdTuples" PQcmdTuples) + ((res pgsql-result)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQgetvalue)) +(uffi:def-function ("PQgetvalue" PQgetvalue) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :cstring) + +(declaim (inline PQgetlength)) +(uffi:def-function ("PQgetlength" PQgetlength) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :int) + +(declaim (inline PQgetisnull)) +(uffi:def-function ("PQgetisnull" PQgetisnull) + ((res pgsql-result) + (tup-num :int) + (field-num :int)) + :module "postgresql" + :returning :int) + +(declaim (inline PQclear)) +(uffi:def-function ("PQclear" PQclear) + ((res pgsql-result)) + :module "postgresql" + :returning :void) diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl index cb83a34..eca4b29 100644 --- a/interfaces/postgresql/postgresql-sql.cl +++ b/interfaces/postgresql/postgresql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-sql.cl,v 1.1 2002/03/23 14:04:53 kevin Exp $ +;;;; $Id: postgresql-sql.cl,v 1.2 2002/03/23 17:07:40 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -68,30 +68,30 @@ (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional port options tty) connection-spec - (uffi:with-cstring (host-native host) - (uffi:with-cstring (user-native user) - (uffi:with-cstring (password-native password) - (uffi:with-cstring (db-native db) - (uffi:with-cstring (port-native port) - (uffi:with-cstring (options-native options) - (uffi:with-cstring (tty-native tty) - (let ((connection (PQsetdbLogin host-native port-native - options-native tty-native - db-native user-native - password-native))) - (declare (type pgsql-conn-def connection)) - (when (not (eq (PQstatus connection) - pgsql-conn-status-type#connection-ok)) - (error 'clsql-connect-error - :database-type database-type - :connection-spec connection-spec - :errno (PQstatus connection) - :error (tidy-error-message - (PQerrorMessage connection)))) - (make-instance 'postgresql-database - :name (database-name-from-spec connection-spec - database-type) - :conn-ptr connection))))))))))) + (uffi:with-cstrings ((host-native host) + (user-native user) + (password-native password) + (db-native db) + (port-native port) + (options-native options) + (tty-native tty)) + (let ((connection (PQsetdbLogin host-native port-native + options-native tty-native + db-native user-native + password-native))) + (declare (type pgsql-conn-def connection)) + (when (not (eq (PQstatus connection) + pgsql-conn-status-type#connection-ok)) + (error 'clsql-connect-error + :database-type database-type + :connection-spec connection-spec + :errno (PQstatus connection) + :error (tidy-error-message + (PQerrorMessage connection)))) + (make-instance 'postgresql-database + :name (database-name-from-spec connection-spec + database-type) + :conn-ptr connection))))) (defmethod database-disconnect ((database postgresql-database)) diff --git a/interfaces/postgresql/postgresql-uffi.cl b/interfaces/postgresql/postgresql-uffi.cl deleted file mode 100644 index af3a1b0..0000000 --- a/interfaces/postgresql/postgresql-uffi.cl +++ /dev/null @@ -1,190 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: postgresql.cl -;;;; Purpose: Low-level PostgreSQL interface using UFFI -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: postgresql-uffi.cl,v 1.1 2002/03/23 14:04:53 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :postgresql) - - -;;;; This file implements as little of the FFI bindings to the -;;;; PostgreSQL client libraries as we could get away with. -;;;; Especially all the PostgreSQL-specific goodies aren't there, and -;;;; we just use void pointers where we can get away with it, which -;;;; thanks to the design of the PostgreSQL client libraries is pretty -;;;; much everywhere, in contrast to the MySQL client libraries for -;;;; example. - -;;;; Type definitions - -;;; Basic Types - -(uffi:def-foreign-type pgsql-oid :unsigned-int) - -(uffi:def-enum pgsql-conn-status-type - (:connection-ok - :connection-bad)) - -(uffi:def-enum pgsql-exec-status-type - (:empty-query - :command-ok - :tuples-ok - :copy-out - :copy-in - :bad-response - :nonfatal-error - :fatal-error)) - -(uffi:def-foreign-type pgsql-conn :pointer-void) -(uffi:def-foreign-type pgsql-result :pointer-void) - -;;(declaim (inline PQsetdbLogin)) ;; causes compile error in LW 4.2.0 -(uffi:def-function ("PQsetdbLogin" PQsetdbLogin) - ((pghost :cstring) - (pgport :cstring) - (pgoptions :cstring) - (pgtty :cstring) - (dbName :cstring) - (login :cstring) - (pwd :cstring)) - :returning pgsql-conn) - -(declaim (inline PQfinish)) -(uffi:def-function ("PQfinish" PQfinish) - ((conn pgsql-conn)) - :module "postgresql" - :returning :void) - -(declaim (inline PQstatus)) -(uffi:def-function ("PQstatus" PQstatus) - ((conn pgsql-conn)) - :module "postgresql" - :returning pgsql-conn-status-type) - -(declaim (inline PQerrorMessage)) -(uffi:def-function ("PQerrorMessage" PQerrorMessage) - ((conn pgsql-conn)) - :module "postgresql" - :returning :cstring) - -(declaim (inline PQexec)) -(uffi:def-function ("PQexec" PQexec) - ((conn pgsql-conn) - (query :cstring)) - :module "postgresql" - :returning pgsql-result) - -(declaim (inline PQresultStatus)) -(uffi:def-function ("PQresultStatus" PQresultStatus) - ((res pgsql-result)) - :module "postgresql" - :returning pgsql-exec-status-type) - -(declaim (inline PQresultErrorMessage)) -(uffi:def-function ("PQresultErrorMessage" PQresultErrorMessage) - ((res pgsql-result)) - :module "postgresql" - :returning :cstring) - -(declaim (inline PQntuples)) -(uffi:def-function ("PQntuples" PQntuples) - ((res pgsql-result)) - :module "postgresql" - :returning :int) - -(declaim (inline PQnfields)) -(uffi:def-function ("PQnfields" PQnfields) - ((res pgsql-result)) - :module "postgresql" - :returning :int) - -(declaim (inline PQfname)) -(uffi:def-function ("PQfname" PQfname) - ((res pgsql-result) - (field-num :int)) - :module "postgresql" - :returning :cstring) - -(declaim (inline PQfnumber)) -(uffi:def-function ("PQfnumber" PQfnumber) - ((res pgsql-result) - (field-name :cstring)) - :module "postgresql" - :returning :int) - -(declaim (inline PQftype)) -(uffi:def-function ("PQftype" PQftype) - ((res pgsql-result) - (field-num :int)) - :module "postgresql" - :returning pgsql-oid) - -(declaim (inline PQfsize)) -(uffi:def-function ("PQfsize" PQfsize) - ((res pgsql-result) - (field-num :int)) - :module "postgresql" - :returning :short) - -(declaim (inline PQcmdStatus)) -(uffi:def-function ("PQcmdStatus" PQcmdStatus) - ((res pgsql-result)) - :module "postgresql" - :returning :cstring) - -(declaim (inline PQoidStatus)) -(uffi:def-function ("PQoidStatus" PQoidStatus) - ((res pgsql-result)) - :module "postgresql" - :returning :cstring) - -(declaim (inline PQcmdTuples)) -(uffi:def-function ("PQcmdTuples" PQcmdTuples) - ((res pgsql-result)) - :module "postgresql" - :returning :cstring) - -(declaim (inline PQgetvalue)) -(uffi:def-function ("PQgetvalue" PQgetvalue) - ((res pgsql-result) - (tup-num :int) - (field-num :int)) - :module "postgresql" - :returning :cstring) - -(declaim (inline PQgetlength)) -(uffi:def-function ("PQgetlength" PQgetlength) - ((res pgsql-result) - (tup-num :int) - (field-num :int)) - :module "postgresql" - :returning :int) - -(declaim (inline PQgetisnull)) -(uffi:def-function ("PQgetisnull" PQgetisnull) - ((res pgsql-result) - (tup-num :int) - (field-num :int)) - :module "postgresql" - :returning :int) - -(declaim (inline PQclear)) -(uffi:def-function ("PQclear" PQclear) - ((res pgsql-result)) - :module "postgresql" - :returning :void)