From emarsden at common-lisp.net Fri Sep 15 20:04:38 2006 From: emarsden at common-lisp.net (emarsden) Date: Fri, 15 Sep 2006 16:04:38 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060915200438.18F411C00A@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv19838 Modified Files: v3-protocol.lisp Log Message: Fix bug in PG-CLOSE-STATEMENT (thanks to ya007 at yandex.ru). --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/08/28 20:08:00 1.19 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/15 20:04:37 1.20 @@ -955,7 +955,7 @@ t) (defmethod pg-close-statement ((connection pgcon-v3) (statement-name string)) - (pg-close connection statement-name #\s)) + (pg-close connection statement-name #\S)) (defmethod pg-close-portal ((connection pgcon-v3) (portal string)) (pg-close connection portal #\P)) From emarsden at common-lisp.net Fri Sep 15 20:49:03 2006 From: emarsden at common-lisp.net (emarsden) Date: Fri, 15 Sep 2006 16:49:03 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060915204903.A37932D01F@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv24811 Modified Files: README pg.lisp v3-protocol.lisp Log Message: Improved documentation and a basic example for the use of execution plans (prepared statements). --- /project/pg/cvsroot/pg/README 2006/08/28 20:08:00 1.6 +++ /project/pg/cvsroot/pg/README 2006/09/15 20:49:03 1.7 @@ -1,7 +1,7 @@ pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp Author: Eric Marsden - Time-stamp: <2006-08-28 emarsden> + Time-stamp: <2006-09-15 emarsden> Version: 0.23 Copyright (C) 1999,2000,2001,2002,2003,2004,2005,2006 Eric Marsden @@ -102,6 +102,64 @@ (pg-disconnect connection) -> nil Close the database connection. + +=== Support for prepared statements ==================================== + + (pg-supports-pbe conn) -> boolean + Returns T iff the connection to the database is able to support + prepared statements. This is only true of connections using + version 3 of the frontend/backend protocol. + + (pg-prepare conn statement-name sql &optional parameter-types) + Prepares an execution plan for a query (a prepared statement). + The prepared statement may contain arguments that are refered to + as $1, $2 etc; if arguments are present their types must be + declared via the list PARAMETER-TYPES. Each element of + PARAMETER-TYPES should be a string that defines the type of its + corresponding parameter (see PG::*TYPE-PARSERS* for examples of + type names used by PostgreSQL). + + Using execution plans is more efficient than multiple calls to + PG-EXEC, since the parsing and query optimizing phase only occurs + once, at preparation time. It also helps to protect against "SQL + injection" attacks, by ensuring that arguments to an SQL query + cannot be interpreted as a part of the SQL request. + + (pg-bind conn portal-name statement-name typed-arguments) + Binds the execution plan that was previously prepared as + STATEMENT-NAME to PORTAL-NAME, with TYPED-ARGUMENTS. + TYPED-ARGUMENTS is a list of tuples of the form '(type value), + where TYPE is one of :char, :byte, :int16, :int32, :string. + + (pg-execute conn portal-name &optional maximal-return-rows) + Executes the execution plan that was previously bound to + PORTAL-NAME. Optionally returns up to MAXIMAL-RETURN-ROWS rows + (0 means an unlimited number of rows). + + (pg-close-statement conn statement-name) + Releases the command execution plan (prepared statement) + STATEMENT-NAME. This also releases any open portals for that + prepared statement. + + (pg-close-portal conn portal-name) + Releases the portal PORTAL-NAME. + +Example using prepared statements: + + (defun delete-item (db-connection int-value string-value) + (pg-prepare db-connection "delete-statement" + "DELETE FROM items WHERE int_column = $1 AND string_column = $2" + `("int4" "varchar")) + (unwind-protect + (progn (pg-bind db-connection "delete-portal" "delete-statement" + `((:int32 ,int-value) (:string ,string-value))) + (pg-execute db-connection "delete-portal")) + ;; NB: portal is closed automatically when statement is closed + (pg-close-statement db-connection "select-statement"))) + + +=== Introspection support ============================================== + (pg-databases connection) -> list of strings Return a list of the databases available at this site (a database is a set of tables; in a virgin PostgreSQL @@ -119,6 +177,9 @@ detailed information (attribute types, for example), it can be obtained from `pg-result' on a SELECT statement for that table. + +=== Support for large objects (BLOBs) ================================= + (pglo-create conn . args) -> oid Create a new large object (BLOB, or binary large object in other DBMSes parlance) in the database to which we are --- /project/pg/cvsroot/pg/pg.lisp 2006/08/28 20:08:00 1.7 +++ /project/pg/cvsroot/pg/pg.lisp 2006/09/15 20:49:03 1.8 @@ -1,7 +1,7 @@ ;;; pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp ;; ;; Author: Eric Marsden -;; Time-stamp: <2006-08-28 emarsden> +;; Time-stamp: <2006-09-15 emarsden> ;; Version: 0.22 ;; ;; Copyright (C) 1999,2000,2001,2002,2003,2004,2005 Eric Marsden @@ -200,7 +200,8 @@ (defgeneric pg-close-statement (connection statement-name) (:documentation - "Closes a prepared statement")) + "Closes prepared statement specified by STATEMENT-NAME and closes +all portals associated with that statement (see PG-PREPARE and PG-BIND).")) (defgeneric pg-close-portal (connection portal) (:documentation --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/15 20:04:37 1.20 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/15 20:49:03 1.21 @@ -902,8 +902,7 @@ (:int16 0))))) t)) -(defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maxinum-number-of-rows 0)) - +(defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maximum-number-of-rows 0)) ;; have it describe the result: (send-packet connection #\D From emarsden at common-lisp.net Mon Sep 18 19:09:26 2006 From: emarsden at common-lisp.net (emarsden) Date: Mon, 18 Sep 2006 15:09:26 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060918190926.3250D7C044@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv16724 Modified Files: README Log Message: Fix to the prepared statement example. --- /project/pg/cvsroot/pg/README 2006/09/15 20:49:03 1.7 +++ /project/pg/cvsroot/pg/README 2006/09/18 19:09:25 1.8 @@ -1,7 +1,7 @@ pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp Author: Eric Marsden - Time-stamp: <2006-09-15 emarsden> + Time-stamp: <2006-09-18 emarsden> Version: 0.23 Copyright (C) 1999,2000,2001,2002,2003,2004,2005,2006 Eric Marsden @@ -155,7 +155,7 @@ `((:int32 ,int-value) (:string ,string-value))) (pg-execute db-connection "delete-portal")) ;; NB: portal is closed automatically when statement is closed - (pg-close-statement db-connection "select-statement"))) + (pg-close-statement db-connection "delete-statement"))) === Introspection support ============================================== From emarsden at common-lisp.net Mon Sep 18 19:10:01 2006 From: emarsden at common-lisp.net (emarsden) Date: Mon, 18 Sep 2006 15:10:01 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060918191001.3DDF57C044@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv16819 Modified Files: pg.asd Log Message: Put the PG defsystem in its own package. --- /project/pg/cvsroot/pg/pg.asd 2006/01/27 17:51:53 1.9 +++ /project/pg/cvsroot/pg/pg.asd 2006/09/18 19:10:01 1.10 @@ -1,7 +1,9 @@ ;;; -*- Mode: lisp -*- ;; -(in-package :asdf) +(defpackage #:pg-system (:use #:asdf #:cl)) +(in-package #:pg-system) + (defclass pg-component (cl-source-file) ()) From emarsden at common-lisp.net Mon Sep 18 19:10:38 2006 From: emarsden at common-lisp.net (emarsden) Date: Mon, 18 Sep 2006 15:10:38 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060918191038.B5B0249024@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv16977 Modified Files: pg.lisp Log Message: Documentation fix for PG-EXECUTE. --- /project/pg/cvsroot/pg/pg.lisp 2006/09/15 20:49:03 1.8 +++ /project/pg/cvsroot/pg/pg.lisp 2006/09/18 19:10:38 1.9 @@ -193,10 +193,10 @@ "Gives the values for the parameters defined in the statement-name. The types can be one of :char :byte :int16 :int32 or :cstring")) -(defgeneric pg-execute (connection portal &optional maxinum-number-of-rows) +(defgeneric pg-execute (connection portal &optional maximum-number-of-rows) (:documentation - "Executes the portal defined previously and return (optionally) up to maximum-number-of-row. -For an unlimited number of rows use 0")) + "Executes the portal defined previously and return (optionally) up to MAXIMUM-NUMBER-OF-ROWS. +For an unlimited number of rows use 0.")) (defgeneric pg-close-statement (connection statement-name) (:documentation From emarsden at common-lisp.net Mon Sep 18 21:33:11 2006 From: emarsden at common-lisp.net (emarsden) Date: Mon, 18 Sep 2006 17:33:11 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060918213311.1C4184049@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv12304 Modified Files: sysdep.lisp Log Message: Make comparison in IMPLEMENTATION-NAME-FOR-ENCODING case-insensitive (from ya007 at yandex.ru). --- /project/pg/cvsroot/pg/sysdep.lisp 2006/01/27 18:03:39 1.13 +++ /project/pg/cvsroot/pg/sysdep.lisp 2006/09/18 21:33:10 1.14 @@ -1,7 +1,7 @@ ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden -;;; Time-stamp: <2006-01-27 emarsden> +;;; Time-stamp: <2006-09-18 emarsden> ;; ;; @@ -327,22 +327,22 @@ (defun implementation-name-for-encoding (encoding) (%sysdep "client encoding to external format name" #+(and clisp unicode) - (cond ((string= encoding "SQL_ASCII") charset:ascii) - ((string= encoding "LATIN1") charset:iso-8859-1) - ((string= encoding "LATIN9") charset:iso-8859-9) - ((string= encoding "UTF8") charset:utf-8) + (cond ((string-equal encoding "SQL_ASCII") charset:ascii) + ((string-equal encoding "LATIN1") charset:iso-8859-1) + ((string-equal encoding "LATIN9") charset:iso-8859-9) + ((string-equal encoding "UTF8") charset:utf-8) (t (error "unknown encoding ~A" encoding))) #+(and allegro ics) - (cond ((string= encoding "SQL_ASCII") :ascii) - ((string= encoding "LATIN1") :latin1) - ((string= encoding "LATIN9") :latin9) - ((string= encoding "UTF8") :utf8) + (cond ((string-equal encoding "SQL_ASCII") :ascii) + ((string-equal encoding "LATIN1") :latin1) + ((string-equal encoding "LATIN9") :latin9) + ((string-equal encoding "UTF8") :utf8) (t (error "unknown encoding ~A" encoding))) #+(and sbcl sb-unicode) - (cond ((string= encoding "SQL_ASCII") :ascii) - ((string= encoding "LATIN1") :latin1) - ((string= encoding "LATIN9") :latin9) - ((string= encoding "UTF8") :utf8) + (cond ((string-equal encoding "SQL_ASCII") :ascii) + ((string-equal encoding "LATIN1") :latin1) + ((string-equal encoding "LATIN9") :latin9) + ((string-equal encoding "UTF8") :utf8) (t (error "unknown encoding ~A" encoding))) #+(or cmu gcl ecl abcl openmcl) nil)) From emarsden at common-lisp.net Mon Sep 18 21:37:48 2006 From: emarsden at common-lisp.net (emarsden) Date: Mon, 18 Sep 2006 17:37:48 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060918213748.5D6C13001F@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv12747 Modified Files: v3-protocol.lisp Log Message: Fix problems with text data in prepared statements. Unlike the rest of the protocol, strings are not sent NUL-terminated. --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/15 20:49:03 1.21 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/18 21:37:48 1.22 @@ -306,6 +306,7 @@ ((:int16) 2) ((:int32) 4) ((:rawdata) (length value)) + ((:string) (length (convert-string-to-bytes value))) ((:cstring) (1+ (length (convert-string-to-bytes value)))) ((:ucstring) (1+ (length value))))))) (data (make-array (- length 4) @@ -356,6 +357,13 @@ (setf (elt data position) 0) (incf position)) + ;; a string without the trailing NUL character + ((:string) + (check-type value string) + (let ((encoded (convert-string-to-bytes value))) + (replace data encoded :start1 position) + (incf position (length encoded)))) + ((:rawdata) (check-type value (array (unsigned-byte 8) *)) (replace data value :start1 position) @@ -374,26 +382,16 @@ to connect to the database using a Unix socket." (let* ((stream (socket-connect port host)) (connection (make-instance 'pgcon-v3 :stream stream :host host :port port)) - (user-packet-length (+ 4 ; length - 4 ; protocol version - (length "user") - 1 - (length user) - 1 - (length "database") - 1 - (length dbname) - 1 - 1))) + (connect-options `("user" ,user + "database" ,dbname)) + (user-packet-length (+ 4 4 (loop :for item :in connect-options :sum (1+ (length item))) 1))) ;; send the startup packet ;; this is one of the only non-standard packets! (%send-net-int stream user-packet-length 4) (%send-net-int stream 3 2) ; major (%send-net-int stream 0 2) ; minor - (%send-cstring stream "user") - (%send-cstring stream user) - (%send-cstring stream "database") - (%send-cstring stream dbname) + (dolist (item connect-options) + (%send-cstring stream item)) (%send-net-int stream 0 1) (%flush connection) @@ -634,9 +632,7 @@ (warn "Got unexpected packet: ~S, resetting connection" packet) ;; sync - (send-packet connection - #\S - nil) + (send-packet connection #\S nil) (%flush connection))))))) (defmethod pg-exec ((connection pgcon-v3) &rest args) @@ -851,16 +847,16 @@ t)) (defmethod pg-bind ((connection pgcon-v3) (portal string) (statement-name string) list-of-types-and-values) - (let ((formats (when list-of-types-and-values + (let ((formats (when list-of-types-and-values (loop :for (type value) :in list-of-types-and-values :collect (ecase type - ((:string) `(:int16 0)) - ((:byte :int16 :int32 :char) `(:int16 1)))))) - (data nil)) + ((:string) '(:int16 0)) + ((:byte :int16 :int32 :char) '(:int16 1)))))) + (data nil)) (when list-of-types-and-values - (loop :for (type value) :in list-of-types-and-values + (loop :for (type value) :in list-of-types-and-values :do (ecase type ((:int32) @@ -875,10 +871,12 @@ ((:char) (push '(:int32 1) data) (push `(:int8 ,(char-code value)) data)) + ;; this is not a NUL-terminated string, so send exactly + ;; the string length rather than 1+ ((:string) - (push `(:int32 ,(1+ (length value))) data) - (push `(:cstring ,value) data)))) - + (let ((encoded-length (length (convert-string-to-bytes value (pg-client-encoding connection))))) + (push `(:int32 ,encoded-length) data) + (push `(:string ,value) data))))) (setf data (nreverse data))) (cond @@ -912,13 +910,10 @@ (send-packet connection #\E `((:cstring ,portal) - (:int32 ,maxinum-number-of-rows))) + (:int32 ,maximum-number-of-rows))) ;; send all data: - (send-packet connection - #\S - nil) + (send-packet connection #\S nil) (%flush connection) - (do-followup-query connection)) (defun pg-close (connection name type) From emarsden at common-lisp.net Tue Sep 19 06:57:28 2006 From: emarsden at common-lisp.net (emarsden) Date: Tue, 19 Sep 2006 02:57:28 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060919065728.B6408316A@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv8237 Modified Files: v3-protocol.lisp Log Message: Remove the limit on maximum message size when using the v3 protocol (from Johan Ur Riise ). --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/18 21:37:48 1.22 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/19 06:57:28 1.23 @@ -640,9 +640,6 @@ on the database to which we are connected via CONNECTION. Return a result structure which can be decoded using `pg-result'." (let ((sql (apply #'concatenate 'simple-string args))) - (when (> (length sql) +MAX_MESSAGE_LEN+) - (error "SQL statement too long: ~A" sql)) - (send-packet connection #\Q `((:cstring ,sql))) (%flush connection) (do-followup-query connection))) From emarsden at common-lisp.net Sat Sep 23 12:24:29 2006 From: emarsden at common-lisp.net (emarsden) Date: Sat, 23 Sep 2006 08:24:29 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060923122429.430EC30009@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv3433 Modified Files: README NEWS TODO sysdep.lisp Log Message: - on CL implementations that support Unix sockets, the HOST argument to PG-CONNECT may designate the directory containing the local PostgreSQL unix socket (often "/var/run/postgresql/"). The HOST argument is assumed to designate a local directory rather than a hostname when its first character is #\/. You may need to modify authentication options in the PostgreSQL configuration file pg_hba.conf to allow connections over a unix-domain socket where the databse username is not equal to your ident tokens. This is an incompatible change to previous support for unix-domain sockets with CMUCL (previously a HOST of NIL told pg-dot-lisp to connect to a unix-domain socket whose name was hardwired into the library). This support currently exists for SBCL, CMUCL and OpenMCL. --- /project/pg/cvsroot/pg/README 2006/09/18 19:09:25 1.8 +++ /project/pg/cvsroot/pg/README 2006/09/23 12:24:28 1.9 @@ -1,8 +1,7 @@ pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp Author: Eric Marsden - Time-stamp: <2006-09-18 emarsden> - Version: 0.23 + Version: 0.24 Copyright (C) 1999,2000,2001,2002,2003,2004,2005,2006 Eric Marsden @@ -54,12 +53,16 @@ (pg-connect dbname user &key password host port) -> connection Connect to the database DBNAME on HOST (defaults to localhost) at - PORT (defaults to 5432), and log in as USER. If HOST is nil, - attempt to connect to the localhost using a Unix domain socket; - otherwise the connection is established using TCP/IP. If the - database requires a password, send PASSWORD (as clear text unless - the backend demands crypt() authentication). Set the output date - type to 'ISO', and initialize our type parser tables. + PORT (defaults to 5432), and log in as USER. If HOST designates + an absolute pathname (its first character is #\/), attempt to + connect to the localhost using a Unix domain socket that resides + in that directory (for example "/var/run/postgresql/"); otherwise + HOST designates a hostname and the connection is established + using TCP/IP. Connections to unix sockets are not supported on + all implementations. If the database requires a password, send + PASSWORD (as clear text unless the backend demands crypt() + authentication). Set the output date type to 'ISO', and + initialize our type parser tables. (pg-exec connection &rest sql) -> pgresult Concatenate the SQL strings and send to the backend. Retrieve --- /project/pg/cvsroot/pg/NEWS 2004/08/11 13:26:41 1.3 +++ /project/pg/cvsroot/pg/NEWS 2006/09/23 12:24:28 1.4 @@ -1,5 +1,30 @@ +=== Version 0.22, 2006-09-23 =========================================== -=== Version 0.21, 2003-xxxx ============================================ + - improved support for character encodings; see variable + *PG-CLIENT-ENCODING* (UTF8 encoding tested with SBCL and CLISP + with PostgreSQL 8.1). + + - fixes to the support for prepared statements (or "execution plans"; + see the README for details of the API) on the v3 frontend/backend + protocol. + + - on CL implementations that support Unix sockets, the HOST argument + to PG-CONNECT may designate the directory containing the local + PostgreSQL unix socket (often "/var/run/postgresql/"). The HOST + argument is assumed to designate a local directory rather than a + hostname when its first character is #\/. You may need to modify + authentication options in the PostgreSQL configuration file + pg_hba.conf to allow connections over a unix-domain socket where + the databse username is not equal to your ident tokens. This is an + incompatible change to previous support for unix-domain sockets + with CMUCL (previously a HOST of NIL told pg-dot-lisp to connect + to a unix-domain socket whose name was hardwired into the library). + This support currently exists for SBCL, CMUCL and OpenMCL. + + - many other bugfixes + + +=== Version 0.21, 2003-05-05 =========================================== - added support for the v3 frontend/backend protocol, used by PostgreSQL version 7.4 and up (thanks for Peter Van Eynde). --- /project/pg/cvsroot/pg/TODO 2004/08/11 13:26:41 1.2 +++ /project/pg/cvsroot/pg/TODO 2006/09/23 12:24:28 1.3 @@ -13,9 +13,6 @@ - in PG-CONNECT, use getaddrinfo_all() to try connecting to each possible address for a hostname - - - the whole bind saga - - maybe use CancelRequest to back out of error with grace? - we should return the oid of the object on inserts --- /project/pg/cvsroot/pg/sysdep.lisp 2006/09/18 21:33:10 1.14 +++ /project/pg/cvsroot/pg/sysdep.lisp 2006/09/23 12:24:28 1.15 @@ -1,16 +1,17 @@ ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden -;;; Time-stamp: <2006-09-18 emarsden> +;;; Time-stamp: <2006-09-20 emarsden> ;; ;; (in-package :postgresql) -#+allegro (require :socket) -#+lispworks (require "comm") -#+cormanlisp (require :sockets) -#+armedbear (require :socket) +(eval-when (:compile-toplevel :load-toplevel :execute) + #+allegro (require :socket) + #+lispworks (require "comm") + #+cormanlisp (require :sockets) + #+armedbear (require :socket)) (defmacro %sysdep (desc &rest forms) @@ -88,18 +89,21 @@ #+cmu (defun socket-connect (port host) (declare (type integer port)) - (handler-case - (let ((fd (if host - (ext:connect-to-inet-socket host port) - (ext:connect-to-unix-socket - (format nil "/var/run/postgresql/.s.PGSQL.~D" port))))) - (sys:make-fd-stream fd :input t :output t - :element-type '(unsigned-byte 8))) - (error (e) - (error 'connection-failure - :host host - :port port - :transport-error e)))) + (let ((host (if (typep host 'pathname) + (namestring host) + host))) + (handler-case + (let ((fd (if (eql #\/ (char host 0)) + (ext:connect-to-unix-socket + (format nil "~A.s.PGSQL.~D" (string host) port)) + (ext:connect-to-inet-socket host port)))) + (sys:make-fd-stream fd :input t :output t + :element-type '(unsigned-byte 8))) + (error (e) + (error 'connection-failure + :host host + :port port + :transport-error e))))) ;; this doesn't currently work, because WRITE-SEQUENCE is not ;; implemented @@ -129,22 +133,6 @@ (error 'connection-failure :host host :port port)))) -#+(and db-sockets broken) -(defun socket-connect (port host) - (declare (type integer port)) - (handler-case - (let ((s (sockets:make-inet-socket :stream :tcp)) - (num (car (sockets:host-ent-addresses - (sockets:get-host-by-name host))))) - (sockets:socket-connect s num port) - (sockets:socket-make-stream s :element-type '(unsigned-byte 8) - :input t :output t :buffering :none)) - (error (e) - (error 'connection-failure - :host host - :port port - :transport-error e)))) - #+sbcl (defun socket-connect (port host-name) (declare (type integer port)) @@ -193,6 +181,8 @@ (comm:open-tcp-stream host port :element-type '(unsigned-byte 8) :direction :io) + ;; note that Lispworks (at least 4.3) does not signal an error if + ;; the hostname cannot be resolved; it simply returns NIL (error (e) (error 'connection-failure :host host @@ -218,24 +208,27 @@ #+openmcl (defun socket-connect (port host) (declare (type integer port)) - (handler-case - (if host - (make-socket :address-family :internet - :type :stream - :connect :active - :format :binary - :remote-host host - :remote-port port) - (make-socket :address-family :file - :type :stream - :connect :active - :format :binary - :remote-filename (format nil "/var/run/postgresql/.s.PGSQL.~D" port))) - (error (e) - (error 'connection-failure - :host host - :port port - :transport-error e)))) + (let ((host (if (typep host 'pathname) + (namestring host) + host))) + (handler-case + (if (eql #\/ (char host 0)) + (make-socket :address-family :file + :type :stream + :connect :active + :format :binary + :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port)) + (make-socket :address-family :internet + :type :stream + :connect :active + :format :binary + :remote-host host + :remote-port port)) + (error (e) + (error 'connection-failure + :host host + :port port + :transport-error e))))) ;; from John DeSoi #+(and mcl (not openmcl)) @@ -325,7 +318,7 @@ (defvar *pg-client-encoding*) (defun implementation-name-for-encoding (encoding) - (%sysdep "client encoding to external format name" + (%sysdep "convert from client encoding to external format name" #+(and clisp unicode) (cond ((string-equal encoding "SQL_ASCII") charset:ascii) ((string-equal encoding "LATIN1") charset:iso-8859-1) @@ -344,12 +337,12 @@ ((string-equal encoding "LATIN9") :latin9) ((string-equal encoding "UTF8") :utf8) (t (error "unknown encoding ~A" encoding))) - #+(or cmu gcl ecl abcl openmcl) + #+(or cmu gcl ecl abcl openmcl lispworks) nil)) (defun convert-string-to-bytes (string &optional (encoding *pg-client-encoding*)) (declare (type string string)) - (%sysdep "convert string to bytes" + (%sysdep "convert string to octet-array" #+(and clisp unicode) (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding)) #+(and allegro ics) @@ -358,7 +351,7 @@ #+(and :sbcl :sb-unicode) (sb-ext:string-to-octets string :external-format (implementation-name-for-encoding encoding)) - #+(or cmu gcl ecl abcl openmcl) + #+(or cmu gcl ecl abcl openmcl lispworks) (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal) (let ((octets (make-array (length string) :element-type '(unsigned-byte 8)))) (map-into octets #'char-code string)) @@ -376,7 +369,7 @@ ;; for implementations that have no support for character ;; encoding, we assume that the encoding is an octet-for-octet ;; encoding, and convert directly - #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl) + #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl lispworks) (let ((string (make-string (length bytes)))) (map-into string #'code-char bytes)))) From emarsden at common-lisp.net Sun Sep 24 15:08:39 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 24 Sep 2006 11:08:39 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060924150839.159FB5533D@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv8006 Modified Files: v3-protocol.lisp TODO Log Message: Make the v3 protocol ERROR-RESPONSE inherit from BACKEND-ERROR. --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/19 06:57:28 1.23 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/24 15:08:38 1.24 @@ -14,7 +14,7 @@ :type (or null stream)))) -(define-condition error-response (postgresql-error) +(define-condition error-response (backend-error) ((severity :initarg :severity :reader error-response-severity) (code :initarg :code @@ -122,7 +122,7 @@ (apply #'cerror "Try to continue, should do a rollback" 'error-response - args))) + (append (list :reason "Backend error") args)))) (defun read-and-handle-notification-response (connection packet) @@ -282,6 +282,9 @@ (string (convert-string-from-bytes octets encoding))) string))) + +(defgeneric read-octets-from-packet (packet length)) + (defmethod read-octets-from-packet ((packet pg-packet) (length integer)) (let ((result (make-array length :element-type '(unsigned-byte 8)))) (with-slots (data position) packet --- /project/pg/cvsroot/pg/TODO 2006/09/23 12:24:28 1.3 +++ /project/pg/cvsroot/pg/TODO 2006/09/24 15:08:38 1.4 @@ -1,3 +1,7 @@ + - rethink the error signaling code (perhaps implement finer-grained + exceptions when using the v3 protocol) + + - SSL support From emarsden at common-lisp.net Sun Sep 24 15:14:38 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 24 Sep 2006 11:14:38 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060924151438.A991A56019@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv8537 Modified Files: pg-tests.lisp Log Message: Added numerous additional tests, for string support, various types of errors signaled by PostgreSQL, integer overflow, transactions, arrays, bit-tables, prepared statements using TEXT parameters. --- /project/pg/cvsroot/pg/pg-tests.lisp 2005/07/17 13:49:43 1.10 +++ /project/pg/cvsroot/pg/pg-tests.lisp 2006/09/24 15:14:38 1.11 @@ -1,6 +1,6 @@ ;;; pg-tests.lisp -- incomplete test suite ;;; -;;; Author: Eric Marsden +;;; Author: Eric Marsden ;; ;; ;; These tests assume that a table named "test" is defined in the @@ -22,13 +22,21 @@ ;; !!! CHANGE THE VALUES HERE !!! (defun call-with-test-connection (function) - (with-pg-connection (conn "test" "pgdotlisp") + (with-pg-connection (conn "test" "pgdotlisp" + :host "localhost" + ;; :host "/var/run/postgresql/" + ) (funcall function conn))) (defmacro with-test-connection ((conn) &body body) `(call-with-test-connection (lambda (,conn) , at body))) +(defun check-single-return (conn sql expected &key (test #'eql)) + (let ((res (pg-exec conn sql))) + (assert (funcall test expected (first (pg-result res :tuple 0)))))) + + (defun test-insert () (format *debug-io* "Testing INSERT & SELECT on integers ...~%") (with-test-connection (conn) @@ -43,10 +51,9 @@ i (* i i)) :do (pg-exec conn sql)) (setq created t) - (setq res (pg-exec conn "SELECT count(val) FROM count_test")) - (assert (eql 100 (first (pg-result res :tuple 0)))) - (setq res (pg-exec conn "SELECT sum(key) FROM count_test")) - (assert (eql 5050 (first (pg-result res :tuple 0)))) + (pg-exec conn "VACUUM count_test") + (check-single-return conn "SELECT count(val) FROM count_test" 100) + (check-single-return conn "SELECT sum(key) FROM count_test" 5050) ;; this iterator does the equivalent of the sum(key) SQL statement ;; above, but on the client side. (pg-for-each conn "SELECT key FROM count_test" @@ -71,10 +78,8 @@ :for sql = (format nil "INSERT INTO count_test_float VALUES(~d, ~f)" i i) :do (pg-exec conn sql)) - (setq res (pg-exec conn "SELECT count(val) FROM count_test_float")) - (assert (eql 1000 (first (pg-result res :tuple 0)))) - (setq res (pg-exec conn "SELECT sum(key) FROM count_test_float")) - (assert (float-eql 500500.0 (first (pg-result res :tuple 0)))) + (check-single-return conn "SELECT count(val) FROM count_test_float" 1000) + (check-single-return conn "SELECT sum(key) FROM count_test_float" 500500.0 :test #'float-eql) ;; this iterator does the equivalent of the sum(key) SQL statement ;; above, but on the client side. (pg-for-each conn "SELECT val FROM count_test_float" @@ -86,8 +91,7 @@ (defun test-insert/numeric () (format *debug-io* "Testing INSERT & SELECT on NUMERIC ...~%") (with-test-connection (conn) - (let ((res nil) - (sum 0) + (let ((sum 0) (created nil)) (unwind-protect (progn @@ -97,10 +101,10 @@ :for sql = (format nil "INSERT INTO count_test_numeric VALUES(~d, ~f)" i i) :do (pg-exec conn sql)) - (setq res (pg-exec conn "SELECT count(val) FROM count_test_numeric")) - (assert (eql 1000 (first (pg-result res :tuple 0)))) - (setq res (pg-exec conn "SELECT sum(key) FROM count_test_numeric")) - (assert (eql 500500 (first (pg-result res :tuple 0)))) + (check-single-return conn "SELECT count(val) FROM count_test_numeric" 1000) + (let ((res (pg-exec conn "EXPLAIN SELECT count(val) FROM count_test_numeric"))) + (assert (string= "EXPLAIN" (pg-result res :status)))) + (check-single-return conn "SELECT sum(key) FROM count_test_numeric" 500500) ;; this iterator does the equivalent of the sum(key) SQL statement ;; above, but on the client side. (pg-for-each conn "SELECT val FROM count_test_numeric" @@ -117,8 +121,8 @@ (progn (pg-exec conn "CREATE TABLE pgltest (a timestamp, b abstime, c time, d date)") (setq created t) - (pg-exec conn "INSERT INTO pgltest VALUES " - "(current_timestamp, 'now', 'now', 'now')") + (pg-exec conn "COMMENT ON TABLE pgltest is 'pg-dot-lisp testing DATE and TIMESTAMP parsing'") + (pg-exec conn "INSERT INTO pgltest VALUES (current_timestamp, 'now', 'now', 'now')") (let* ((res (pg-exec conn "SELECT * FROM pgltest")) (parsed (first (pg-result res :tuples)))) (format t "attributes ~a~%" (pg-result res :attributes)) @@ -145,10 +149,47 @@ (let ((sum 0)) (pg-for-each conn "SELECT * FROM pgbooltest" (lambda (tuple) (when (first tuple) (incf sum (second tuple))))) - (assert (eql 42 sum)))) + (assert (eql 42 sum))) + (pg-exec conn "ALTER TABLE pgbooltest ADD COLUMN foo int2") + (pg-exec conn "INSERT INTO pgbooltest VALUES ('t', -1, 1)") + (let ((sum 0)) + (pg-for-each conn "SELECT * FROM pgbooltest" + (lambda (tuple) (when (first tuple) (incf sum (second tuple))))) + (assert (eql 41 sum)))) (when created (pg-exec conn "DROP TABLE pgbooltest")))))) + +(defun test-integer-overflow () + (format *debug-io* "Testing integer overflow signaling ...~%") + (with-test-connection (conn) + (let ((created nil)) + (unwind-protect + (progn + (pg-exec conn "CREATE TABLE pg_int_overflow (a INTEGER, b INTEGER)") + (setq created t) + (handler-case + (loop :for i :from 10 :by 100 + :do (pg-exec conn (format nil "INSERT INTO pg_int_overflow VALUES (~D, ~D)" i (* i i))) + (check-single-return conn (format nil "SELECT b FROM pg_int_overflow WHERE a = ~D" i) (* i i))) + (pg:backend-error (exc) + (format *debug-io* "OK: integer overflow handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: integer overflow not handled: ~A~%" exc)))) + (when created + (pg-exec conn "DROP TABLE pg_int_overflow")))))) + +(defun test-strings () + (format *debug-io* "Testing strings ...~%") + (with-test-connection (conn) + (check-single-return conn "SELECT POSITION('4' IN '1234567890')" 4) + (check-single-return conn "SELECT SUBSTRING('1234567890' FROM 4 FOR 3)" "456" :test #'string-equal) + (check-single-return conn "SELECT 'indio' LIKE 'in__o'" t) + (check-single-return conn "SELECT replace('yabadabadoo', 'ba', '123')" "ya123da123doo" :test #'string-equal) + (check-single-return conn "select md5('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'::bytea)" + "d174ab98d277d9f5a5611c2c9f419d9f" :test #'string-equal))) + + (defun test-integrity () (format *debug-io* "Testing integrity constaint signaling ...~%") (with-test-connection (conn) @@ -167,12 +208,131 @@ (when created (pg-exec conn "DROP TABLE pgintegritycheck")))))) + +(defun test-error-handling () + (format *debug-io* "Testing error handling ...~%") + (with-test-connection (conn) + ;; error handling for non-existant table + (handler-case (pg-exec conn "SELECT * FROM inexistant_table") + (pg:backend-error (exc) + (format *debug-io* "OK: non-existant table error handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + ;; test for an ABORT when not in a transaction + (handler-case (pg-exec conn "ABORT") + (pg:backend-error (exc) + (format *debug-io* "OK: ABORT outside transaction handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + ;; test division by zero + (handler-case (pg-exec conn "SELECT 1/0::int8") + (pg:backend-error (exc) + (format *debug-io* "OK: integer division by zero handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT 1/0::float4") + (pg:backend-error (exc) + (format *debug-io* "OK: floating point division by zero handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "DROP OPERATOR = (int4, nonesuch)") + (pg:backend-error (exc) + (format *debug-io* "OK: drop non-existant operator handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "EXPLAIN WHY MYSQL SUCKS") + (pg:backend-error (exc) + (format *debug-io* "OK: syntax error handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT DISTINCT on (foobar) * from pg_database") + (pg:backend-error (exc) + (format *debug-io* "OK: selected attribute not in table handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))))) + +(defun test-transactions () + (format *debug-io* "Testing transactions ...~%") + (with-test-connection (conn) + (let ((created nil)) + (unwind-protect + (progn + (pg-exec conn "CREATE TABLE truncating (a INTEGER PRIMARY KEY)") + (setq created t) + (pg-exec conn" INSERT INTO truncating VALUES (1)") + (pg-exec conn "INSERT INTO truncating VALUES (2)") + (let ((res (pg-exec conn "SELECT * FROM truncating"))) + (assert (eql 2 (length (pg-result res :tuples))))) + ;; emit a TRUNCATE but then abort the transaction + (ignore-errors + (with-pg-transaction conn + (pg-exec conn "TRUNCATE truncating") + (error "oops, aborting to force a rollback"))) + (let ((res (pg-exec conn "SELECT * FROM truncating"))) + (assert (eql 2 (length (pg-result res :tuples))))) + (with-pg-transaction conn + (pg-exec conn "TRUNCATE truncating")) + (let ((res (pg-exec conn "SELECT * FROM truncating"))) + (assert (zerop (length (pg-result res :tuples)))))) + (when created + (pg-exec conn "DROP TABLE truncating")))))) + +(defun test-arrays () + (format *debug-io* "Testing array support ... ~%") + (with-test-connection (conn) + (let ((created nil)) + (unwind-protect + (progn + (pg-exec conn "CREATE TABLE arrtest ( + a int2[], + b int4[][][], + c name[], + d text[][], + e float8[], + f char(5)[], + g varchar(5)[])") + (setq created t) + (pg-exec conn "INSERT INTO arrtest (a[1:5], b[1:1][1:2][1:2], c, d, f, g) + VALUES ('{1,2,3,4,5}', '{{{0,0},{1,2}}}', '{}', '{}', '{}', '{}')") + (pg-exec conn "UPDATE arrtest SET e[0] = '1.1'") + (pg-exec conn "UPDATE arrtest SET e[1] = '2.2'") + (pg-for-each conn "SELECT * FROM arrtest" + (lambda (tuple) (princ tuple) (terpri))) + (pg-exec conn "SELECT a[1], b[1][1][1], c[1], d[1][1], e[0] FROM arrtest")) + (when created + (pg-exec conn "DROP TABLE arrtest")))))) + +(defun test-bit-tables () + (format *debug-io* "Testing bit-tables ... ~%") + (with-test-connection (conn) + (let ((created nil)) + (unwind-protect + (progn + (pg-exec conn "CREATE TABLE BIT_TABLE(b BIT(11))") + (setq created t) + (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'00000000000')") + (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'11011000000')") + (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'01010101010')") + (handler-case (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'101011111010')") + (pg:backend-error (exc) + (format *debug-io* "OK: bittable overflow handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: undetected bittable overflow (type ~A): ~A~%" + (type-of exc) exc))) + (pg-for-each conn "SELECT * FROM bit_table" + (lambda (tuple) (format t "bits: ~A~%" tuple)))) + (when created + (pg-exec conn "DROP TABLE bit_table")))))) + (defun test-introspection () (format *debug-io* "Testing support for introspection ...~%") (with-test-connection (conn) (dotimes (i 500) (pg-tables conn)))) +;; (let ((res (pg-exec conn "SELECT pg_stat_file('/tmp')"))) +;; (format t "stat(\"/tmp\"): ~S~%" (pg-result res :tuples))))) + ;; Fibonnaci numbers with memoization via a database table (defun fib (n) @@ -205,10 +365,10 @@ (progn (pg-exec conn "CREATE TABLE fib (n INTEGER, fibn INT8)") (setq created t) - (funwrap 'fib) + #+cmu (funwrap 'fib) (time (setq non-memoized (fib 40))) #+cmu (fwrap 'fib #'memoize-fib :user-data conn) - (update-fwrappers 'fib) ; remove stale conn user-data object + #+cmu (update-fwrappers 'fib) ; remove stale conn user-data object (time (setq memoized (fib 40))) (format t "~S" (pg-exec conn "SELECT COUNT(n) FROM fib")) (assert (eql non-memoized memoized))) @@ -312,11 +472,40 @@ (with-test-connection (conn) (pg-exec conn "DROP TABLE pgmt"))) +#+(and sbcl sb-thread) +(defun test-multiprocess () + (format *debug-io* "Testing multiprocess database access~%") + (with-test-connection (conn) + (pg-exec conn "CREATE TABLE pgmt (a TEXT, b INTEGER, C FLOAT)")) + (let ((dio *debug-io*)) + (flet ((producer () + (with-test-connection (con) + (dotimes (i 5000) + (if (= (mod i 1000) 0) (format dio "~s connected over ~S producing ~a~%" + sb-thread:*current-thread* mycony i)) + (pg-exec con (format nil "INSERT INTO pgmt VALUES (~S, ~D, ~F)" i i i)) + (when (zerop (mod i 100)) + (pg-exec con "COMMIT WORK"))))) + (consumer () + (with-test-connection (con) + (dotimes (i 10) + (sleep 1) + (format dio "~&consumer on ~a" i) + (let ((res (pg-exec con "SELECT count(*) FROM pgmt"))) + (format *debug-io* " Consumer sees ~D rows~%" + (first (pg-result res :tuple 0)))))))) + (let ((prs (loop :for x :from 0 :below 3 + :collect (sb-thread:make-thread #'producer :name "PG data producer"))) + (co (sb-thread:make-thread #'consumer :name "PG data consumer"))) + (loop :while (some 'sb-thread:thread-alive-p (append prs (list co))) + :do (sleep 5)))) + (with-test-connection (conn) + (pg-exec conn "DROP TABLE pgmt")))) (defun test-pbe () (with-test-connection (conn) (when (pg-supports-pbe conn) - (format *debug-io* "~&Testing pbe...") + (format *debug-io* "~&Testing PBE/int4 ...") (let ((res nil) (count 0) (created nil)) @@ -324,7 +513,6 @@ (progn (pg-exec conn "CREATE TABLE count_test(key int, val int)") (setq created t) - (format *debug-io* "~&table created") (pg-prepare conn "ct_insert" "INSERT INTO count_test VALUES ($1, $2)" '("int4" "int4")) @@ -349,14 +537,48 @@ (when created (pg-exec conn "DROP TABLE count_test"))))))) +(defun test-pbe-text () + (with-test-connection (conn) + (when (pg-supports-pbe conn) + (format *debug-io* "~&Testing PBE/text...") + (let ((res nil) + (count 0) + (created nil)) + (unwind-protect + (progn + (pg-exec conn "CREATE TABLE pbe_text_test(key int, val text)") + (setq created t) + (pg-prepare conn "ct_insert/text" + "INSERT INTO pbe_text_test VALUES ($1, $2)" + '("int4" "text")) + (loop :for i :from 1 :to 100 + :do + (pg-bind conn + "ct_portal/text" "ct_insert/text" + `((:int32 ,i) + (:string ,(format nil "~a" (* i i))))) + (pg-execute conn "ct_portal/text") + (pg-close-portal conn "ct_portal/text")) + (format *debug-io* "~&data inserted") + (setq res (pg-exec conn "SELECT count(val) FROM pbe_text_test")) + (assert (eql 100 (first (pg-result res :tuple 0)))) + (setq res (pg-exec conn "SELECT sum(key) FROM pbe_text_test")) + (assert (eql 5050 (first (pg-result res :tuple 0)))) + ;; this iterator does the equivalent of the sum(key) SQL statement + ;; above, but on the client side. + (pg-for-each conn "SELECT key FROM pbe_text_test" + (lambda (tuple) (incf count (first tuple)))) + (assert (= 5050 count))) + (when created + (pg-exec conn "DROP TABLE pbe_text_test"))))))) + (defun test-copy-in-out () (with-test-connection (conn) (ignore-errors (pg-exec conn "DROP TABLE foo")) - (pg-exec conn "CREATE TABLE foo (a int, b int)") - (pg-exec conn "INSERT INTO foo VALUES (1, 2)") - (pg-exec conn "INSERT INTO foo VALUES (2, 4)") - + (pg-exec conn "CREATE TABLE foo (a int, b int, c text)") + (pg-exec conn "INSERT INTO foo VALUES (1, 2, 'two')") + (pg-exec conn "INSERT INTO foo VALUES (2, 4, 'four')") (with-open-file (stream "/tmp/foo-out" :direction :output :element-type '(unsigned-byte 8) @@ -364,25 +586,43 @@ :if-exists :overwrite) (setf (pgcon-sql-stream conn) stream) (pg-exec conn "COPY foo TO stdout")) - (pg-exec conn "DELETE FROM foo") (with-open-file (stream "/tmp/foo-out" [67 lines skipped] From emarsden at common-lisp.net Sun Sep 24 15:50:18 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 24 Sep 2006 11:50:18 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060924155018.4D9CE76308@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv15007 Modified Files: v3-protocol.lisp sysdep.lisp Log Message: Disabling buffering of the socket stream on CLISP greatly improves performance. --- /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/24 15:08:38 1.24 +++ /project/pg/cvsroot/pg/v3-protocol.lisp 2006/09/24 15:50:18 1.25 @@ -374,7 +374,8 @@ (%send-net-int stream (char-code code) 1) (%send-net-int stream length 4 ) - (write-sequence data stream))) + (write-sequence data stream) + (%flush connection))) (defun pg-connect/v3 (dbname user &key (host "localhost") (port 5432) (password "")) --- /project/pg/cvsroot/pg/sysdep.lisp 2006/09/23 12:24:28 1.15 +++ /project/pg/cvsroot/pg/sysdep.lisp 2006/09/24 15:50:18 1.16 @@ -1,7 +1,7 @@ ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden -;;; Time-stamp: <2006-09-20 emarsden> +;;; Time-stamp: <2006-09-24 emarsden> ;; ;; @@ -127,7 +127,9 @@ (handler-case (#+lisp=cl socket:socket-connect #-lisp=cl lisp:socket-connect - port host :element-type '(unsigned-byte 8)) + port host + :element-type '(unsigned-byte 8) + :buffered t) (error (e) (declare (ignore e)) (error 'connection-failure :host host :port port)))) From emarsden at common-lisp.net Sun Sep 24 21:19:30 2006 From: emarsden at common-lisp.net (emarsden) Date: Sun, 24 Sep 2006 17:19:30 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060924211930.152381E017@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv17996 Modified Files: pg-tests.lisp Log Message: More additions to the testing code: testing reporting of floating point overflow and underflow, array syntax, more bitvector tests. --- /project/pg/cvsroot/pg/pg-tests.lisp 2006/09/24 15:14:38 1.11 +++ /project/pg/cvsroot/pg/pg-tests.lisp 2006/09/24 21:19:30 1.12 @@ -110,6 +110,8 @@ (pg-for-each conn "SELECT val FROM count_test_numeric" (lambda (tuple) (incf sum (first tuple)))) (assert (eql 500500 sum))) + (check-single-return conn "SELECT 'infinity'::float4 + 'NaN'::float4" 'NAN) + (check-single-return conn "SELECT 1 / (!! 2)" 1/2) (when created (pg-exec conn "DROP TABLE count_test_numeric")))))) @@ -175,7 +177,12 @@ (pg:backend-error (exc) (format *debug-io* "OK: integer overflow handled: ~A~%" exc)) (error (exc) - (format *debug-io* "FAIL: integer overflow not handled: ~A~%" exc)))) + (format *debug-io* "FAIL: integer overflow not handled: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT (10000 * 10000.0 / 45)::int2") + (pg:backend-error (exc) + (format *debug-io* "OK: int2 overflow handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: int2 overflow not handled: ~A~%" exc)))) (when created (pg-exec conn "DROP TABLE pg_int_overflow")))))) @@ -187,7 +194,8 @@ (check-single-return conn "SELECT 'indio' LIKE 'in__o'" t) (check-single-return conn "SELECT replace('yabadabadoo', 'ba', '123')" "ya123da123doo" :test #'string-equal) (check-single-return conn "select md5('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'::bytea)" - "d174ab98d277d9f5a5611c2c9f419d9f" :test #'string-equal))) + "d174ab98d277d9f5a5611c2c9f419d9f" :test #'string-equal) + (check-single-return conn "SELECT /* embedded comment */ CASE 'a' WHEN 'a' THEN 42 ELSE 2 END" 42))) (defun test-integrity () @@ -235,16 +243,53 @@ (format *debug-io* "OK: floating point division by zero handled: ~A~%" exc)) (error (exc) (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT (4 / 4e40)::float4") + (pg:backend-error (exc) + (format *debug-io* "OK: floating point underflow handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled floating point underflow: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT (4 / 4e400)::float8") + (pg:backend-error (exc) + (format *debug-io* "OK: double precision floating point underflow handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled double precision floating point underflow: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT (log(-1))::float8") + (pg:backend-error (exc) + (format *debug-io* "OK: negative log handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: undetected negative log: ~A~%" exc))) (handler-case (pg-exec conn "DROP OPERATOR = (int4, nonesuch)") (pg:backend-error (exc) (format *debug-io* "OK: drop non-existant operator handled: ~A~%" exc)) (error (exc) (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT CONVERT('??foo??' USING utf8_to_big5)") + (pg:backend-error (exc) + (format *debug-io* "OK: encoding error handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled encoding error: ~A~%" exc))) (handler-case (pg-exec conn "EXPLAIN WHY MYSQL SUCKS") (pg:backend-error (exc) (format *debug-io* "OK: syntax error handled: ~A~%" exc)) (error (exc) (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT '{ }}'::text[]") + (pg:backend-error (exc) + (format *debug-io* "OK: array syntax error handled: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled error: ~A~%" exc))) + (handler-case (pg-exec conn "SET SESSION AUTHORIZATION postgres") + (pg:backend-error (exc) + (format *debug-io* "OK: authorization error: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: unhandled authorization error: ~A~%" exc))) + (handler-case (pg-exec conn "SELECT " (let ((sql "array[42]")) + (dotimes (i 2000) + (setq sql (format nil "array_prepend(~d, ~a)" i sql))) sql)) + (pg:backend-error (exc) + (format *debug-io* "OK: stack overflow detected: ~A~%" exc)) + (error (exc) + (format *debug-io* "FAIL: undetected stack overflow: ~A~%" exc))) (handler-case (pg-exec conn "SELECT DISTINCT on (foobar) * from pg_database") (pg:backend-error (exc) (format *debug-io* "OK: selected attribute not in table handled: ~A~%" exc)) @@ -267,7 +312,7 @@ (ignore-errors (with-pg-transaction conn (pg-exec conn "TRUNCATE truncating") - (error "oops, aborting to force a rollback"))) + (pg-exec conn "SELECT sqrt(-2)"))) (let ((res (pg-exec conn "SELECT * FROM truncating"))) (assert (eql 2 (length (pg-result res :tuples))))) (with-pg-transaction conn @@ -283,6 +328,9 @@ (let ((created nil)) (unwind-protect (progn + (check-single-return conn "SELECT 33.4 > ALL(ARRAY[1,2,3])" t) + (check-single-return conn "SELECT 33.4 = ANY(ARRAY[1,2,3])" nil) + (check-single-return conn "SELECT 'foo' LIKE ANY (ARRAY['%a', '%o'])" t) (pg-exec conn "CREATE TABLE arrtest ( a int2[], b int4[][][], @@ -308,6 +356,8 @@ (let ((created nil)) (unwind-protect (progn + (check-single-return conn "SELECT POSITION(B'1010' IN B'000001010')" 6) + (check-single-return conn "SELECT POSITION(B'1011011011011' IN B'00001011011011011')" 5) (pg-exec conn "CREATE TABLE BIT_TABLE(b BIT(11))") (setq created t) (pg-exec conn "INSERT INTO BIT_TABLE VALUES (B'00000000000')") From emarsden at common-lisp.net Sat Sep 30 16:51:13 2006 From: emarsden at common-lisp.net (emarsden) Date: Sat, 30 Sep 2006 12:51:13 -0400 (EDT) Subject: [pg-cvs] CVS pg Message-ID: <20060930165113.189427634C@common-lisp.net> Update of /project/pg/cvsroot/pg In directory clnet:/tmp/cvs-serv6047 Modified Files: sysdep.lisp pg.asd Log Message: Add unix-domain socket support for Allegro CL (tested with Express edition for Linux/x86). --- /project/pg/cvsroot/pg/sysdep.lisp 2006/09/24 15:50:18 1.16 +++ /project/pg/cvsroot/pg/sysdep.lisp 2006/09/30 16:51:12 1.17 @@ -1,14 +1,13 @@ ;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden -;;; Time-stamp: <2006-09-24 emarsden> +;;; Time-stamp: <2006-09-30 emarsden> ;; ;; (in-package :postgresql) (eval-when (:compile-toplevel :load-toplevel :execute) - #+allegro (require :socket) #+lispworks (require "comm") #+cormanlisp (require :sockets) #+armedbear (require :socket)) @@ -165,14 +164,22 @@ (defun socket-connect (port host) (declare (type integer port)) (handler-case - (socket:make-socket :remote-host host - :remote-port port - :format :binary) - (error (e) + (if (eql #\/ (char host 0)) + (socket:make-socket :type :stream + :address-family :file + :connect :active + ;; :local-filename (format nil "~A.s.PGSQL.~D" (string host) port) + :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port) + :format :binary) + (socket:make-socket :remote-host host + :remote-port port + :connect :active + :format :binary)) + (error (e) (error 'connection-failure - :host host - :port port - :transport-error e)))) + :host host + :port port + :transport-error e)))) ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary ;; streams. Fixed in version 4.3. @@ -283,6 +290,9 @@ (eval-when (:load-toplevel :execute :compile-toplevel) (require :socket)) +;; could provide support for connections via a unix-domain socket by +;; using http://freshmeat.net/projects/j-buds/ (requires linking to a +;; shared libary) #+armedbear (defun socket-connect (port host) (declare (type integer port)) --- /project/pg/cvsroot/pg/pg.asd 2006/09/18 19:10:01 1.10 +++ /project/pg/cvsroot/pg/pg.asd 2006/09/30 16:51:12 1.11 @@ -17,9 +17,8 @@ (defsystem :pg :name "Socket-level PostgreSQL interface" :author "Eric Marsden" - :version "0.22" + :version "0.24" :depends-on ( - #+allegro :socket #+lispworks "comm" #+cormanlisp :sockets #+sbcl :sb-bsd-sockets