;;;; 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
;;;;
: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
;;;; 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
;;;;
: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))
;;;; 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
;;;;
: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))
--- /dev/null
+;;;; -*- 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)))
+
;;;; 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
: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))
+++ /dev/null
-;;;; -*- 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)))
-
--- /dev/null
+;;;; -*- 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 "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
+ (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))))
+++ /dev/null
-;;;; -*- 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 "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
- (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))))
--- /dev/null
+;;;; -*- 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)
;;;; 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
(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))
+++ /dev/null
-;;;; -*- 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)
projects / clsql.git / commitdiff