cl-pg-20061216.orig/0002755000175000017500000000000010560035327014153 5ustar pvaneyndpvaneyndcl-pg-20061216.orig/debian/0002755000175000017500000000000010560035327015375 5ustar pvaneyndpvaneyndcl-pg-20061216.orig/debian/changelog0000644000175000017500000000421210560035327017244 0ustar pvaneyndpvaneyndcl-pg (20061225-2) UNRELEASED; urgency=low * token new version -- Peter Van Eynde Thu, 26 Jan 2006 16:48:40 +0100 cl-pg (20061225-1) unstable; urgency=low * New upstream * Better sbcl unicode support * Improved asdf compatibility * Documentation for pg-close-portal fixed in upstream (Closes: #349778) -- Peter Van Eynde Wed, 25 Jan 2006 20:32:49 +0100 cl-pg (20050717-1) unstable; urgency=low * token new darcs version * unicode fix * New upstream. * Now no longer a native package to ease NMU and ubuntu related forks. -- Peter Van Eynde Mon, 1 Aug 2005 11:12:33 +0200 cl-pg (20040920) unstable; urgency=low * New upstream release: Add support for the SQL NUMERIC type, thanks to Risto Sakari Laakso. * Fixed Extended queries with never versions of postgreSQL -- Peter Van Eynde Mon, 20 Sep 2004 00:13:39 +0200 cl-pg (20040810) unstable; urgency=low * Now a debian-native package. * Support for the v3 protocol * Support for parse/bind/execute parts of that protocol * Support for COPY IN/OUT modes * New implementation fixes many bugs, among then: Closes: #244816 -- Peter Van Eynde Tue, 10 Aug 2004 13:08:31 +0200 cl-pg (0.19-1) unstable; urgency=low * New upstream. * Upstream has fixed write-sequence bug. Closes: #214963 -- Peter Van Eynde Wed, 22 Oct 2003 11:46:59 +0200 cl-pg (0.18-3) unstable; urgency=low * Now also supports sbcl. -- Peter Van Eynde Fri, 18 Jul 2003 09:45:55 +0200 cl-pg (0.18-2) unstable; urgency=low * Changed section from libs to devel -- Peter Van Eynde Tue, 3 Jun 2003 15:12:49 +0200 cl-pg (0.18-1) unstable; urgency=low * New upstream release. -- Peter Van Eynde Fri, 23 May 2003 10:01:42 +0200 cl-pg (0.16-1) unstable; urgency=low * Changed architecture to all * Initial Release. Closes: #170774 * Actually based on unreleased 0.16 with a fix for a few cmucl bugs -- Peter Van Eynde Tue, 3 Dec 2002 10:02:44 +0100 cl-pg-20061216.orig/debian/compat0000644000175000017500000000000210560035327016571 0ustar pvaneyndpvaneynd4 cl-pg-20061216.orig/debian/control0000644000175000017500000000121710560035327016777 0ustar pvaneyndpvaneyndSource: cl-pg Section: devel Priority: optional Maintainer: Peter Van Eynde Build-Depends-Indep: debhelper (>> 4.0.0) Standards-Version: 3.6.2.1 Package: cl-pg Architecture: all Depends: common-lisp-controller (>= 3.45), cl-asdf Description: Common Lisp library that provides a socket level postgresql interface Pg is a socket-level interface to the PostgreSQL object-relational Database. The Library implements the client part of the frontend/backend protocol, so does not require interfacing with the libpq library. SQL types are converted to the equivalent Common Lisp types where possible. Supports large objects (BLOBs). cl-pg-20061216.orig/debian/copyright0000644000175000017500000000214310560035327017326 0ustar pvaneyndpvaneyndThis package was debianized by Peter Van Eynde on Tue, 26 Nov 2002 10:56:05 +0100. It is a project hosted at: http://www.common-lisp.net/project/pg/ Upstream Author: Eric Marsden Copyright: This package is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This package is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this package; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA On Debian GNU/Linux systems, the complete text of the GNU Lesser General Public License can be found in `/usr/share/common-licenses/LGPL'. cl-pg-20061216.orig/debian/dirs0000644000175000017500000000010110560035327016247 0ustar pvaneyndpvaneynd/usr/share/common-lisp/systems/ /usr/share/common-lisp/source/pg cl-pg-20061216.orig/debian/install0000644000175000017500000000005710560035327016766 0ustar pvaneyndpvaneynd*.lisp pg.asd usr/share/common-lisp/source/pg/ cl-pg-20061216.orig/debian/links0000644000175000017500000000011410560035327016432 0ustar pvaneyndpvaneyndusr/share/common-lisp/source/pg/pg.asd usr/share/common-lisp/systems/pg.asd cl-pg-20061216.orig/debian/rules0000644000175000017500000000215310560035327016451 0ustar pvaneyndpvaneynd#!/usr/bin/make -f # Sample debian/rules that uses debhelper. # GNU copyright 1997 to 1999 by Joey Hess. # Uncomment this to turn on verbose mode. #export DH_VERBOSE=1 ifneq (,$(findstring debug,$(DEB_BUILD_OPTIONS))) CFLAGS += -g endif ifeq (,$(findstring nostrip,$(DEB_BUILD_OPTIONS))) INSTALL_PROGRAM += -s endif configure: configure-stamp configure-stamp: dh_testdir touch configure-stamp build: build-stamp build-stamp: configure-stamp dh_testdir touch build-stamp clean: dh_testdir dh_testroot rm -f build-stamp configure-stamp dh_clean install: build dh_testdir dh_testroot dh_clean -k dh_installdirs # Build architecture-independent files here. binary-arch: build install # We have nothing to do by default. # Build architecture-dependent files here. binary-indep: build install dh_testdir dh_testroot dh_installdocs dh_install dh_installchangelogs NEWS ChangeLog dh_link dh_strip dh_lisp dh_compress dh_fixperms dh_installdeb dh_shlibdeps dh_gencontrol dh_md5sums dh_builddeb binary: binary-indep binary-arch .PHONY: build clean binary-indep binary-arch binary install configure cl-pg-20061216.orig/defpackage.lisp0000644000175000017500000000216610560035327017121 0ustar pvaneyndpvaneynd(defpackage :postgresql (:nicknames :pg) (:use :common-lisp :pg-md5 #+cmu :alien #+cmu :c-call #+openmcl :ccl) #+openmcl (:shadow ccl:socket-connect) (:export #:pg-connect #:pg-exec #:pg-result #:pg-disconnect #:pgcon-sql-stream #:*pg-disable-type-coercion* #:*pg-client-encoding* #:pg-databases #:pg-tables #:pg-columns #:pg-backend-version #:pg-date-style #:pg-client-encoding #:with-pg-connection #:with-pg-transaction #:pg-for-each #:pglo-create #:pglo-open #:pglo-close #:pglo-read #:pglo-write #:pglo-lseek #:pglo-tell #:pglo-unlink #:pglo-import #:pglo-export #:pg-supports-pbe #:pg-prepare #:pg-bind #:pg-execute #:pg-close-portal #:pg-close-statement #:postgresql-error #:connection-failure #:authentication-failure #:protocol-error #:backend-error)) ;; EOF cl-pg-20061216.orig/CREDITS0000644000175000017500000000143110560035327015170 0ustar pvaneyndpvaneyndEric Marsden: Author of the initial version of pg-dot-lisp. Peter Van Eynde: Wrote the support for the v3 PostgreSQL protocol. Marc Battyani: Lispworks port and bugfixes Johannes Grødem : Fix to parsing of DATE types Doug McNaught: Bugfixes Howard Ding: Bugfixes Ernst Jeschek: Pointed out a bug in float parsing Brian Lui: Provided fixes for ACL6 James Anderson: Provided a fix for a change in PostgreSQL timestamp format Brian Mastenbrook: Implemented MD5 authentication support Risto Sakari Laakso: Provided a parser for the NUMERIC type Andreas Fuchs Patch to allow connection via a unix socket with SBCL Katsuya Tomioka Patch to timezone handling in timestamp parsing (apologies for people who have been forgotten in this file) cl-pg-20061216.orig/NEWS0000644000175000017500000001133410560035327014652 0ustar pvaneyndpvaneynd=== Version 0.22, 2006-09-23 =========================================== - 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). pg-dot-lisp will attempt to connect to your database server using the new protocol, and upon failure will reconnect using the older protocol. To avoid this once-per-connection overhead if you know you're only using older PostgreSQL versions, use PG-CONNECT/V2 instead of PG-CONNECT. - split out functionality into more files - added preliminary support for character encodings, for when the encoding used by PostgreSQL for TEXT data differs from that used by the Common Lisp implementation for strings. === Version 0.20 (unreleased) ========================================== - added more tests for BOOLEAN types, to check the handling of PostgreSQL errors (violation of an integrity constraint leads to an error of type PG:BACKEND-ERROR being signaled). For CMUCL users who use the multiprocessing support, there's a test that runs several data producers and a consumer in different threads. - error condition names (POSTGRESQL-ERROR, AUTHENTICATION-FAILURE, BACKEND-ERROR are now exported from the PG package. === Version 0.19, 2003-10-10 =========================================== - new multi-file organization: split out the system-dependent parts and the tests into separate files. An ASDF system description is provided in the file pg.asd. - change to WITH-PG-TRANSACTION: the previous version would abort the current transaction upon encountering an error, which made debugging difficult. The new version (thanks to Daniel Barlow) maintains the transaction open until you have exited the debugger. - support for connecting to PostgreSQL using a local socket instead of using TCP/IP, when you're on the same host as the backend. To enable, use a NIL host argument to PG-CONNECT. This makes it possible to connect to the database without enabling TCP/IP connections in the backend ("-i" option), and (depending on the access configuration parameters specified in pg_hba.conf) possibly without supplying a password. This is currently only supported for CMUCL and SBCL. - parser support for the INTERVAL type (you get this by subtracting two timestamps). They are coerced by pg-dot-lisp to a number of seconds, represented in floating point. - new configuration variable *PG-CLIENT-ENCODING*, that supports client-side encoding of text data, as per . Function PG-CLIENT-ENCODING, and corresponding setf function, that allows you to retrieve and modify the current client encoding. - new configuration variable *PG-DATE-STYLE* that allows you to change the style in which date types are printed. Function PG-DATE-STYLE that allows you to retrieve (and modify via its SETF function) the current backend's date style. - CMUCL: loading the file cmucl-install-subsystem.lisp (as a user who has write access to the directory where CMUCL is installed) will cause this package to be installed as a CMUCL "subsystem", that can thereafter be loaded by saying "(require :pg)". - SBCL: fix for new sb-bsd-sockets - support for a new Common Lisp implementation, Armed Bear Lisp for the JVM === Version 0.18, 2003-06-01 ============================================ - Fix for parsing of TIMESTAMP fields in PostgreSQL 7.3, thanks to James Anderson. These can now contain timezone and millisecond fields. cl-pg-20061216.orig/README0000644000175000017500000003556110560035327015043 0ustar pvaneyndpvaneyndpg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp Author: Eric Marsden Version: 0.24 Copyright (C) 1999,2000,2001,2002,2003,2004,2005,2006 Eric Marsden This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. For download information, mailing lists for suggestions and bug reports, see == Overview ========================================================= This module lets you access the PostgreSQL object-relational DBMS from Common Lisp. The code implements the client part of the socket-level frontend/backend protocol, rather than providing a wrapper around the libpq library. The module is capable of type coercions from a range of SQL types to the equivalent Lisp type. The only non portable code is the use of 'socket-connect' and (optional) some way of accessing the Unix crypt() function. Works with CMUCL, SBCL, CLISP, OpenMCL, ABCL, ACL, Lispworks, and MCL. CormanLisp has socket support but not for binary I/O. == Entry points ======================================================= (with-pg-connection ((con &rest open-args) &body body) A macro which opens a connection to database DBNAME, executes the BODY forms then disconnects. See function `pg-connect' for details of the connection arguments OPEN-ARGS. (with-pg-transaction con &body body) A macro which executes the BODY forms wrapped in an SQL transaction. CON is a connection to the database. If an error occurs during the execution of the forms, a ROLLBACK instruction is executed. (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 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 all the information returned by the database and return it in an opaque record PGRESULT. (pg-result pgresult what &rest args) -> info Extract information from the PGRESULT. WHAT can be one of * :connection * :status * :attributes * :tuples * :tuple tupleNumber * :oid `connection' allows you to retrieve the database connection. `status' is a string returned by the backend to indicate the status of the command; it is normally "SELECT" for a select command, "DELETE 1" if the deletion affected a single row, etc. `attributes' is a list of tuples providing metadata: the first component of each tuple is the attribute's name as a string, the second an integer representing its PostgreSQL type, and the third an integer representing the size of that type. `tuples' returns all the data retrieved from the database, as a list of lists, each list corresponding to one row of data returned by the backend. `tuple num' can be used to extract a specific tuple. `oid' allows you to retrieve the OID returned by the backend if the command was an insertion; the OID is a unique identifier for that row in the database (this is PostgreSQL-specific, please refer to the documentation for more details). (pg-for-each connection select-form callback) Calls CALLBACK on each tuple returned by SELECT-FORM. Declares a cursor for SELECT-FORM, then fetches tuples using repeated executions of FETCH 1, until no results are left. The cursor is then closed. The work is performed within a transaction. When you have a large amount of data to handle, this usage is more efficient than fetching all the tuples in one go. (pg-disconnect connection &key abort) -> nil Close the database connection. If the keyword argument ABORT is non-NIL, the database connection is closed immediately, without first attempting to send a disconnect packet to the PostgreSQL backend. === 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 "delete-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 installation there is a single database named "template1"). (pg-tables connection) -> list of strings Return a list of the tables present in the database to which we are currently connected. Only include user tables: system tables are excluded. (pg-columns connection table) -> list of strings Return a list of the columns (or attributes) in TABLE, which must be a table in the database to which we are currently connected. We only include the column names; if you want more 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 connected via CONN. Returns an OID (which is represented as an integer) which will allow you to use the large object. Optional ARGS are a Unix-style mode string which determines the permissions of the newly created large object, one of "r" for read-only permission, "w" for write-only, "rw" for read+write. Default is "r". Large-object functions MUST be used within a transaction (see the macro `with-pg-transaction'). (pglo-open conn oid . args) -> fd Open a large object whose unique identifier is OID (an integer) in the database to which we are connected via CONN. Optional ARGS is a Unix-style mode string as for pglo-create; which defaults to "r" read-only permissions. Returns a file descriptor (an integer) which can be used in other large-object functions. (pglo-close conn fd) Close the file descriptor FD which was associated with a large object. Note that this does not delete the large object; use PGLO-UNLINK for that. (pglo-read conn fd bytes) -> string Read BYTES from the file descriptor FD which is associated with a large object. Return a string which should be BYTES characters long. (pglo-write connection fd buf) Write the bytes contained in the string BUF to the large object associated with the file descriptor FD. (pglo-lseek conn fd offset whence) Do the equivalent of a lseek(2) on the file descriptor FD which is associated with a large object; ie reposition the read/write file offset for that large object to OFFSET (an integer). WHENCE has the same significance as in lseek(); it should be one of SEEK_SET (set the offset to the absolute position), SEEK_CUR (set the offset relative to the current offset) or SEEK_END (set the offset relative to the end of the file). WHENCE should be an integer whose values can be obtained from the header file (probably 0, 1 and 2 respectively). (pglo-tell conn oid) -> integer Do the equivalent of an ftell(3) on the file associated with the large object whose unique identifier is OID. Returns the current position of the file offset for the object's associated file descriptor, as an integer. (pglo-unlink conn oid) Remove the large object whose unique identifier is OID from the system (in the current implementation of large objects in PostgreSQL, each large object is associated with an object in the filesystem). (pglo-import conn filename) -> oid Create a new large object and initialize it to the data contained in the file whose name is FILENAME. Returns an OID (as an integer). Note that is operation is only syntactic sugar around the basic large-object operations listed above. (pglo-export conn oid filename) Create a new file named FILENAME and fill it with the contents of the large object whose unique identifier is OID. This operation is also syntactic sugar. Boolean variable `*PG-DISABLE-TYPE-COERCION*' which can be set to non-nil (before initiating a connection) to disable the library's type coercion facility. Default is t. SECURITY NOTE: please note that your postmaster has to be started with the `-i' option in order for it to accept TCP/IP connections (typically this is not the default setting). See the PostgreSQL documentation at for more information. Setting up PostgreSQL to accept TCP/IP connections has security implications; please consult the documentation for details. You can connect to the database using Unix domain sockets if you wish to avoid setting up PostgreSQL to listen on a TCP socket. pg.lisp is able to use the crypt authentication method to avoid sending the password in cleartext over the wire (this assumes access to the `crypt' function via the FFI -- see sysdep.lisp). It can also use md5 passwords (which are used with the WITH ENCRYPTED PASSWORD form of the CREATE USER command), thanks to Pierre Mai's portable md5 library. It does not support the Kerberos authentication method, nor OpenSSL connections (though this should not be difficult if your Common Lisp implementation is able to open SSL streams). It is also possible to use the port forwarding capabilities of ssh to establish a connection to the backend over TCP/IP, which provides both a secure authentication mechanism and encryption (and optionally compression) of data passing through the tunnel. Here's how to do it (thanks to Gene Selkov, Jr. for the description): 1. Establish a tunnel to the backend machine, like this: ssh -L 3333:backend.dom:5432 postgres@backend.dom The first number in the -L argument, 3333, is the port number of your end of the tunnel. The second number, 5432, is the remote end of the tunnel -- the port number your backend is using. The name or the address in between the port numbers belongs to the server machine, as does the last argument to ssh that also includes the optional user name. Without the user name, ssh will try the name you are currently logged on as on the client machine. You can use any user name the server machine will accept, not necessarily those related to postgres. 2. Now that you have a running ssh session, you can point pg.lisp to the local host at the port number which you specified in step 1. For example, (pg-connect "dbname" "user" :port 3333) You can omit the port argument if you chose 5432 as the local end of the tunnel, since pg.lisp defaults to this value. At various times, this code has been tested or reported to work with * CMUCL 18d, 18e, 19a, 19c on Solaris/SPARC and Linux/x86 * SBCL 0.9.2 to 0.9.16 on Linux/x86 * CLISP 2.30 on LinuxPPC and SPARC * OpenMCL 0.13.x and 0.14.x on LinuxPPC * Armed Bear Common Lisp * ACL 6.1 trial/x86 * Lispworks 4.3 on Linux and Windows * PostgreSQL versions 6.5, 7.0, 7.1.2, 7.2, 7.3, 7.4, 8.0, 8.1 You may be interested in using "pg-psql" by Harley Gorrell, which provides a psql-like listener interface to PostgreSQL (together with tabulated output), on top of this library. See cl-pg-20061216.orig/TODO0000644000175000017500000000135210560035327014642 0ustar pvaneyndpvaneynd - rethink the error signaling code (perhaps implement finer-grained exceptions when using the v3 protocol) - SSL support - add support for asynchronous events signaled by the backend, probably using implementation mechanisms such as CMUCL's SERVE-EVENT support - add support for the SQL bit string data type CREATE TABLE test (a BUT(3), b BIT VARYING(5)) INSERT INTO TEST VALUES (B'101', B'00'); - in PG-CONNECT, use getaddrinfo_all() to try connecting to each possible address for a hostname - maybe use CancelRequest to back out of error with grace? - we should return the oid of the object on inserts - use CopyData #\d methods - handle CopyInResponse and CopyOutResponse in pg-exec - use Describe cl-pg-20061216.orig/parsers.lisp0000644000175000017500000002740210560035327016526 0ustar pvaneyndpvaneynd;;; parsers.lisp -- type coercion support ;;; ;;; Author: Eric Marsden ;; ;; ;; When returning data from a SELECT statement, PostgreSQL starts by ;; sending some metadata describing the attributes. This information ;; is read by `PG:READ-ATTRIBUTES', and consists of each attribute's ;; name (as a string), its size (in bytes), and its type (as an oid ;; which points to a row in the PostgreSQL system table pg_type). Each ;; row in pg_type includes the type's name (as a string). ;; ;; We are able to parse a certain number of the PostgreSQL types (for ;; example, numeric data is converted to a numeric Common Lisp type, ;; dates are converted to the CL date representation, booleans to ;; lisp booleans). However, there isn't a fixed mapping from a ;; type to its OID which is guaranteed to be stable across database ;; installations, so we need to build a table mapping OIDs to parser ;; functions. ;; ;; This is done by the procedure `PG:INITIALIZE-PARSERS', which is run ;; the first time a connection is initiated with the database from ;; this invocation of CL, and which issues a SELECT statement to ;; extract the required information from pg_type. This initialization ;; imposes a slight overhead on the first request, which you can avoid ;; by setting `*PG-DISABLE-TYPE-COERCION*' to non-nil if it bothers you. ;; ==================================================================== ;;; TODO ============================================================ ;; ;; * add a mechanism for parsing user-defined types. The user should ;; be able to define a parse function and a type-name; we query ;; pg_type to get the type's OID and add the information to ;; pg:*parsers*. ;; (declaim (optimize (speed 3) (safety 1))) (in-package :postgresql) (defvar *pg-disable-type-coercion* nil "Non-nil disables the type coercion mechanism. The default is nil, which means that data recovered from the database is coerced to the corresponding Common Lisp type before being returned; for example numeric data is transformed to CL numbers, and booleans to booleans. The coercion mechanism requires an initialization query to the database, in order to build a table mapping type names to OIDs. This option is provided mainly in case you wish to avoid the overhead of this initial query. The overhead is only incurred once per session (not per connection to the backend).") ;; alist of (oid . parser) pairs. This is built dynamically at ;; initialization of the connection with the database (once generated, ;; the information is shared between connections). (defvar *parsers* '()) (defvar *type-to-oid* (make-hash-table :test #'eq) "Is a hashtable for turning a typename into a OID. Needed to define the type of objects in pg-prepare") (defvar *type-parsers* `(("bool" . ,'bool-parser) ("bytea" . ,'identity) ("char" . ,'text-parser) ("char2" . ,'text-parser) ("char4" . ,'text-parser) ("char8" . ,'text-parser) ("char16" . ,'text-parser) ("text" . ,'text-parser) ("varchar" . ,'text-parser) ("numeric" . ,'numeric-parser) ("int2" . ,'integer-parser) ("int4" . ,'integer-parser) ("int8" . ,'integer-parser) ;; int2vector ("oid" . ,'integer-parser) ;; oidvector ;; bit ;; varbit ;; record ;; cstring ;; any ("row" . ,'row-parser) ("float4" . ,'float-parser) ("float8" . ,'float-parser) ("money" . ,'text-parser) ; "$12.34" ("abstime" . ,'timestamp-parser) ("date" . ,'date-parser) ("timestamp" . ,'timestamp-parser) ; or 'precise-timestamp-parser if you want milliseconds ("timestamptz" . ,'timestamp-parser) ("datetime" . ,'timestamp-parser) ("time" . ,'text-parser) ; preparsed "15:32:45" ("timetz" . ,'text-parser) ("reltime" . ,'text-parser) ; don't know how to parse these ("timespan" . ,'interval-parser) ("interval" . ,'interval-parser) ("tinterval" . ,'interval-parser))) ;; see `man pgbuiltin' for details on PostgreSQL builtin types (defun integer-parser (str) (parse-integer str)) ;; from Risto Sakari Laakso ;; ;; http://www.postgresql.org/docs/7.4/static/datatype.html#DATATYPE-NUMERIC-DECIMAL ;; ;; NUMERIC(precision, scale) ;; ;; The scale of a numeric is the count of decimal digits in the ;; fractional part, to the right of the decimal point. The precision of a ;; numeric is the total count of significant digits in the whole number, that ;; is, the number of digits to both sides of the decimal point. (defun numeric-parser (str) (let ((dot-pos (position #\. str)) integer-part (decimal-part 0)) ;; parse up to #\., or whole string if #\. not present (setq integer-part (parse-integer (subseq str 0 dot-pos))) ;; if #\. present .. (when dot-pos (let* ((decimal-str (subseq str (1+ dot-pos))) (dec-str-len (length decimal-str))) ;; if has at least one digit after #\. (when (> dec-str-len 0) ;; parse integer after #\. and divide by 10^(digits), i.e. ".023" => 23/1000 (setq decimal-part (/ (parse-integer decimal-str) (expt 10 dec-str-len)))))) (if (eq #\- (elt str 0)) (- integer-part decimal-part) (+ integer-part decimal-part)))) ;; FIXME switch to a specialized float parser that conses less (defun float-parser (str) (declare (type simple-string str)) (let ((*read-eval* nil)) (read-from-string str))) ;; here we are assuming that the value of *PG-CLIENT-ENCODING* is ;; compatible with the encoding that the CL implementation uses for ;; strings. The backend should convert all values belonging to one of ;; the text data types from the table's internal representation to ;; that requested by the client, so here we don't need to do any ;; conversion. (defun text-parser (str) str) (defun bool-parser (str) (declare (type simple-string str)) (cond ((string= "t" str) t) ((string= "f" str) nil) (t (error 'protocol-error :reason "Badly formed boolean from backend: ~s" str)))) (defun parse-timestamp (str) (declare (type simple-string str)) (let* ((year (parse-integer str :start 0 :end 4)) (month (parse-integer str :start 5 :end 7)) (day (parse-integer str :start 8 :end 10)) (hours (parse-integer str :start 11 :end 13)) (minutes (parse-integer str :start 14 :end 16)) (seconds (parse-integer str :start 17 :end 19)) (length (length str)) (start-tz (if (find (char str (- length 3)) "+-") (- length 3))) (tz (when start-tz (parse-integer str :start start-tz))) (milliseconds (if (and (< 19 length) (eql (char str 19) #\.)) (parse-integer str :start 20 :end start-tz) 0))) (values year month day hours minutes seconds milliseconds tz))) ;; format for abstime/timestamp etc with ISO output syntax is ;; ;; "1999-01-02 05:11:23.0345645+01" ;; ;; which we convert to a CL universal time. Thanks to James Anderson ;; for a fix for timestamp format in PostgreSQL 7.3 (with or without ;; tz, with or without milliseconds). (defun timestamp-parser (str) ;; Test for the special values 'infinity' and '-infinity' (cond ((digit-char-p (schar str 0)) (multiple-value-bind (year month day hours minutes seconds) (parse-timestamp str) (encode-universal-time seconds minutes hours day month year))) ((equal str "infinity") :infinity) ((equal str "-infinity") :-infinity) (t (error "Unknown special timestamp value ~A" str)))) (defun precise-timestamp-parser (str) (multiple-value-bind (year month day hours minutes seconds milliseconds) (parse-timestamp str) (+ (encode-universal-time seconds minutes hours day month year) (/ milliseconds 1000.0)))) ;; An interval is what you get when you subtract two timestamps. We ;; convert to a number of seconds. (defun interval-parser (str) (let* ((hours (parse-integer str :start 0 :end 2)) (minutes (parse-integer str :start 3 :end 5)) (seconds (parse-integer str :start 6 :end 8)) (milliseconds (parse-integer str :start 9))) (+ (/ milliseconds (expt 10.0 (- (length str) 9))) seconds (* 60 minutes) (* 60 60 hours)))) ;; format for abstime/timestamp etc with ISO output syntax is ;;; "1999-01-02 00:00:00+01" ;; which we convert to a CL universal time (defun isodate-parser (str) (let ((year (parse-integer str :start 0 :end 4)) (month (parse-integer str :start 5 :end 7)) (day (parse-integer str :start 8 :end 10)) (hours (parse-integer str :start 11 :end 13)) (minutes (parse-integer str :start 14 :end 16)) (seconds (parse-integer str :start 17 :end 19)) (tz (parse-integer str :start 19 :end 22))) (encode-universal-time seconds minutes hours day month year tz))) ;; format for date with ISO output syntax is ;;; "1999-01-02" ;; which we convert to a CL universal time (defun date-parser (str) (let ((year (parse-integer str :start 0 :end 4)) (month (parse-integer str :start 5 :end 7)) (day (parse-integer str :start 8 :end 10))) (encode-universal-time 0 0 0 day month year))) ;; http://www.postgresql.org/docs/8.1/interactive/sql-expressions.html#SQL-SYNTAX-ROW-CONSTRUCTORS ;; ;; these are in the format "(foo,bar,baz)" (defun row-parser (str) (assert (char= #\( (char str 0))) (loop :with start = 1 :with last = (- (length str) 1) :for end = (or (position #\, str :start start) last) :collect (subseq str start end) :do (setq start (1+ end)) :until (>= end last))) (defun initialize-parsers (connection) (let* ((pgtypes (pg-exec connection "SELECT typname,oid FROM pg_type")) (tuples (pg-result pgtypes :tuples))) (setq *parsers* '()) (map nil (lambda (tuple) (let* ((typname (first tuple)) (oid (parse-integer (second tuple))) (type (assoc typname *type-parsers* :test #'string=))) (cond ((consp type) (setf (gethash (intern typname :keyword) *type-to-oid*) oid) (push (cons oid (cdr type)) *parsers*)) (t #+debug (warn "Unknown PostgreSQL type found: '~A' oid: '~A'" typname oid))))) tuples))) ;; FIXME should perhaps resignal parse errors as a condition derived ;; from POSTGRESQL-ERROR (defun parse (str oid) (declare (type simple-string str)) (let ((parser (assoc oid *parsers* :test #'eql))) (if (consp parser) (funcall (cdr parser) str) str))) (defun lookup-type (type) "Given the name of a type, returns the oid of the type or NIL if not found" (let ((type (etypecase type (symbol type) (string (intern type :keyword))))) (gethash type *type-to-oid*))) ;; PQescapeBytea - converts from binary string to the ;; minimal encoding necessary to include the string in an SQL ;; INSERT statement with a bytea type column as the target. ;; ;; The following transformations are applied ;; '\0' == ASCII 0 == \000 ;; '\'' == ASCII 39 == '' ;; '\\' == ASCII 92 == \\ ;; anything < 0x20, or > 0x7e ---> \ooo ;; (where ooo is an octal expression) ;; If not std_strings, all backslashes sent to the output are doubled. ;; ;; http://www.postgresql.org/docs/8.1/static/datatype-binary.html (defun bytea->string (data) (declare (type (vector (unsigned-byte 8) *) data)) (with-output-to-string (out) (loop :for octet :across data :do (cond ((<= 32 octet 126) (write-char (code-char octet) out)) (t (format out "\\~3,'0O" octet)))))) ;; EOF cl-pg-20061216.orig/md5.lisp0000644000175000017500000006150610560035327015537 0ustar pvaneyndpvaneynd;;;; This file implements The MD5 Message-Digest Algorithm, as defined in ;;;; RFC 1321 by R. Rivest, published April 1992. ;;;; ;;;; It was written by Pierre R. Mai, with copious input from the ;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and ;;;; has been placed into the public domain. ;;;; ;;;; This version distributed with pg-dot-lisp comes from the SBCL ;;;; SB-MD5 contrib, with minor changes to compile in other Common ;;;; Lisp implementations. ;;;; ;;;; $Id: md5.lisp,v 1.3 2006/01/27 17:51:53 emarsden Exp $ ;;;; ;;;; While the implementation should work on all conforming Common ;;;; Lisp implementations, it has only been optimized for CMU CL, ;;;; where it achieved comparable performance to the standard md5sum ;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc ;;;; hardware). ;;;; ;;;; Since the implementation makes heavy use of arithmetic on ;;;; (unsigned-byte 32) numbers, acceptable performance is likely only ;;;; on CL implementations that support unboxed arithmetic on such ;;;; numbers in some form. For other CL implementations a 16bit ;;;; implementation of MD5 is probably more suitable. ;;;; ;;;; The code implements correct operation for files of unbounded size ;;;; as is, at the cost of having to do a single generic integer ;;;; addition for each call to update-md5-state. If you call ;;;; update-md5-state frequently with little data, this can pose a ;;;; performance problem. If you can live with a size restriction of ;;;; 512 MB, then you can enable fast fixnum arithmetic by putting ;;;; :md5-small-length onto *features* prior to compiling this file. ;;;; ;;;; This software is "as is", and has no warranty of any kind. The ;;;; authors assume no responsibility for the consequences of any use ;;;; of this software. (defpackage :PG-MD5 (:use :CL) (:export ;; Low-Level types and functions #:md5-regs #:initial-md5-regs #:md5regs-digest #:update-md5-block #:fill-block #:fill-block-ub8 #:fill-block-char ;; Mid-Level types and functions #:md5-state #:md5-state-p #:make-md5-state #:update-md5-state #:finalize-md5-state ;; High-Level functions on sequences, streams and files #:md5sum-sequence #:md5sum-string #:md5sum-stream #:md5sum-file)) (in-package :PG-MD5) #+cmu (eval-when (:compile-toplevel) (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) #+cmu (eval-when (:compile-toplevel :execute) (defparameter *old-features* *features*) (pushnew (c:backend-byte-order c:*target-backend*) *features*)) #+sbcl (eval-when (:compile-toplevel) (defparameter *old-features* *features*) (pushnew sb-c:*backend-byte-order* *features*)) ;;; Section 2: Basic Datatypes (deftype ub32 () "Corresponds to the 32bit quantity word of the MD5 Spec" `(unsigned-byte 32)) (defmacro assemble-ub32 (a b c d) "Assemble an ub32 value from the given (unsigned-byte 8) values, where a is the intended low-order byte and d the high-order byte." `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a))) ;;; Section 3.4: Auxilliary functions (declaim (inline f g h i) (ftype (function (ub32 ub32 ub32) ub32) f g h i)) (defun f (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x y) (kernel:32bit-logical-andc1 x z)) #-cmu (logior (logand x y) (logandc1 x z))) (defun g (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x z) (kernel:32bit-logical-andc2 y z)) #-cmu (logior (logand x z) (logandc2 y z))) (defun h (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) #-cmu (logxor x y z)) (defun i (x y z) (declare (type ub32 x y z) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) #-cmu (ldb (byte 32 0) (logxor y (logorc2 x z)))) (declaim (inline mod32+) (ftype (function (ub32 ub32) ub32) mod32+)) (defun mod32+ (a b) (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (ldb (byte 32 0) (+ a b))) #+cmu (define-compiler-macro mod32+ (a b) `(ext:truly-the ub32 (+ ,a ,b))) ;;; Dunno why we need this, but without it MOD32+ wasn't being ;;; inlined. Oh well. -- CSR, 2003-09-14 #+sbcl (define-compiler-macro mod32+ (a b) `(ldb (byte 32 0) (+ ,a ,b))) (declaim (inline rol32) (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) (defun rol32 (a s) (declare (type ub32 a) (type (unsigned-byte 5) s) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) #+big-endian (kernel:shift-towards-start a s) (ash a (- s 32))) #+sbcl (sb-rotate-byte:rotate-byte s (byte 32 0) a) #-(or cmu sbcl) (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) ;;; Section 3.4: Table T (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *t* (make-array 64 :element-type 'ub32 :initial-contents (loop for i from 1 to 64 collect (truncate (* 4294967296 (abs (sin (float i 0.0d0))))))))) ;;; Section 3.4: Helper Macro for single round definitions (defmacro with-md5-round ((op block) &rest clauses) (loop for (a b c d k s i) in clauses collect `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) (mod32+ (aref ,block ,k) ,(aref *t* (1- i)))) ,s))) into result finally (return `(progn ,@result)))) ;;; Section 3.3: (Initial) MD5 Working Set (deftype md5-regs () "The working state of the MD5 algorithm, which contains the 4 32-bit registers A, B, C and D." `(simple-array (unsigned-byte 32) (4))) (defmacro md5-regs-a (regs) `(aref ,regs 0)) (defmacro md5-regs-b (regs) `(aref ,regs 1)) (defmacro md5-regs-c (regs) `(aref ,regs 2)) (defmacro md5-regs-d (regs) `(aref ,regs 3)) (defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67) "Initial value of Register A of the MD5 working state.") (defconstant +md5-magic-b+ (assemble-ub32 #x89 #xab #xcd #xef) "Initial value of Register B of the MD5 working state.") (defconstant +md5-magic-c+ (assemble-ub32 #xfe #xdc #xba #x98) "Initial value of Register C of the MD5 working state.") (defconstant +md5-magic-d+ (assemble-ub32 #x76 #x54 #x32 #x10) "Initial value of Register D of the MD5 working state.") (declaim (inline initial-md5-regs)) (defun initial-md5-regs () "Create the initial working state of an MD5 run." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) (declare (type md5-regs regs)) (setf (md5-regs-a regs) +md5-magic-a+ (md5-regs-b regs) +md5-magic-b+ (md5-regs-c regs) +md5-magic-c+ (md5-regs-d regs) +md5-magic-d+) regs)) ;;; Section 3.4: Operation on 16-Word Blocks (defun update-md5-block (regs block) "This is the core part of the MD5 algorithm. It takes a complete 16 word block of input, and updates the working state in A, B, C, and D accordingly." (declare (type md5-regs regs) (type (simple-array ub32 (16)) block) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (let ((a (md5-regs-a regs)) (b (md5-regs-b regs)) (c (md5-regs-c regs)) (d (md5-regs-d regs))) (declare (type ub32 a b c d)) ;; Round 1 (with-md5-round (f block) (A B C D 0 7 1)(D A B C 1 12 2)(C D A B 2 17 3)(B C D A 3 22 4) (A B C D 4 7 5)(D A B C 5 12 6)(C D A B 6 17 7)(B C D A 7 22 8) (A B C D 8 7 9)(D A B C 9 12 10)(C D A B 10 17 11)(B C D A 11 22 12) (A B C D 12 7 13)(D A B C 13 12 14)(C D A B 14 17 15)(B C D A 15 22 16)) ;; Round 2 (with-md5-round (g block) (A B C D 1 5 17)(D A B C 6 9 18)(C D A B 11 14 19)(B C D A 0 20 20) (A B C D 5 5 21)(D A B C 10 9 22)(C D A B 15 14 23)(B C D A 4 20 24) (A B C D 9 5 25)(D A B C 14 9 26)(C D A B 3 14 27)(B C D A 8 20 28) (A B C D 13 5 29)(D A B C 2 9 30)(C D A B 7 14 31)(B C D A 12 20 32)) ;; Round 3 (with-md5-round (h block) (A B C D 5 4 33)(D A B C 8 11 34)(C D A B 11 16 35)(B C D A 14 23 36) (A B C D 1 4 37)(D A B C 4 11 38)(C D A B 7 16 39)(B C D A 10 23 40) (A B C D 13 4 41)(D A B C 0 11 42)(C D A B 3 16 43)(B C D A 6 23 44) (A B C D 9 4 45)(D A B C 12 11 46)(C D A B 15 16 47)(B C D A 2 23 48)) ;; Round 4 (with-md5-round (i block) (A B C D 0 6 49)(D A B C 7 10 50)(C D A B 14 15 51)(B C D A 5 21 52) (A B C D 12 6 53)(D A B C 3 10 54)(C D A B 10 15 55)(B C D A 1 21 56) (A B C D 8 6 57)(D A B C 15 10 58)(C D A B 6 15 59)(B C D A 13 21 60) (A B C D 4 6 61)(D A B C 11 10 62)(C D A B 2 15 63)(B C D A 9 21 64)) ;; Update and return (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) a) (md5-regs-b regs) (mod32+ (md5-regs-b regs) b) (md5-regs-c regs) (mod32+ (md5-regs-c regs) c) (md5-regs-d regs) (mod32+ (md5-regs-d regs) d)) regs)) ;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks (declaim (inline fill-block fill-block-ub8 fill-block-char)) (defun fill-block (block buffer offset) "Convert a complete 64 byte input vector segment into the given 16 word MD5 block. This currently works on (unsigned-byte 8) and character simple-arrays, via the functions `fill-block-ub8' and `fill-block-char' respectively." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (type (simple-array ub32 (16)) block) (type (simple-array * (*)) buffer) (optimize (speed 3) (safety 0) (space 0) (debug 0))) (etypecase buffer ((simple-array (unsigned-byte 8) (*)) (fill-block-ub8 block buffer offset)) (simple-string (fill-block-char block buffer offset)))) (defun fill-block-ub8 (block buffer offset) "Convert a complete 64 (unsigned-byte 8) input vector segment starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (type (simple-array ub32 (16)) block) (type (simple-array (unsigned-byte 8) (*)) buffer) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+(and :cmu :little-endian) (kernel:bit-bash-copy buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) block (* vm:vector-data-offset vm:word-bits) (* 64 vm:byte-bits)) #+(and :sbcl :little-endian) (sb-kernel:ub8-bash-copy buffer offset block 0 64) #-(or (and :sbcl :little-endian) (and :cmu :little-endian)) (loop for i of-type (integer 0 16) from 0 for j of-type (integer 0 #.most-positive-fixnum) from offset to (+ offset 63) by 4 do (setf (aref block i) (assemble-ub32 (aref buffer j) (aref buffer (+ j 1)) (aref buffer (+ j 2)) (aref buffer (+ j 3)))))) (defun fill-block-char (block buffer offset) "Convert a complete 64 character input string segment starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) (type (simple-array ub32 (16)) block) (type simple-string buffer) (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+(and :cmu :little-endian) (kernel:bit-bash-copy buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) block (* vm:vector-data-offset vm:word-bits) (* 64 vm:byte-bits)) #+(and :sbcl :little-endian) (sb-kernel:ub8-bash-copy buffer offset block 0 64) #-(or (and :sbcl :little-endian) (and :cmu :little-endian)) (loop for i of-type (integer 0 16) from 0 for j of-type (integer 0 #.most-positive-fixnum) from offset to (+ offset 63) by 4 do (setf (aref block i) (assemble-ub32 (char-code (schar buffer j)) (char-code (schar buffer (+ j 1))) (char-code (schar buffer (+ j 2))) (char-code (schar buffer (+ j 3))))))) ;;; Section 3.5: Message Digest Output (declaim (inline md5regs-digest)) (defun md5regs-digest (regs) "Create the final 16 byte message-digest from the MD5 working state in regs. Returns a (simple-array (unsigned-byte 8) (16))." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) (type md5-regs regs)) (let ((result (make-array 16 :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (16)) result)) (macrolet ((frob (reg offset) (let ((var (gensym))) `(let ((,var ,reg)) (declare (type ub32 ,var)) (setf (aref result ,offset) (ldb (byte 8 0) ,var) (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var) (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var)))))) (frob (md5-regs-a regs) 0) (frob (md5-regs-b regs) 4) (frob (md5-regs-c regs) 8) (frob (md5-regs-d regs) 12)) result)) ;;; Mid-Level Drivers (defstruct (md5-state (:constructor make-md5-state ()) (:copier)) (regs (initial-md5-regs) :type md5-regs :read-only t) (amount 0 :type #-md5-small-length (integer 0 *) #+md5-small-length (unsigned-byte 29)) (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t :type (simple-array (unsigned-byte 32) (16))) (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t :type (simple-array (unsigned-byte 8) (64))) (buffer-index 0 :type (integer 0 63)) (finalized-p nil)) (declaim (inline copy-to-buffer)) (defun copy-to-buffer (from from-offset count buffer buffer-offset) "Copy a partial segment from input vector from starting at from-offset and copying count elements into the 64 byte buffer starting at buffer-offset." (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) (type (unsigned-byte 29) from-offset) (type (integer 0 63) count buffer-offset) (type (simple-array * (*)) from) (type (simple-array (unsigned-byte 8) (64)) buffer)) #+cmu (kernel:bit-bash-copy from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) buffer (+ (* vm:vector-data-offset vm:word-bits) (* buffer-offset vm:byte-bits)) (* count vm:byte-bits)) #+sbcl (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count) #-(or cmu sbcl) (etypecase from (simple-string (loop for buffer-index of-type (integer 0 64) from buffer-offset for from-index of-type fixnum from from-offset below (+ from-offset count) do (setf (aref buffer buffer-index) (char-code (schar (the simple-string from) from-index))))) ((simple-array (unsigned-byte 8) (*)) (loop for buffer-index of-type (integer 0 64) from buffer-offset for from-index of-type fixnum from from-offset below (+ from-offset count) do (setf (aref buffer buffer-index) (aref (the (simple-array (unsigned-byte 8) (*)) from) from-index)))))) (defun update-md5-state (state sequence &key (start 0) (end (length sequence))) "Update the given md5-state from sequence, which is either a simple-string or a simple-array with element-type (unsigned-byte 8), bounded by start and end, which must be numeric bounding-indices." (declare (type md5-state state) (type (simple-array * (*)) sequence) (type fixnum start end) (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0)) #+cmu (ext:optimize-interface (safety 1) (debug 1))) (let ((regs (md5-state-regs state)) (block (md5-state-block state)) (buffer (md5-state-buffer state)) (buffer-index (md5-state-buffer-index state)) (length (- end start))) (declare (type md5-regs regs) (type fixnum length) (type (integer 0 63) buffer-index) (type (simple-array (unsigned-byte 32) (16)) block) (type (simple-array (unsigned-byte 8) (64)) buffer)) ;; Handle old rest (unless (zerop buffer-index) (let ((amount (min (- 64 buffer-index) length))) (declare (type (integer 0 63) amount)) (copy-to-buffer sequence start amount buffer buffer-index) (setq start (the fixnum (+ start amount))) (when (>= start end) (setf (md5-state-buffer-index state) (+ buffer-index amount)) (return-from update-md5-state state))) (fill-block-ub8 block buffer 0) (update-md5-block regs block)) ;; Handle main-part and new-rest (etypecase sequence ((simple-array (unsigned-byte 8) (*)) (locally (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) (loop for offset of-type (unsigned-byte 29) from start below end by 64 until (< (- end offset) 64) do (fill-block-ub8 block sequence offset) (update-md5-block regs block) finally (let ((amount (- end offset))) (unless (zerop amount) (copy-to-buffer sequence offset amount buffer 0)) (setf (md5-state-buffer-index state) amount))))) (simple-string (locally (declare (type simple-string sequence)) (loop for offset of-type (unsigned-byte 29) from start below end by 64 until (< (- end offset) 64) do (fill-block-char block sequence offset) (update-md5-block regs block) finally (let ((amount (- end offset))) (unless (zerop amount) (copy-to-buffer sequence offset amount buffer 0)) (setf (md5-state-buffer-index state) amount)))))) (setf (md5-state-amount state) #-md5-small-length (+ (md5-state-amount state) length) #+md5-small-length (the (unsigned-byte 29) (+ (md5-state-amount state) length))) state)) (defun finalize-md5-state (state) "If the given md5-state has not already been finalized, finalize it, by processing any remaining input in its buffer, with suitable padding and appended bit-length, as specified by the MD5 standard. The resulting MD5 message-digest is returned as an array of sixteen (unsigned-byte 8) values. Calling `update-md5-state' after a call to `finalize-md5-state' results in unspecified behaviour." (declare (type md5-state state) (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0)) #+cmu (ext:optimize-interface (safety 1) (debug 1))) (or (md5-state-finalized-p state) (let ((regs (md5-state-regs state)) (block (md5-state-block state)) (buffer (md5-state-buffer state)) (buffer-index (md5-state-buffer-index state)) (total-length (* 8 (md5-state-amount state)))) (declare (type md5-regs regs) (type (integer 0 63) buffer-index) (type (simple-array ub32 (16)) block) (type (simple-array (unsigned-byte 8) (*)) buffer)) ;; Add mandatory bit 1 padding (setf (aref buffer buffer-index) #x80) ;; Fill with 0 bit padding (loop for index of-type (integer 0 64) from (1+ buffer-index) below 64 do (setf (aref buffer index) #x00)) (fill-block-ub8 block buffer 0) ;; Flush block first if length wouldn't fit (when (>= buffer-index 56) (update-md5-block regs block) ;; Create new fully 0 padded block (loop for index of-type (integer 0 16) from 0 below 16 do (setf (aref block index) #x00000000))) ;; Add 64bit message bit length (setf (aref block 14) (ldb (byte 32 0) total-length)) #-md5-small-length (setf (aref block 15) (ldb (byte 32 32) total-length)) ;; Flush last block (update-md5-block regs block) ;; Done, remember digest for later calls (setf (md5-state-finalized-p state) (md5regs-digest regs))))) ;;; High-Level Drivers (defun md5sum-sequence (sequence &key (start 0) end) "Calculate the MD5 message-digest of data bounded by START and END in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE 8)." (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) (type (vector (unsigned-byte 8)) sequence) (type fixnum start)) (locally (declare (optimize (safety 1) (debug 0))) (let ((state (make-md5-state))) (declare (type md5-state state)) #+cmu (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) (update-md5-state state data :start real-start :end real-end)) #+sbcl (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) (update-md5-state state data :start real-start :end real-end)) #-(or cmu sbcl) (let ((real-end (or end (length sequence)))) (declare (type fixnum real-end)) (update-md5-state state sequence :start start :end real-end)) (finalize-md5-state state)))) #+nil (defun md5sum-string (string &key (external-format :default) (start 0) end) "Calculate the MD5 message-digest of the binary representation of STRING (as octets) in EXTERNAL-FORMAT. The boundaries START and END refer to character positions in the string, not to octets in the resulting binary representation." (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) (type string string) (type fixnum start)) (locally (declare (optimize (safety 1) (debug 0))) (md5sum-sequence (sb-ext:string-to-octets string :external-format external-format :start start :end end)))) (eval-when (:compile-toplevel :load-toplevel) (defconstant +buffer-size+ (* 128 1024) "Size of internal buffer to use for md5sum-stream and md5sum-file operations. This should be a multiple of 64, the MD5 block size.")) (deftype buffer-index () `(integer 0 ,+buffer-size+)) (defun md5sum-stream (stream) "Calculate an MD5 message-digest of the contents of STREAM, whose element-type has to be (UNSIGNED-BYTE 8)." (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))) (declare (type stream stream)) (locally (declare (optimize (safety 1) (debug 0))) (let ((state (make-md5-state))) (declare (type md5-state state)) (cond ((equal (stream-element-type stream) '(unsigned-byte 8)) (let ((buffer (make-array +buffer-size+ :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer)) (loop for bytes of-type buffer-index = (read-sequence buffer stream) do (update-md5-state state buffer :end bytes) until (< bytes +buffer-size+) finally (return (finalize-md5-state state))))) #+(or) ((equal (stream-element-type stream) 'character) (let ((buffer (make-string +buffer-size+))) (declare (type (simple-string #.+buffer-size+) buffer)) (loop for bytes of-type buffer-index = (read-sequence buffer stream) do (update-md5-state state buffer :end bytes) until (< bytes +buffer-size+) finally (return (finalize-md5-state state))))) (t (error "Unsupported stream element-type ~S for stream ~S." (stream-element-type stream) stream)))))) (defun md5sum-file (pathname) "Calculate the MD5 message-digest of the file designated by pathname." (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))) (locally (declare (optimize (safety 1) (debug 0))) (with-open-file (stream pathname :element-type '(unsigned-byte 8)) (md5sum-stream stream)))) #+cmu (eval-when (:compile-toplevel :execute) (setq *features* *old-features*)) #+cmu (eval-when (:compile-toplevel) (setq ext:*inline-expansion-limit* *old-expansion-limit*)) #+sbcl (eval-when (:compile-toplevel) (setq *features* *old-features*)) cl-pg-20061216.orig/cmucl-install-subsystem.lisp0000644000175000017500000000203010560035327021640 0ustar pvaneyndpvaneynd;;; cmucl-install-subsystem.lisp ;; ;; ;; Loading this into CMUCL will install pg.lisp as a CMUCL subsystem, ;; that can be loaded with ;; ;; (require :pg) ;; ;; Note that the user running CMUCL needs to have write access to the ;; subsystems directory (so you may need to run this as root). (let ((fasl-1 (compile-file "defpackage" :load t)) (fasl-2 (compile-file "sysdep" :load t)) (fasl-3 (compile-file "pg"))) (with-open-file (out (compile-file-pathname "library:subsystems/pg-library") :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (dolist (f (list fasl-1 fasl-2 fasl-3)) (with-open-file (in f :direction :input :element-type '(unsigned-byte 8)) (loop :with buffer = (make-array 1024 :element-type '(unsigned-byte 8)) :for n = (read-sequence buffer in) :until (= n 0) :do (write-sequence buffer out :end n)))))) ;; EOF cl-pg-20061216.orig/large-object.lisp0000644000175000017500000001133310560035327017401 0ustar pvaneyndpvaneynd;;; large-object.lisp -- support for BLOBs ;;; ;;; Author: Eric Marsden ;; ;; ;; Sir Humphrey: Who is Large and to what does he object? ;; ;; Large objects are the PostgreSQL way of doing what most databases ;; call BLOBs (binary large objects). In addition to being able to ;; stream data to and from large objects, PostgreSQL's ;; object-relational capabilities allow the user to provide functions ;; which act on the objects. ;; ;; For example, the user can define a new type called "circle", and ;; define a C or Tcl function called `circumference' which will act on ;; circles. There is also an inheritance mechanism in PostgreSQL. ;; ;; The PostgreSQL large object interface is similar to the Unix file ;; system, with open, read, write, lseek etc. ;; ;; Implementation note: the network protocol for large objects changed ;; around version 6.5 to use network order for integers. ;; ===================================================================== (in-package :postgresql) (defconstant +INV_ARCHIVE+ #x10000) ; fe-lobj.c (defconstant +INV_WRITE+ #x20000) (defconstant +INV_READ+ #x40000) (defconstant +LO_BUFSIZ+ 1024) (defvar *lo-initialized* nil) (defvar *lo-functions* '()) (defun lo-init (connection) (let ((res (pg-exec connection "SELECT proname, oid from pg_proc WHERE " "proname = 'lo_open' OR " "proname = 'lo_close' OR " "proname = 'lo_creat' OR " "proname = 'lo_unlink' OR " "proname = 'lo_lseek' OR " "proname = 'lo_tell' OR " "proname = 'loread' OR " "proname = 'lowrite'"))) (setq *lo-functions* '()) (dolist (tuple (pg-result res :tuples)) (push (cons (car tuple) (cadr tuple)) *lo-functions*)) (unless (= 8 (length *lo-functions*)) (error "Couldn't find OIDs for all the large object functions")) (setq *lo-initialized* t))) ;; returns an OID (defun pglo-create (connection &optional (modestr "r")) (let* ((mode (cond ((integerp modestr) modestr) ((string= "r" modestr) +INV_READ+) ((string= "w" modestr) +INV_WRITE+) ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+)) (t (error "Bad mode ~s" modestr)))) (oid (fn connection "lo_creat" t mode))) (unless (integerp oid) (error 'backend-error :reason "Didn't return an OID")) (when (zerop oid) (error 'backend-error :reason "Can't create large object")) oid)) ;; args = modestring (default "r", or "w" or "rw") ;; returns a file descriptor for use in later lo-* procedures (defun pglo-open (connection oid &optional (modestr "r")) (let* ((mode (cond ((integerp modestr) modestr) ((string= "r" modestr) +INV_READ+) ((string= "w" modestr) +INV_WRITE+) ((string= "rw" modestr) (logior +INV_READ+ +INV_WRITE+)) (t (error 'program-error (format nil "Bad mode ~s" modestr))))) (fd (fn connection "lo_open" t oid mode))) (assert (integerp fd)) fd)) (defun pglo-close (connection fd) (fn connection "lo_close" t fd)) ;; pglo-read has moved to v2-protocol.lisp and v3-protocol.lisp ;; ;; the difference between the v3 and v2 protocols is that in the former case ;; data is read in binary format, whereas in the latter data is read as text. (defun pglo-write (connection fd buf) (fn connection "lowrite" t fd buf)) (defun pglo-lseek (connection fd offset whence) (fn connection "lo_lseek" t fd offset whence)) (defun pglo-tell (connection fd) (fn connection "lo_tell" t fd)) (defun pglo-unlink (connection oid) (fn connection "lo_unlink" t oid)) (defun pglo-import (connection filename) (let ((buf (make-array +LO_BUFSIZ+ :element-type '(unsigned-byte 8))) (oid (pglo-create connection "rw"))) (with-open-file (in filename :direction :input :element-type '(unsigned-byte 8)) (loop :with fdout = (pglo-open connection oid "w") :for bytes = (read-sequence buf in) :until (< bytes +LO_BUFSIZ+) :do (pglo-write connection fdout buf) :finally (pglo-write connection fdout (subseq buf 0 bytes)) (pglo-close connection fdout))) oid)) (defun pglo-export (connection oid filename) (with-open-file (out filename :direction :output :element-type '(unsigned-byte 8)) (loop :with fdin = (pglo-open connection oid "r") :for str = (pglo-read connection fdin +LO_BUFSIZ+) :until (zerop (length str)) :do (write-sequence str out) :finally (pglo-close connection fdin)))) ;; EOF cl-pg-20061216.orig/lowlevel.lisp0000644000175000017500000001212410560035327016673 0ustar pvaneyndpvaneynd;;; lowlevel.lisp -- lowlevel network ;;; ;;; Author: Eric Marsden ;;; Time-stamp: <2005-07-17 emarsden> (in-package :postgresql) ;; read an integer in network byte order (defun %read-net-int8 (stream) "Reads an integer BYTES bytes long from the STREAM. The signed integer is presumed to be in network order. Returns the integer." (let ((result (read-byte stream))) (when (= 1 (ldb (byte 1 7) result)) ;; negative (setf result (- (1+ (logxor result #xFF))))) result)) (defun %read-net-int16 (stream) "Reads an integer BYTES bytes long from the STREAM. The signed integer is presumed to be in network order. Returns the integer." (let ((result (+ (* 256 (read-byte stream)) (read-byte stream)))) (when (= 1 (ldb (byte 1 15) result)) ;; negative (setf result (- (1+ (logxor result #xFFFF))))) result)) (defun %read-net-int32 (stream) "Reads an integer BYTES bytes long from the STREAM. The signed integer is presumed to be in network order. Returns the integer." (let ((result (+ (* 256 256 256 (read-byte stream)) (* 256 256 (read-byte stream)) (* 256 (read-byte stream)) (read-byte stream)))) (when (= 1 (ldb (byte 1 31) result)) ;; negative (setf result (- (1+ (logxor result #xFFFFFFFF))))) result)) #-cmu (defun %read-bytes (stream howmany) "Reads HOWMANY bytes from the STREAM. Returns the array of " (declare (type stream stream)) (let ((v (make-array howmany :element-type '(unsigned-byte 8)))) (read-sequence v stream) v)) ;; There is a bug in CMUCL's implementation of READ-SEQUENCE on ;; network streams, which can return without reading to the end of the ;; sequence when it has to wait for data. It confuses the end-of-file ;; condition with no-more-data-currently-available. This workaround is ;; thanks to Wayne Iba. #+cmu (defun %read-bytes (stream howmany) "Reads HOWMANY bytes from the STREAM. Returns the array of " (declare (type stream stream)) (let ((v (make-array howmany :element-type '(unsigned-byte 8)))) (do ((continue-at (read-sequence v stream :start 0 :end howmany) (read-sequence v stream :start continue-at :end howmany))) ((= continue-at howmany)) ) v)) (defun %read-chars (stream howmany) (declare (type fixnum howmany)) (let ((bytes (%read-bytes stream howmany)) (str (make-string howmany))) (dotimes (i howmany) (setf (aref str i) (code-char (aref bytes i)))) str)) (defun %read-cstring (stream maxbytes) "Read a null-terminated string from CONNECTION." (declare (type fixnum maxbytes)) (let ((chars nil)) (do ((b (read-byte stream nil nil) (read-byte stream nil nil)) (i 0 (+ i 1))) ((or (= i maxbytes) ; reached allowed length (null b) ; eof (zerop b)) ; end of string (concatenate 'string (nreverse chars))) (push (code-char b) chars)))) ;; read an integer in network byte order (defun read-net-int (connection bytes) (do ((i bytes (- i 1)) (stream (pgcon-stream connection)) (accum 0)) ((zerop i) accum) (setq accum (+ (* 256 accum) (read-byte stream))))) (defun send-string (connection str &optional pad-to) (let* ((stream (pgcon-stream connection)) (len (length str)) (v (make-array len :element-type '(unsigned-byte 8)))) ;; convert the string to a vector of bytes (dotimes (i len) (setf (aref v i) (char-code (aref str i)))) (write-sequence v stream) ;; pad if necessary (when pad-to (write-sequence (make-array (- pad-to len) :initial-element 0 :element-type '(unsigned-byte 8)) stream)))) (defun send-octets (connection buffer) (declare (type (vector (unsigned-byte 8) *) buffer)) (write-sequence buffer (pgcon-stream connection))) ;; highest order bits first (defun send-int (connection int bytes) (declare (type fixnum int bytes)) (let ((v (make-array bytes :element-type '(unsigned-byte 8))) (stream (pgcon-stream connection))) (do ((i (- bytes 1) (- i 1))) ((< i 0)) (setf (aref v i) (rem int 256)) (setq int (floor int 256))) (write-sequence v stream))) (defun %send-net-int (stream int bytes) (declare (type stream stream) (type fixnum int bytes)) (let ((v (make-array bytes :element-type '(unsigned-byte 8)))) (loop for offset from (* 8 (1- bytes)) downto 0 by 8 for data = (ldb (byte 8 offset) int) for i from 0 do (setf (aref v i) data)) #+debug (format t "~&writing: ~S~%" v) (write-sequence v stream))) (defun %send-cstring (stream str) "Sends a null-terminated string to CONNECTION" (let* ((len (length str)) (v (make-array len :element-type '(unsigned-byte 8)))) ;; convert the string to a vector of bytes (dotimes (i len) (setf (aref v i) (char-code (aref str i)))) (write-sequence v stream) (write-byte 0 stream))) (declaim (inline %flush)) (defun %flush (connection) (force-output (pgcon-stream connection))) ;; EOF cl-pg-20061216.orig/meta-queries.lisp0000644000175000017500000000357410560035327017454 0ustar pvaneyndpvaneynd;;; meta-queries.lisp -- DBMS metainformation ;;; ;;; Author: Eric Marsden ;;; Time-stamp: <2005-12-19 emarsden> ;; ;; ;; Metainformation such as the list of databases present in the ;; database management system, list of tables, attributes per table. ;; This information is not available directly, but can be deduced by ;; querying the system tables. ;; ;; Based on the queries issued by psql in response to user commands ;; `\d' and `\d tablename'; see file pgsql/src/bin/psql/psql.c (in-package :postgresql) (defun pg-databases (conn) "Return a list of the databases available at this site." (let ((res (pg-exec conn "SELECT datname FROM pg_database"))) (reduce #'append (pg-result res :tuples)))) (defun pg-tables (conn) "Return a list of the tables present in this database." (let ((res (pg-exec conn "SELECT relname FROM pg_class, pg_user WHERE " "(relkind = 'r') AND relname !~ '^pg_' AND usesysid = relowner ORDER BY relname"))) (reduce #'append (pg-result res :tuples)))) (defun pg-columns (conn table) "Return a list of the columns present in TABLE." (let ((res (pg-exec conn (format nil "SELECT * FROM ~s WHERE 0 = 1" table)))) (mapcar #'first (pg-result res :attributes)))) (defun pg-backend-version (conn) "Return a string identifying the version and operating environment of the backend." (let ((res (pg-exec conn "SELECT version()"))) (first (pg-result res :tuple 0)))) (defun pg-describe-table (conn table) (flet ((oid-to-name (oid) (maphash (lambda (key value) (when (eql value oid) (return-from oid-to-name key))) *type-to-oid*))) (let ((res (pg-exec conn (format nil "SELECT * FROM ~S WHERE 0=1" table)))) (loop :for (name oid) :in (pg-result res :attributes) :collect (list name (oid-to-name oid)))))) ;; EOF cl-pg-20061216.orig/pg-tests.lisp0000644000175000017500000007777110560035327016633 0ustar pvaneyndpvaneynd;;; pg-tests.lisp -- incomplete test suite ;;; ;;; Author: Eric Marsden ;; ;; ;; These tests assume that a table named "test" is defined in the ;; system catalog, and that the user identified in ;; CALL-WITH-TEST-CONNECTION has the rights to access that table. (defpackage :pg-tests (:use :cl :pg #+cmu :fwrappers) (:export #:test)) (in-package :pg-tests) (defmacro with-pg-connection/2 ((con &rest open-args) &body body) `(let ((,con (pg::pg-connect/v2 ,@open-args))) (unwind-protect (progn ,@body) (when ,con (pg-disconnect ,con))))) ;; !!! CHANGE THE VALUES HERE !!! (defmacro with-test-connection ((conn &key (database "test") (user-name "pgdotlisp") (password "secret") (host "localhost") ;; or "/var/run/postgresql/" (port 5432) (encoding *pg-client-encoding*)) &body body) `(with-pg-connection (,conn ,database ,user-name :password ,password :host ,host :port ,port :encoding ,encoding) ,@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) (let ((count 0) (created nil)) (unwind-protect (progn (pg-exec conn "CREATE TABLE count_test(key int, val int)") (loop :for i :from 1 :to 100 :for sql = (format nil "INSERT INTO count_test VALUES(~s, ~s)" i (* i i)) :do (pg-exec conn sql)) (setq created t) (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" (lambda (tuple) (incf count (first tuple)))) (assert (= 5050 count))) (when created (pg-exec conn "DROP TABLE count_test")))))) (defun test-insert/float () (format *debug-io* "Testing INSERT & SELECT on floats ...~%") (with-test-connection (conn) (let ((sum 0.0) (created nil)) (flet ((float-eql (a b) (< (/ (abs (- a b)) b) 1e-5))) (unwind-protect (progn (pg-exec conn "CREATE TABLE count_test_float(key int, val float)") (setq created t) (loop :for i :from 1 :to 1000 :for sql = (format nil "INSERT INTO count_test_float VALUES(~d, ~f)" i i) :do (pg-exec conn sql)) (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" (lambda (tuple) (incf sum (first tuple)))) (assert (float-eql 500500 sum))) (when created (pg-exec conn "DROP TABLE count_test_float"))))))) (defun test-insert/numeric () (format *debug-io* "Testing INSERT & SELECT on NUMERIC ...~%") (with-test-connection (conn) (let ((sum 0) (created nil)) (unwind-protect (progn (pg-exec conn "CREATE TABLE count_test_numeric(key int, val numeric(10,2))") (setq created t) (loop :for i :from 1 :to 1000 :for sql = (format nil "INSERT INTO count_test_numeric VALUES(~d, ~f)" i i) :do (pg-exec conn sql)) (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" (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")))))) (defun test-date () (format *debug-io* "Testing DATE and TIMESTAMP parsing ...~%") (with-test-connection (conn) (let ((created nil)) (unwind-protect (progn (pg-exec conn "CREATE TABLE pgltest (a timestamp, b abstime, c time, d date)") (setq created t) (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)) (format t "Timestamp = ~s~%abstime = ~s~%time = ~s (CL universal-time = ~d)~%date = ~s~%" (first parsed) (second parsed) (third parsed) (get-universal-time) (fourth parsed)))) (when created (pg-exec conn "DROP TABLE pgltest")))))) (defun test-booleans () (format *debug-io* "Testing support for BOOLEAN type ...~%") (with-test-connection (conn) (let ((created nil)) (unwind-protect (progn (pg-exec conn "CREATE TABLE pgbooltest (a BOOLEAN, b INT4)") (setq created t) (pg-exec conn "INSERT INTO pgbooltest VALUES ('t', 42)") (dotimes (i 100) (pg-exec conn (format nil "INSERT INTO pgbooltest VALUES ('f', ~D)" i))) (let ((sum 0)) (pg-for-each conn "SELECT * FROM pgbooltest" (lambda (tuple) (when (first tuple) (incf sum (second tuple))))) (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))) (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")))))) (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) (check-single-return conn "SELECT /* embedded comment */ CASE 'a' WHEN 'a' THEN 42 ELSE 2 END" 42))) (defun test-integrity () (format *debug-io* "Testing integrity constaint signaling ...~%") (with-test-connection (conn) (let ((created nil)) (unwind-protect (progn (pg-exec conn "CREATE TABLE pgintegritycheck (a INTEGER UNIQUE)") (setq created t) (dotimes (i 100) (pg-exec conn (format nil "INSERT INTO pgintegritycheck VALUES (~D)" i))) (handler-case (pg-exec conn "INSERT INTO pgintegritycheck VALUES (1)") (pg:backend-error (exc) (format *debug-io* "OK: integrity constraint handled: ~A~%" exc)) (error (exc) (format *debug-io* "FAIL: unhandled integrity constraint: ~A~%" exc)))) (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 "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)) (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") (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 (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 (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[][][], 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 (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')") (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))))) (defun test-encoding () (let ((octets (coerce '(105 97 122 115 124) '(vector (unsigned-byte 8))))) (dolist (encoding '("UTF8" "LATIN1" "LATIN2")) (let ((encoded (pg::convert-string-from-bytes octets encoding))) (with-test-connection (conn :encoding encoding) (ignore-errors (pg-exec conn "DROP TABLE encoding_test")) (pg-exec conn "CREATE TABLE encoding_test (a VARCHAR(40))") (pg-exec conn "INSERT INTO encoding_test VALUES ('" encoded "')") (check-single-return conn "SELECT * FROM encoding_test" encoded :test #'string=) (pg-exec conn "DROP TABLE encoding_test")))))) ;; Fibonnaci numbers with memoization via a database table (defun fib (n) (declare (type integer n)) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) ;; (compile 'fib) #+cmu (define-fwrapper memoize-fib (n) (let* ((conn (fwrapper-user-data fwrapper)) (res (pg-exec conn (format nil "SELECT fibn FROM fib WHERE n = ~d" n))) (tuples (pg-result res :tuples))) (cond ((zerop (length tuples)) (let ((fibn (call-next-function))) (pg-exec conn (format nil "INSERT INTO fib VALUES (~D, ~D)" n fibn)) fibn)) ((eql 1 (length tuples)) (caar tuples)) (t (error "integrity error in fibn table"))))) (defun test-fib () (format *debug-io* "Testing fibonnaci number generation ...~%3") (with-test-connection (conn) (let ((created nil) (non-memoized 0) (memoized 0)) (unwind-protect (progn (pg-exec conn "CREATE TABLE fib (n INTEGER, fibn INT8)") (setq created t) #+cmu (funwrap 'fib) (time (setq non-memoized (fib 40))) #+cmu (fwrap 'fib #'memoize-fib :user-data conn) #+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))) (when created (pg-exec conn "DROP TABLE fib")))))) (defun test-lo () (format *debug-io* "Testing large object support ...~%") (with-test-connection (conn) (with-pg-transaction conn (let* ((oid (pglo-create conn)) (fd (pglo-open conn oid))) (sleep 1) (pglo-tell conn fd) (sleep 1) (pglo-unlink conn oid))))) ;; test of large-object interface. We are careful to use vectors of ;; bytes instead of strings, because with the v3 protocol strings ;; undergo \\xxx encoding (for instance #\newline is transformed to \\012). (defun test-lo-read () (format *debug-io* "Testing read of large object ...~%") (with-test-connection (conn) (with-pg-transaction conn (let* ((oid (pglo-create conn "rw")) (fd (pglo-open conn oid "rw"))) (pglo-write conn fd (map '(vector (unsigned-byte 8)) #'char-code (format nil "Hi there mate~%What's up?~%"))) (pglo-lseek conn fd 3 0) ; SEEK_SET = 0 (assert (eql 3 (pglo-tell conn fd))) ;; this should print "there mate" (format *debug-io* "Read ~s from lo~%" (map 'string #'code-char (pglo-read conn fd 10))) (format *debug-io* "Rest is ~s~%" (map 'string #'code-char (pglo-read conn fd 1024))) (pglo-close conn fd) #+nil (pglo-unlink conn oid))))) #+cmu (defun test-lo-import () (format *debug-io* "Testing import of large object ...~%") (with-test-connection (conn) (with-pg-transaction conn (let ((oid (pglo-import conn "/etc/group"))) (pglo-export conn oid "/tmp/group") (cond ((zerop (ext:process-exit-code (ext:run-program "diff" (list "/tmp/group" "/etc/group")))) (format *debug-io* "pglo-import test succeeded~%") (unix:unix-unlink "/tmp/group")) (t (format *debug-io* "pglo-import test failed: check differences between files /etc/group and /tmp/group"))) (pglo-unlink conn oid))))) (defun test-simple () (let ((*pg-disable-type-coercion* t)) (with-test-connection (conn) (format t "backend ~a~%" (pg-backend-version conn))))) (defun test-notifications () (with-test-connection (conn) (let (res) (setq res (pg-exec conn "LISTEN pg_test_listen")) (format t "LISTEN -> ~S~%" (pg-result res :status)) (assert (null (pg::pgcon-notices conn))) (pg-exec conn "SELECT * FROM pg_type") (assert (null (pg::pgcon-notices conn))) (setq res (pg-exec conn "NOTIFY pg_test_listen")) (format t "NOTIFY -> ~S~%" (pg-result res :status)) (format t "In TEST-NOTIFICATIONS notices are ~S~%" (pg::pgcon-notices conn))))) ;; FIXME could add interaction between producer and consumers via NOTIFY #+(and cmu mp) (defun test-multiprocess () (format *debug-io* "Testing multiprocess database access~%") (when (eq mp::*current-process* mp::*initial-process*) (mp::startup-idle-and-top-level-loops)) (with-test-connection (conn) (pg-exec conn "CREATE TABLE pgmt (a TEXT, b INTEGER, C FLOAT)")) (flet ((producer () (with-test-connection (conn) (dotimes (i 5000) (pg-exec conn (format nil "INSERT INTO pgmt VALUES (~S, ~D, ~F)" i i i)) (when (zerop (mod i 100)) (pg-exec conn "COMMIT WORK"))))) (consumer () (with-test-connection (conn) (dotimes (i 10) (sleep 1) (let ((res (pg-exec conn "SELECT count(*) FROM pgmt"))) (format *debug-io* " Consumer sees ~D rows~%" (first (pg-result res :tuple 0)))))))) (let ((p1 (mp:make-process #'producer :name "PG data producer")) (p2 (mp:make-process #'producer :name "PG data producer")) (p3 (mp:make-process #'producer :name "PG data producer")) (co (mp:make-process #'consumer :name "PG data consumer"))) (loop :while (some 'mp:process-alive-p (list p1 p2 p3 co)) :do (sleep 5) (mp:show-processes t)))) (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* con 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/int4 ...") (let ((count 0) (created nil)) (unwind-protect (progn (pg-exec conn "CREATE TABLE count_test(key int, val int)") (setq created t) (pg-prepare conn "ct_insert" "INSERT INTO count_test VALUES ($1, $2)" '("int4" "int4")) (loop :for i :from 1 :to 100 :do (pg-bind conn "ct_portal" "ct_insert" `((:int32 ,i) (:int32 ,(* i i)))) (pg-execute conn "ct_portal") (pg-close-portal conn "ct_portal")) (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" (lambda (tuple) (incf count (first tuple)))) (assert (= 5050 count))) (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 ((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")) (check-single-return conn "SELECT count(val) FROM pbe_text_test" 100) (check-single-return conn "SELECT sum(key) FROM pbe_text_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 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, 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) :if-does-not-exist :create :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" :direction :input :element-type '(unsigned-byte 8) :if-does-not-exist :error) (setf (pgcon-sql-stream conn) stream) (pg-exec conn "COPY foo FROM stdout")) (let ((res (pg-exec conn "SELECT b FROM foo WHERE a = 1"))) (assert (eql 2 (first (pg-result res :tuple 0))))) (let ((res (pg-exec conn "SELECT c FROM foo WHERE a = 1"))) (assert (string-equal "two" (first (pg-result res :tuple 0))))) (let ((res (pg-exec conn "SELECT b FROM foo WHERE a = 2"))) (assert (eql 4 (first (pg-result res :tuple 0))))) (pg-exec conn "DROP TABLE foo"))) (defun test-triggers () (with-test-connection (conn) (ignore-errors (pg-exec conn "DROP TABLE pg_trigger_table")) (pg-exec conn "CREATE TABLE pg_trigger_table (a int, b int)") (pg-exec conn "CREATE FUNCTION trigger_func() RETURNS trigger LANGUAGE plpgsql AS '" "BEGIN " "RAISE NOTICE ''trigger_func() called: action = %, when = %, level = %'', TG_OP, TG_WHEN, TG_LEVEL; " "RETURN NULL; " "END;'") (pg-exec conn "CREATE TRIGGER before_ins_stmt_trig BEFORE INSERT ON pg_trigger_table " "FOR EACH STATEMENT EXECUTE PROCEDURE trigger_func()") (pg-exec conn "CREATE TRIGGER after_ins_stmt_trig AFTER INSERT ON pg_trigger_table " "FOR EACH STATEMENT EXECUTE PROCEDURE trigger_func()") (pg-exec conn "INSERT INTO pg_trigger_table VALUES (1, 2)") (pg-exec conn "INSERT INTO pg_trigger_table VALUES (3, 4)") (pg-exec conn "DROP TABLE pg_trigger_table"))) (defun test () (let (#+nil(*pg-client-encoding* "UTF8")) (with-test-connection (conn) (format t "Running pg.lisp tests against backend ~a~%" (pg-backend-version conn)) ;; client encoding supported since PostgreSQL v7.1 (format t "Client encoding is ~A~%" (pg-client-encoding conn)) (format t "Date style is ~A~%" (pg-date-style conn)) (let ((r2 (pg-exec conn "CREATE TABLE pgltest (a int, b float, c numeric)")) (r3 (pg-exec conn "INSERT INTO pgltest VALUES (3, -1234.5e67, 123.45)")) (r4 (pg-exec conn "DROP TABLE pgltest"))) (format t "~%==============================================~%") (format t "status of CREATE is ~s~%" (pg-result r2 :status)) (format t "status of INSERT is ~s~%" (pg-result r3 :status)) (format t "oid of INSERT is ~s~%" (pg-result r3 :oid)) (format t "status of DROP is ~s~%" (pg-result r4 :status)) (format t "==============================================~%"))) (test-simple) (test-insert) (test-insert/float) (test-insert/numeric) (test-date) (test-booleans) (test-integer-overflow) (test-strings) (test-integrity) (test-error-handling) (test-transactions) (test-arrays) (test-bit-tables) (test-notifications) (test-lo) (test-lo-read) #+cmu (test-lo-import) (test-pbe) (test-pbe-text) #+unix (test-copy-in-out) (values))) ;; EOF cl-pg-20061216.orig/pg.asd0000644000175000017500000000254210560035327015253 0ustar pvaneyndpvaneynd;;; -*- Mode: lisp -*- ;; (defpackage #:pg-system (:use #:asdf #:cl)) (in-package #:pg-system) (defclass pg-component (cl-source-file) ()) ;; For CMUCL, ensure that the crypt library is loaded before ;; attempting to load the code. #+cmu (defmethod perform :before ((o load-op) (c pg-component)) (ext:load-foreign "/usr/lib/libcrypt.so")) (defsystem :pg :name "Socket-level PostgreSQL interface" :author "Eric Marsden" :version "0.24" :depends-on ( #+lispworks "comm" #+cormanlisp :sockets #+sbcl :sb-bsd-sockets #+sbcl :sb-rotate-byte #+(and mcl (not openmcl)) "OPENTRANSPORT") :components ((:file "md5") (:file "defpackage" :depends-on ("md5")) (:pg-component "sysdep" :depends-on ("defpackage" "md5")) (:file "meta-queries" :depends-on ("defpackage")) (:file "parsers" :depends-on ("defpackage")) (:file "utility" :depends-on ("defpackage")) (:file "lowlevel" :depends-on ("defpackage")) (:file "pg" :depends-on ("sysdep" "parsers")) (:file "large-object" :depends-on ("pg")) (:file "v2-protocol" :depends-on ("pg" "large-object" "utility")) (:file "v3-protocol" :depends-on ("pg" "large-object" "utility")))) cl-pg-20061216.orig/pg.lisp0000644000175000017500000002542710560035327015462 0ustar pvaneyndpvaneynd;;; pg.lisp -- socket level interface to the PostgreSQL RDBMS for Common Lisp ;; ;; Author: Eric Marsden ;; Time-stamp: <2006-11-19 emarsden> ;; Version: 0.22 ;; ;; Copyright (C) 1999,2000,2001,2002,2003,2004,2005 Eric Marsden ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Library General Public ;; License as published by the Free Software Foundation; either ;; version 2 of the License, or (at your option) any later version. ;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Library General Public License for more details. ;; ;; You should have received a copy of the GNU Library General Public ;; License along with this library; if not, write to the Free ;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;; ;; Please send suggestions and bug reports to ;;; Overview ========================================================= ;; ;; This module lets you access the PostgreSQL object-relational DBMS ;; from Common Lisp. The code implements the client part of the ;; socket-level frontend/backend protocol, rather than providing a ;; wrapper around the libpq library. The module is capable of type ;; coercions from a range of SQL types to the equivalent Lisp type. ;; The only non portable code is the use of 'socket-connect' and ;; (optional) some way of accessing the Unix crypt() function. ;; ;; Works with pretty much all the ANSI Common Lisp implementations. ;; Exceptions are Corman Common Lisp whose socket streams do not ;; support binary I/O. ;; ;; See the README for API documentation. ;; Please note that your postmaster has to be started with the `-i' ;; option in order for it to accept TCP/IP connections (typically this ;; is not the default setting). See the PostgreSQL documentation at ;; for more information. ;; ;; Thanks to Marc Battyani for the LW port and for bugfixes, to ;; Johannes GrÞdem for a fix to parsing of DATE ;; types, to Doug McNaught and Howard Ding for bugfixes, to Ernst ;; Jeschek for pointing out a bug in float parsing, to Brian Lui for ;; providing fixes for ACL6, to James Anderson for providing a fix for ;; a change in PostgreSQL timestamp format. (declaim (optimize (speed 3) (safety 1))) (in-package :postgresql) (define-condition postgresql-error (simple-error) ()) (define-condition connection-failure (postgresql-error) ((host :initarg :host :reader connection-failure-host) (port :initarg :port :reader connection-failure-port) (transport-error :initarg :transport-error :reader connection-failure-transport-error)) (:report (lambda (exc stream) (declare (type stream stream)) (format stream "Couldn't connect to PostgreSQL database at ~a:~a. Connection attempt reported ~A. Is the postmaster running and accepting TCP connections?~%" (connection-failure-host exc) (connection-failure-port exc) (connection-failure-transport-error exc))))) (define-condition authentication-failure (postgresql-error) ((reason :initarg :reason :reader authentication-failure-reason)) (:report (lambda (exc stream) (declare (type stream stream)) (format stream "PostgreSQL authentication failure: ~a~%" (authentication-failure-reason exc))))) (define-condition protocol-error (postgresql-error) ((reason :initarg :reason :reader protocol-error-reason)) (:report (lambda (exc stream) (declare (type stream stream)) (format stream "PostgreSQL protocol error: ~a~%" (protocol-error-reason exc))))) (define-condition backend-error (postgresql-error) ((reason :initarg :reason :reader backend-error-reason)) (:report (lambda (exc stream) (declare (type stream stream)) (format stream "PostgreSQL backend error: ~a~%" (backend-error-reason exc))))) (defconstant +NAMEDATALEN+ 32) ; postgres_ext.h (defconstant +SM_DATABASE+ 64) (defconstant +SM_USER+ 32) (defconstant +SM_OPTIONS+ 64) (defconstant +SM_UNUSED+ 64) (defconstant +SM_TTY+ 64) (defconstant +STARTUP_MSG+ 7) (defconstant +STARTUP_KRB4_MSG+ 10) (defconstant +STARTUP_KRB5_MSG+ 11) (defconstant +STARTUP_PASSWORD_MSG+ 14) (defconstant +STARTUP_PACKET_SIZE+ (+ 4 4 +SM_DATABASE+ +SM_USER+ +SM_OPTIONS+ +SM_UNUSED+ +SM_TTY+)) (defconstant +MAX_MESSAGE_LEN+ 8192) ; libpq-fe.h (defvar *pg-client-encoding* "LATIN1" "The encoding that will be used for communication with the PostgreSQL backend, for example \"LATIN1\", \"UTF8\", \"EUC_JP\". See .") (defvar *pg-date-style* "ISO") (defclass pgcon () ((stream :accessor pgcon-stream :initarg :stream :initform nil) (host :accessor pgcon-host :initarg :host :initform nil) (port :accessor pgcon-port :initarg :port :initform 0) (pid :accessor pgcon-pid) (secret :accessor pgcon-secret) (notices :accessor pgcon-notices :initform (list)) (binary-p :accessor pgcon-binary-p :initform nil) (encoding :accessor pgcon-encoding :initarg :encoding))) (defmethod print-object ((self pgcon) stream) (print-unreadable-object (self stream :type nil) (with-slots (pid host port) self (format stream "PostgreSQL connection to backend pid ~d at ~a:~d" (when (slot-boundp self 'pid) pid) (when (slot-boundp self 'host) host) (when (slot-boundp self 'port) port))))) (defstruct pgresult connection status attributes tuples) (defgeneric pg-exec (connection &rest args) (:documentation "Execute the SQL command given by the concatenation of ARGS on the database to which we are connected via CONNECTION. Return a result structure which can be decoded using `pg-result'.")) (defgeneric fn (connection fn integer-result &rest args) (:documentation "Execute one of the large-object functions (lo_open, lo_close etc). Argument FN is either an integer, in which case it is the OID of an element in the pg_proc table, and otherwise it is a string which we look up in the alist *lo-functions* to find the corresponding OID.")) (defgeneric pg-disconnect (connection &key abort) (:documentation "Disconnects from the DB")) (defgeneric pg-supports-pbe (connection) (:documentation "Returns true if the connection supports pg-prepare/-bind and -execute") (:method (connection) (declare (ignore connection)) nil)) (defgeneric pg-prepare (connection statement-name sql-statement &optional type-of-parameters) (:documentation "Prepares a sql-statement give a given statement-name (can be empty) and optionally declares the types of the parameters as a list of strings. You can define parameters to be filled in later by using $1 and so on.")) (defgeneric pg-bind (connection portal statement-name list-of-types-and-values) (:documentation "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 maximum-number-of-rows) (:documentation "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 "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 "Closes a prepared statement portal")) (defgeneric pglo-read (connection fd bytes) (:documentation "Read from a large object on file descriptor FD.")) ;; first attempt to connect to connect using the v3 protocol; if this ;; results in an ErrorResponse we close the connection and retry using ;; the v2 protocol. This allows us to connect to PostgreSQL 7.4 ;; servers using the benefits of the new protocol, but still interact ;; with older servers. (defun pg-connect (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*)) "Initiate a connection with the PostgreSQL backend. Connect to the database DBNAME with the username USER, on PORT of HOST, providing PASSWORD if necessary. Return a connection to the database (as an opaque type). If HOST is a pathname or a string starting with #\/, it designates the directory containing the Unix socket on which PostgreSQL's backend is waiting for local connections. We first attempt to speak the PostgreSQL 7.4 protocol, and fall back to the older network protocol if necessary." (handler-case (pg-connect/v3 dbname user :host host :port port :password password :encoding encoding) (protocol-error (c) (declare (ignore c)) (warn "reconnecting using protocol version 2") (pg-connect/v2 dbname user :host host :port port :password password :encoding encoding)))) (defun pg-result (result what &rest args) "Extract WHAT component of RESULT. RESULT should be a structure obtained from a call to `pg-exec', and WHAT should be one of :connection -> return the connection object :status -> return the status string provided by the database :attributes -> return the metadata, as a list of lists :tuples -> return the data, as a list of lists :tuple n -> return the nth component of the data :oid -> return the OID (a unique identifier generated by PostgreSQL for each row resulting from an insertion" (declare (type pgresult result)) (cond ((eq :connection what) (pgresult-connection result)) ((eq :status what) (pgresult-status result)) ((eq :attributes what) (pgresult-attributes result)) ((eq :tuples what) (pgresult-tuples result)) ((eq :tuple what) (let ((which (if args (first args) (error "which tuple?"))) (tuples (pgresult-tuples result))) (nth which tuples))) ((eq :oid what) (let ((status (pgresult-status result))) (if (string= "INSERT" (subseq status 0 6)) (parse-integer (subseq status 7 (position #\space status :start 7))) (error "Only INSERT commands generate an oid: ~s" status)))) (t (error "Unknown result request: ~s" what)))) ;; EOF cl-pg-20061216.orig/stone-age-load.lisp0000644000175000017500000000100410560035327017634 0ustar pvaneyndpvaneynd;;; stone-age-load.lisp ;;; ;;; Author: Eric Marsden ;;; Time-stamp: <2005-07-17 emarsden> (load (compile-file "md5.lisp")) (load "defpackage.lisp") (load (compile-file "meta-queries.lisp")) (load (compile-file "sysdep.lisp")) (load (compile-file "parsers.lisp")) (load (compile-file "utility.lisp")) (load (compile-file "lowlevel.lisp")) (load (compile-file "pg.lisp")) (load (compile-file "large-object.lisp")) (load (compile-file "v2-protocol.lisp")) (load (compile-file "v3-protocol.lisp")) ;; EOF cl-pg-20061216.orig/sysdep.lisp0000644000175000017500000003211610560035327016354 0ustar pvaneyndpvaneynd;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp ;;; ;;; Author: Eric Marsden ;;; Time-stamp: <2006-11-19 emarsden> ;; ;; (in-package :postgresql) (eval-when (:compile-toplevel :load-toplevel :execute) #+lispworks (require "comm") #+cormanlisp (require :sockets) #+armedbear (require :socket)) (defmacro %sysdep (desc &rest forms) (when (null forms) (error "No system dependent code to ~A" desc)) (car forms)) #+(and cmu glibc2) (eval-when (:compile-toplevel :load-toplevel) (format t ";; Loading libcrypt~%") ;; (ext:load-foreign "/lib/libcrypt.so.1") (sys::load-object-file "/usr/lib/libcrypt.so")) #+(and cmu glibc2) (defun crypt (key salt) (declare (type string key salt)) (alien:alien-funcall (alien:extern-alien "crypt" (function c-call:c-string c-call:c-string c-call:c-string)) key salt)) #-(and cmu glibc2) (defun crypt (key salt) (declare (ignore salt)) key) (defun md5-digest (string &rest strings) (declare (type simple-string string)) (let ((vec (md5sum-sequence (map '(vector (unsigned-byte 8)) #'char-code (apply #'concatenate 'string string strings))))) (format nil "~(~{~2,'0X~}~)" (coerce vec 'list)))) (defun md5-encode-password (user password salt) (concatenate 'string "md5" (md5-digest (md5-digest password user) salt))) ;; this is a little fiddly, because CLISP can be built without support ;; for the Linux package ;; #+CLISP ;; (defun crypt (key salt) ;; (linux::crypt key salt)) ;; bug in WRITE-SEQUENCE in CMUCL #+(or cmu18c cmu18d) (defun write-sequence (seq stream &key start end) (declare (ignore start end)) (loop :for element :across seq :do (write-byte element stream))) ;; work around bug in FASL fop dumping #+cmu (setf c::top-level-lambda-max 0) #+(and cmu ssl) (defun socket-connect (port host) (declare (type integer port)) (handler-case (let ((fd (ext:connect-to-inet-socket host port))) (ssl:make-ssl-client-stream fd)) (error (e) (error 'connection-failure :host host :port port :transport-error e)))) #+cmu (defun socket-connect (port host) (declare (type integer port)) (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 #+(and cmu simple-streams broken) (defun socket-connect (port host) (declare (type integer port)) (handler-case (make-instance 'stream:socket-simple-stream :remote-host host :remote-port port :direction :io) (error (e) (error 'connection-failure :host host :port port :transport-error e)))) #+clisp (defun socket-connect (port host) (declare (type integer port)) (handler-case (#+lisp=cl socket:socket-connect #-lisp=cl lisp:socket-connect port host :element-type '(unsigned-byte 8) :buffered t) (error (e) (declare (ignore e)) (error 'connection-failure :host host :port port)))) #+sbcl (defun socket-connect (port host-name) (declare (type integer port)) (let ((host (if (typep host-name 'pathname) (namestring host-name) host-name))) (handler-case (sb-bsd-sockets:socket-make-stream (if (eql #\/ (char host 0)) (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream))) (sb-bsd-sockets:socket-connect s (format nil "~A.s.PGSQL.~D" (string host) port)) s) (let ((s (make-instance 'sb-bsd-sockets:inet-socket :type :stream :protocol :tcp)) (num (car (sb-bsd-sockets:host-ent-addresses (sb-bsd-sockets:get-host-by-name host))))) (sb-bsd-sockets:socket-connect s num port) s)) :element-type '(unsigned-byte 8) :input t :output t :buffering :none) (error (e) (error 'connection-failure :host host :port port :transport-error e))))) #+allegro (defun socket-connect (port host) (declare (type integer port)) (handler-case (if (eql #\/ (char host 0)) (socket:make-socket :type :stream :address-family :file :connect :active :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)))) ;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary ;; streams. Fixed in version 4.3. #+lispworks (defun socket-connect (port host) (declare (type integer port)) (handler-case (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 :port port :transport-error e)))) ;; this doesn't work, since the Corman sockets module doesn't support ;; binary I/O on socket streams. #+cormanlisp (defun socket-connect (port host) (declare (type integer port)) (handler-case (progn (sockets:start-sockets) (let ((sock (sockets:make-client-socket :host host :port port))) (sockets:make-socket-stream sock))) (error (e) (error 'connection-failure :host host :port port :transport-error e)))) #+openmcl (defun socket-connect (port host) (declare (type integer port)) (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)) (defun socket-connect (port host) (declare (type integer port)) (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8))) ;; There is a bug in MCL (4.3.1 tested) where read-sequence and ;; write-sequence fail with binary tcp streams. These two methods ;; provide a work-around. #+(and mcl (not openmcl)) (defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream) (sequence ccl::simple-unsigned-byte-vector) &key (start 0) end) (ccl::stream-write-vector s sequence start (or end (length sequence))) s) #+(and mcl (not openmcl)) (defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream) (sequence ccl::simple-unsigned-byte-vector) &key (start 0) (end (length sequence))) (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s) sequence (- end start) start) end) #+ecl (defun socket-connect (port host) (declare (type integer port)) (handler-case (si:open-client-stream host port) (error (e) (error 'connection-failure :host host :port port :transport-error e)))) ;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't ;; work, DEFINE-CONDITION not implemented, ... #+gcl (defun socket-connect (port host) (declare (type integer port)) (si::socket port :host host)) #+armedbear (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)) (handler-case (ext:get-socket-stream (ext:make-socket host port) :element-type '(unsigned-byte 8)) (error (e) (error 'connection-failure :host host :port port :transport-error e)))) ;; for Lispworks ;; (defun encode-lisp-string (string) ;; (translate-string-via-fli string :utf-8 :latin-1)) ;; ;; (defun decode-external-string (string) ;; (translate-string-via-fli string :latin-1 :utf-8)) ;; ;; ;; Note that a :utf-8 encoding of a null in a latin-1 string is ;; ;; also null, and vice versa. So don't have to worry about ;; ;; null-termination or length. (If we were translating to/from ;; ;; :unicode, this would become an issue.) ;; ;; (defun translate-string-via-fli (string from to) ;; (fli:with-foreign-string (ptr elements bytes :external-format from) ;; string ;; (declare (ignore elements bytes)) ;; (fli:convert-from-foreign-string ptr :external-format to))) ;;; character encoding support (defvar *pg-client-encoding*) (defun implementation-name-for-encoding (encoding) (%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) ((string-equal encoding "LATIN2") charset:iso-8859-2) ((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-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-equal encoding "SQL_ASCII") :ascii) ((string-equal encoding "LATIN1") :iso-8859-1) ((string-equal encoding "LATIN2") :iso-8859-2) ((string-equal encoding "LATIN9") :iso-8859-9) ((string-equal encoding "UTF8") :utf8) (t (error "unknown encoding ~A" encoding))) #+(or cmu gcl ecl abcl openmcl lispworks) nil)) (defun convert-string-to-bytes (string encoding) (declare (type string string)) (%sysdep "convert string to octet-array" #+(and clisp unicode) (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding)) #+(and allegro ics) (excl:string-to-octets string :null-terminate nil :external-format (implementation-name-for-encoding encoding)) #+(and :sbcl :sb-unicode) (sb-ext:string-to-octets string :external-format (implementation-name-for-encoding encoding)) #+(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)) (error "Can't convert ~A string to octets" encoding)))) (defun convert-string-from-bytes (bytes encoding) (declare (type (vector (unsigned-byte 8)) bytes)) (%sysdep "convert octet-array to string" #+(and clisp unicode) (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding)) #+(and allegro ics) (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding)) #+(and :sbcl :sb-unicode) (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding)) ;; 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 lispworks) (let ((string (make-string (length bytes)))) (map-into string #'code-char bytes)))) ;; EOF cl-pg-20061216.orig/utility.lisp0000644000175000017500000000741010560035327016547 0ustar pvaneyndpvaneynd;;; utility.lisp -- wrapper functions and macros ;;; ;;; Author: Eric Marsden ;;; Time-stamp: <2006-09-30 emarsden> (in-package :postgresql) (defun pg-date-style (conn) (let ((res (pg-exec conn "SHOW datestyle"))) (first (pg-result res :tuple 0)))) (defun set-pg-date-style (conn new-date-style) (declare (type simple-string new-date-style)) (pg-exec conn "SET datestyle TO " new-date-style)) (defsetf pg-date-style set-pg-date-style) ;; see http://www.postgresql.org/docs/7.3/static/multibyte.html (defun pg-client-encoding (conn) "Return a string identifying the client encoding." (let ((res (pg-exec conn "SHOW client_encoding"))) (first (pg-result res :tuple 0)))) (defun set-pg-client-encoding (conn new-encoding) "Set the client_encoding." (declare (type simple-string new-encoding)) (pg-exec conn "SET client_encoding TO " new-encoding)) (defsetf pg-client-encoding set-pg-client-encoding) (defmacro with-pg-connection ((con &rest open-args) &body body) "Bindspec is of the form (connection open-args), where OPEN-ARGS are as for PG-CONNECT. The database connection is bound to the variable CONNECTION. If the connection is unsuccessful, the forms are not evaluated. Otherwise, the BODY forms are executed, and upon termination, normal or otherwise, the database connection is closed." (let ((ok (gensym))) `(let ((,con (pg-connect ,@open-args)) (,ok nil)) (unwind-protect (multiple-value-prog1 (progn ,@body) (setf ,ok t)) (when ,con (pg-disconnect ,con :abort (not ,ok))))))) ;; this is the old version #+(or) (defmacro with-pg-transaction (con &body body) "Execute BODY forms in a BEGIN..END block. If a PostgreSQL error occurs during execution of the forms, execute a ROLLBACK command. Large-object manipulations _must_ occur within a transaction, since the large object descriptors are only valid within the context of a transaction." `(progn (pg-exec ,con "BEGIN WORK") (handler-case (prog1 (progn ,@body) (pg-exec ,con "COMMIT WORK")) (error (e) (pg-exec ,con "ROLLBACK WORK") (error e))))) ;;; this version thanks to Daniel Barlow. The old version would abort ;;; the transaction before entering the debugger, which made ;;; debugging difficult. (defmacro with-pg-transaction (con &body body) "Execute BODY forms in a BEGIN..END block. If a PostgreSQL error occurs during execution of the forms, execute a ROLLBACK command. Large-object manipulations _must_ occur within a transaction, since the large object descriptors are only valid within the context of a transaction." (let ((success (gensym "SUCCESS"))) `(let (,success) (unwind-protect (prog2 (pg-exec ,con "BEGIN WORK") (progn ,@body) (setf ,success t)) (pg-exec ,con (if ,success "COMMIT WORK" "ROLLBACK WORK")))))) (defun pg-for-each (conn select-form callback) "Create a cursor for SELECT-FORM, and call CALLBACK for each result. Uses the PostgreSQL database connection CONN. SELECT-FORM must be an SQL SELECT statement. The cursor is created using an SQL DECLARE CURSOR command, then results are fetched successively until no results are left. The cursor is then closed. The work is performed within a transaction. The work can be interrupted before all tuples have been handled by THROWing to a tag called 'pg-finished." (let ((cursor (symbol-name (gensym "PGCURSOR")))) (catch 'pg-finished (with-pg-transaction conn (pg-exec conn "DECLARE " cursor " CURSOR FOR " select-form) (unwind-protect (loop :for res = (pg-result (pg-exec conn "FETCH 1 FROM " cursor) :tuples) :until (zerop (length res)) :do (funcall callback (first res))) (pg-exec conn "CLOSE " cursor)))))) ;; EOF cl-pg-20061216.orig/v2-protocol.lisp0000644000175000017500000003030310560035327017227 0ustar pvaneyndpvaneynd;;; v2-protocol.lisp -- frontend/backend protocol prior to PostgreSQL 7.4 ;;; ;;; Author: Eric Marsden (in-package :postgresql) (defclass pgcon-v2 (pgcon) ()) (defun pg-connect/v2 (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*)) "Initiate a connection with the PostgreSQL backend, using protocol v2. Connect to the database DBNAME with the username USER, on PORT of HOST, providing PASSWORD if necessary. Return a connection to the database (as an opaque type). If HOST is a pathname or a string whose first character is #\/, it designates the directory containing the Unix socket on which the PostgreSQL backend is listening." (let* ((stream (socket-connect port host)) (connection (make-instance 'pgcon-v2 :stream stream :host host :port port :encoding encoding)) (user-packet-length (+ +SM_USER+ +SM_OPTIONS+ +SM_UNUSED+ +SM_TTY+))) ;; send the startup packet (send-int connection +STARTUP_PACKET_SIZE+ 4) (send-int connection 2 2) ; protocol 6.3 major (send-int connection 0 2) ; protocol 6.3 minor (send-string connection dbname +SM_DATABASE+) (send-string connection user user-packet-length) (%flush connection) (loop (case (read-byte stream) ;; ErrorResponse ((69) (close stream) (error 'authentication-failure :reason (%read-cstring stream 4096))) ;; Authentication ((82) (case (read-net-int connection 4) ((0) ; AuthOK (and (not *pg-disable-type-coercion*) (null *parsers*) (initialize-parsers connection)) (when *pg-date-style* (setf (pg-date-style connection) *pg-date-style*)) (when encoding (setf (pg-client-encoding connection) encoding)) (return connection)) ((3) ; AuthUnencryptedPassword (send-int connection (+ 5 (length password)) 4) (send-string connection password) (send-int connection 0 1) (%flush connection)) ((4) ; AuthEncryptedPassword (let* ((salt (%read-chars stream 2)) (crypted (crypt password salt))) #+debug (format *debug-io* "Got salt of ~s~%" salt) (send-int connection (+ 4 (length crypted) 1) 4) (send-string connection crypted) (send-int connection 0 1) (%flush connection))) ((5) ; AuthMD5Password #+debug (format *debug-io* "MD5Auth: got salt of ~s~%" salt) (force-output *debug-io*) (let* ((salt (%read-chars stream 4)) (ciphered (md5-encode-password user password salt))) (send-int connection (+ 4 (length ciphered) 1) 4) (send-string connection ciphered) (send-int connection 0 1) (%flush connection))) ((1) ; AuthKerberos4 (error 'authentication-failure :reason "Kerberos4 authentication not supported")) ((2) ; AuthKerberos5 (error 'authentication-failure :reason "Kerberos5 authentication not supported")) (t (error 'authentication-failure :reason "unknown authentication type")))) (t (error 'protocol-error :reason "expected an authentication response")))))) (defmethod pg-exec ((connection pgcon-v2) &rest args) "Execute the SQL command given by the concatenation of ARGS 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)) (stream (pgcon-stream connection)) (tuples '()) (attributes '()) (result (make-pgresult :connection connection))) (when (> (length sql) +MAX_MESSAGE_LEN+) (error "SQL statement too long: ~A" sql)) (write-byte 81 stream) (send-string connection sql) (write-byte 0 stream) (%flush connection) (do ((b (read-byte stream nil :eof) (read-byte stream nil :eof))) ((eq b :eof) (error 'protocol-error :reason "unexpected EOF from backend")) (case b ;; asynchronous notify, #\A ((65) ;; read the pid (read-net-int connection 4) (handle-notice connection)) ;; BinaryRow, #\B ((66) (setf (pgcon-binary-p connection) t) (unless attributes (error 'protocol-error :reason "Tuple received before metadata")) (push (read-tuple/v2 connection attributes) tuples)) ;; CompletedResponse, #\C ((67) (let ((status (%read-cstring stream +MAX_MESSAGE_LEN+))) (setf (pgresult-status result) status) (setf (pgresult-tuples result) (nreverse tuples)) (setf (pgresult-attributes result) attributes) (return result))) ;; AsciiRow (text data transfer), #\D ((68) (setf (pgcon-binary-p connection) nil) (unless attributes (error 'protocol-error :reason "Tuple received before metadata")) (push (read-tuple/v2 connection attributes) tuples)) ;; ErrorResponse, #\E ((69) (let ((msg (%read-cstring stream +MAX_MESSAGE_LEN+))) (error 'backend-error :reason msg))) ;; #\G and #\H: start copy in, start copy out ;; EmptyQueryResponse, #\I ((73) (let ((c (read-byte stream))) (when (< 0 c) (error 'protocol-error :reason "Garbled data")))) ;; BackendKeyData, #\K ((75) (setf (pgcon-pid connection) (read-net-int connection 4)) (setf (pgcon-secret connection) (read-net-int connection 4))) ;; NotificationResponse, #\N ((78) (setf (pgcon-pid connection) (read-net-int connection 4)) (handle-notice connection)) ;; CursorResponse, #\P ((80) (let ((str (%read-cstring stream +MAX_MESSAGE_LEN+))) (declare (ignore str)) ;; (format *debug-io* "Portal name ~a~%" str) )) ;; RowDescription (metadata for subsequent tuples), #\T ((84) (and attributes (error "Cannot handle multiple result group")) (setq attributes (read-attributes/v2 connection))) ;; ReadyForQuery ((90) t) (t (error 'protocol-error :reason (format nil "Unknown response type from backend ~d" b))))))) ;; Execute one of the large-object functions (lo_open, lo_close etc). ;; Argument FN is either an integer, in which case it is the OID of an ;; element in the pg_proc table, and otherwise it is a string which we ;; look up in the alist *lo-functions* to find the corresponding OID. (defmethod fn ((connection pgcon-v2) fn integer-result &rest args) (or *lo-initialized* (lo-init connection)) (let ((fnid (cond ((integerp fn) fn) ((not (stringp fn)) (error "Expecting a string or an integer: ~s" fn)) ((assoc fn *lo-functions* :test #'string=) (cdr (assoc fn *lo-functions* :test #'string=))) (t (error "Unknown builtin function ~s" fn))))) (send-int connection 70 1) ; function call (send-int connection 0 1) (send-int connection fnid 4) (send-int connection (length args) 4) (dolist (arg args) (cond ((integerp arg) (send-int connection 4 4) (send-int connection arg 4)) ((stringp arg) (send-int connection (length arg) 4) (send-string connection arg)) ((vectorp arg) (send-int connection (length arg) 4) (send-octets connection arg)) (t (error 'protocol-error :reason (format nil "Unknown fastpath type ~s" arg))))) (%flush connection) (loop :with result = nil :with ready = nil :for b = (read-byte (pgcon-stream connection) nil :eof) :do (case b ;; FunctionResultResponse ((86) (let ((res (read-byte (pgcon-stream connection) nil :eof))) (cond ((= res 0) ; empty result (return-from fn nil)) ((= res 71) ; nonempty result (let ((len (read-net-int connection 4))) (if integer-result (setq result (read-net-int connection len)) (setq result (%read-chars (pgcon-stream connection) len))))) (t (error 'protocol-error :reason "wierd FunctionResultResponse"))))) ;; end of FunctionResult ((48) (return-from fn result)) ((69) (error 'backend-error :reason (%read-cstring (pgcon-stream connection) 4096))) ;; NoticeResponse ((78) (setf (pgcon-pid connection) (read-net-int connection 4)) (handle-notice connection)) ;; ReadyForQuery ((90) (setq ready t)) (t (error 'protocol-error :reason (format nil "Unexpected byte ~s" b))))))) (defmethod pg-disconnect ((connection pgcon-v2) &key abort) (cond (abort (close (pgcon-stream connection) :abort t)) (t (write-byte 88 (pgcon-stream connection)) (%flush connection) (close (pgcon-stream connection)))) (values)) ;; Attribute information is as follows ;; attribute-name (string) ;; attribute-type as an oid from table pg_type ;; attribute-size (in bytes?) (defun read-attributes/v2 (connection) (let ((attribute-count (read-net-int connection 2)) (attributes '())) (do ((i attribute-count (- i 1))) ((zerop i) (nreverse attributes)) (let ((type-name (%read-cstring (pgcon-stream connection) +MAX_MESSAGE_LEN+)) (type-id (read-net-int connection 4)) (type-len (read-net-int connection 2)) ;; this doesn't exist in the 6.3 protocol !! (type-modifier (read-net-int connection 4))) (declare (ignore type-modifier)) (push (list type-name type-id type-len) attributes))))) ;; the bitmap is a string, which we interpret as a sequence of bytes (defun bitmap-ref/v2 (bitmap ref) (multiple-value-bind (char-ref bit-ref) (floor ref 8) (logand #b10000000 (ash (aref bitmap char-ref) bit-ref)))) ;; the server starts by sending a bitmap indicating which tuples are ;; NULL. "A bit map with one bit for each field in the row. The 1st ;; field corresponds to bit 7 (MSB) of the 1st byte, the 2nd field ;; corresponds to bit 6 of the 1st byte, the 8th field corresponds to ;; bit 0 (LSB) of the 1st byte, the 9th field corresponds to bit 7 of ;; the 2nd byte, and so on. Each bit is set if the value of the ;; corresponding field is not NULL. If the number of fields is not a ;; multiple of 8, the remainder of the last byte in the bit map is ;; wasted." (defun read-tuple/v2 (connection attributes) (let* ((num-attributes (length attributes)) (num-bytes (ceiling (/ num-attributes 8))) (bitmap (%read-bytes (pgcon-stream connection) num-bytes)) (correction (if (pgcon-binary-p connection) 0 -4)) (tuples '())) (do ((i 0 (+ i 1)) (type-ids (mapcar #'second attributes) (cdr type-ids))) ((= i num-attributes) (nreverse tuples)) (cond ((zerop (bitmap-ref/v2 bitmap i)) (push nil tuples)) (t (let* ((len (+ (read-net-int connection 4) correction)) (raw (%read-chars (pgcon-stream connection) (max 0 len))) (parsed (parse raw (car type-ids)))) (push parsed tuples))))))) ;; FIXME could signal a postgresql-notification condition (defun handle-notice (connection) (push (%read-cstring (pgcon-stream connection) +MAX_MESSAGE_LEN+) (pgcon-notices connection))) ;; split out from large-object.lisp (defmethod pglo-read ((connection pgcon-v2) fd bytes) (let ((octets (fn connection "loread" nil fd bytes))) (map '(vector (unsigned-byte 8)) #'char-code octets))) ;; EOF cl-pg-20061216.orig/v3-protocol.lisp0000644000175000017500000011135410560035327017236 0ustar pvaneyndpvaneynd;;; v3-protocol.lisp -- frontend/backend protocol from PostgreSQL v7.4 ;;; ;;; Author: Peter Van Eynde (declaim (optimize (speed 3) (safety 1))) (in-package :postgresql) (defclass pgcon-v3 (pgcon) ((parameters :accessor pgcon-parameters :initform (list)) (sql-stream :initform nil :accessor pgcon-sql-stream :type (or null stream)))) (define-condition error-response (backend-error) ((severity :initarg :severity :reader error-response-severity) (code :initarg :code :reader error-response-code) (message :initarg :message :reader error-response-message) (detail :initarg :detail :reader error-response-detail) (hint :initarg :hint :reader error-response-hint) (position :initarg :position :reader error-response-position) (where :initarg :where :reader error-response-where) (file :initarg :file :reader error-response-file) (line :initarg :line :reader error-response-line) (routine :initarg :routine :reader error-response-routine)) (:report (lambda (exc stream) (format stream "PostgreSQL ~A: (~A) ~A, ~A. Hint: ~A File: ~A, line ~A/~A ~A -> ~A" (ignore-errors (error-response-severity exc)) (ignore-errors (error-response-code exc)) (ignore-errors (error-response-message exc)) (ignore-errors (error-response-detail exc)) (ignore-errors (error-response-hint exc)) (ignore-errors (error-response-file exc)) (ignore-errors (error-response-line exc)) (ignore-errors (error-response-position exc)) (ignore-errors (error-response-routine exc)) (ignore-errors (error-response-where exc)))))) ;; packets send/received are always: ;; ;; - a byte indicating a character code ;; - 4 bytes -> an integer giving the length ;; of the packet ;; - data ;; ;; So we create specialized data structures for this (defclass pg-packet () ((type :initarg :type :type base-char :reader pg-packet-type) (length :initarg :length :type (unsigned-byte 32) :reader pg-packet-length) (data :initarg :data :type (array (unsigned-byte 8) *)) (position :initform 0 :type integer) (connection :initarg :connection :type pgcon-v3))) (defmethod print-object ((object pg-packet) stream) (print-unreadable-object (object stream :type t :identity t) (format stream "type: ~A length: ~A position: ~A" (and (slot-boundp object 'type) (slot-value object 'type)) (and (slot-boundp object 'length) (slot-value object 'length)) (and (slot-boundp object 'position) (slot-value object 'position))))) ;; the error and notice functions: ;; FIXME remove the duplication between this an HANDLE-NOTIFICATION/V3 at end of file (defun read-and-generate-error-response (connection packet) (let ((args nil)) (loop :for field-type = (read-from-packet packet :byte) :until (= field-type 0) :do (let ((message (read-from-packet packet :cstring))) (push message args) (push (ecase (code-char field-type) ((#\S) :severity) ((#\C) :code) ((#\M) :message) ((#\D) :detail) ((#\H) :hint) ((#\P) :position) ((#\W) :where) ((#\F) :file) ((#\L) :line) ((#\R) :routine)) args))) (send-packet connection #\S nil) ;; we are trying to recover from errors too: (apply #'cerror "Try to continue, should do a rollback" 'error-response (append (list :reason "Backend error") args)))) (defun read-and-handle-notification-response (connection packet) (declare (type pg-packet packet) (type pgcon-v3 connection)) (let* ((pid (read-from-packet packet :int32)) (condition-name (read-from-packet packet :cstring)) (additional-information (read-from-packet packet :cstring))) (setf (pgcon-pid connection) pid) (format *debug-io* "~&Got notification: ~S, ~S~%" condition-name additional-information) (push condition-name (pgcon-notices connection)))) ;; the main function (defun read-packet (connection) "Reads a packet from the connection. Returns the packet, handles errors and notices automagically, but will still return them" (let* ((stream (pgcon-stream connection)) (type (%read-net-int8 stream)) (length (%read-net-int32 stream))) ;; detect a bogus protocol response from the backend, which ;; probably means that we're in PG-CONNECT/V3 but talking to an ;; old backend that only understands the V2 protocol. Heuristics ;; for this detection are the same as in libpq, file fe-connect.c (when (eql (char-code #\E) type) (unless (< 8 length 30000) (close stream) (error 'protocol-error :reason "Probable old PostgreSQL backend"))) (let* ((data (%read-bytes stream (- length 4))) (packet (make-instance 'pg-packet :type (code-char type) :length length :data data :connection connection))) (case (pg-packet-type packet) ((#\E) ; error (read-and-generate-error-response connection packet) packet) ((#\N) ; Notice (handle-notice/v3 connection packet) packet) ((#\A) (read-and-handle-notification-response connection packet) packet) (t ;; return the packet packet))))) ;; Not to get at the data: (defgeneric read-from-packet (packet type) (:documentation "Reads an integer from the given PACKET with type TYPE") (:method ((packet pg-packet) (type (eql :char))) (with-slots (data position) packet (prog1 (elt data position) (incf position)))) (:method ((packet pg-packet) (type (eql :byte))) (with-slots (data position) packet (let ((result (elt data position))) (incf position) (when (= 1 (ldb (byte 1 7) result)) ;; negative (setf result (- (1+ (logxor result #xFF))))) result))) (:method ((packet pg-packet) (type (eql :int16))) (with-slots (data position) packet (let ((result (+ (* 256 (elt data position)) (elt data (1+ position))))) (incf position 2) (when (= 1 (ldb (byte 1 15) result)) ;; negative (setf result (- (1+ (logxor result #xFFFF))))) result))) (:method ((packet pg-packet) (type (eql :int32))) (with-slots (data position) packet (let ((result (+ (* 256 256 256 (elt data position)) (* 256 256 (elt data (1+ position))) (* 256 (elt data (+ 2 position))) (elt data (+ 3 position))))) (incf position 4) (when (= 1 (ldb (byte 1 31) result)) ;; negative (setf result (- (1+ (logxor result #xFFFFFFFF))))) result))) ;; a string that does not get encoded (:method ((packet pg-packet) (type (eql :ucstring))) (with-slots (data position) packet (let* ((end (position 0 data :start position)) (result (unless (eql end position) (make-array (- end position) :element-type 'character)))) (when result (loop :for i :from position :below end :for j :from 0 :do (setf (aref result j) (code-char (aref data i)))) (setf position (1+ end)) result)))) ;; a string that does get encoded, if the current connection has set ;; its prefered encoding (:method ((packet pg-packet) (type (eql :cstring))) (with-slots (data position connection) packet (cond ((pgcon-encoding connection) (let* ((end (position 0 data :start position)) (result (unless (eql end position) (convert-string-from-bytes (subseq data position end) (pgcon-encoding connection))))) (when result (setf position (1+ end))) result)) ;; the encoding has not yet been set, so revert to :ucstring behaviour (t (read-from-packet packet :ucstring)))))) ;; FIXME need to check all callers of this function to distinguish ;; between uses that expect charset encoding to be handled, and those ;; that really want READ-OCTET-ARRAY-FROM-PACKET (defgeneric read-string-from-packet (packet length) (:documentation "Reads a string of LENGTH characters from the packet") (:method ((packet pg-packet) (length (eql -1))) nil) (:method ((packet pg-packet) (length integer)) (when (< length 0) (error "length cannot be negative. is: ~S" length)) (with-slots (connection) packet (let* ((octets (read-octets-from-packet packet length)) (encoding (if (or (eql #\R (pg-packet-type packet)) (eql #\E (pg-packet-type packet))) "LATIN1" (pgcon-encoding connection))) (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 (replace result data :start2 position :end2 (+ position length)) (incf position length) result))) (defun send-packet (connection code description) "Sends a packet to the connection. CODE is the character code of the packet, description is a list of items with as first element one of :byte, :char :int16 :int32 or :cstring and as second element the value of the parameter" (declare (type base-char code)) (let* ((length (+ 4 (loop for (type value) in description sum (ecase type ((:byte :char) 1) ((:int16) 2) ((:int32) 4) ((:rawdata) (length value)) ((:string) (length (convert-string-to-bytes value (pgcon-encoding connection)))) ((:cstring) (1+ (length (convert-string-to-bytes value (pgcon-encoding connection))))) ((:ucstring) (1+ (length value))))))) (data (make-array (- length 4) :element-type '(unsigned-byte 8))) (stream (pgcon-stream connection))) (loop for (type value) in description with position = 0 do (ecase type ((:byte) (check-type value (signed-byte 8)) (setf (elt data position) value) (incf position)) ((:char) (check-type value base-char) (setf (elt data position) (char-code value)) (incf position)) ((:int16) (check-type value (signed-byte 16)) (setf (elt data position) (ldb (byte 8 8) value)) (setf (elt data (+ 1 position)) (ldb (byte 8 0) value)) (incf position 2)) ((:int32) (check-type value (signed-byte 32)) (setf (elt data position) (ldb (byte 8 24) value)) (setf (elt data (+ 1 position)) (ldb (byte 8 16) value)) (setf (elt data (+ 2 position)) (ldb (byte 8 8) value)) (setf (elt data (+ 3 position)) (ldb (byte 8 0) value)) (incf position 4)) ((:ucstring) (check-type value string) (loop for char across value do (setf (elt data position) (char-code char)) (incf position)) (setf (elt data position) 0) (incf position)) ((:cstring) (check-type value string) (let ((encoded (convert-string-to-bytes value (pgcon-encoding connection)))) (declare (type (vector (unsigned-byte 8) *) encoded)) (replace data encoded :start1 position) (incf position (length encoded))) (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 (pgcon-encoding connection)))) (declare (type (vector (unsigned-byte 8) *) encoded)) (replace data encoded :start1 position) (incf position (length encoded)))) ((:rawdata) (check-type value (array (unsigned-byte 8) *)) (replace data value :start1 position) (incf position (length value))))) (%send-net-int stream (char-code code) 1) (%send-net-int stream length 4) (write-sequence data stream))) (defun pg-connect/v3 (dbname user &key (host "localhost") (port 5432) (password "") (encoding *pg-client-encoding*)) "Initiate a connection with the PostgreSQL backend. Connect to the database DBNAME with the username USER, on PORT of HOST, providing PASSWORD if necessary. Return a connection to the database (as an opaque type). If HOST is a pathname or a string whose first character is #\/, it designates the directory containing the Unix socket on which the PostgreSQL backend is listening." (let* ((stream (socket-connect port host)) (connection (make-instance 'pgcon-v3 :stream stream :host host :port port :encoding encoding)) (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 (dolist (item connect-options) (%send-cstring stream item)) (%send-net-int stream 0 1) (%flush connection) (loop :for packet = (read-packet connection) :do (case (pg-packet-type packet) ((#\R) ;; Authentication Request: (let* ((code (read-from-packet packet :int32))) (case code ((0) ;; AuthOK ) ((1) ; AuthKerberos4 (error 'authentication-failure :reason "Kerberos4 authentication not supported")) ((2) ; AuthKerberos5 (error 'authentication-failure :reason "Kerberos5 authentication not supported")) ((3) ; AuthUnencryptedPassword (send-packet connection #\p `((:ucstring ,password))) (%flush connection)) ((4) ; AuthEncryptedPassword (let* ((salt (read-string-from-packet packet 2)) (crypted (crypt password salt))) #+debug (format *debug-io* "CryptAuth: Got salt of ~s~%" salt) (send-packet connection #\p `((:ucstring ,crypted))) (%flush connection))) ((5) ; AuthMD5Password #+debug (format *debug-io* "MD5Auth: got salt of ~s~%" salt) (force-output *debug-io*) (let* ((salt (read-string-from-packet packet 4)) (ciphered (md5-encode-password user password salt))) (send-packet connection #\p `((:ucstring ,ciphered))) (%flush connection))) ((6) ; AuthSCMPassword (error 'authentication-failure :reason "SCM authentication not supported")) (t (error 'authentication-failure :reason "unknown authentication type"))))) ((#\K) ;; Cancelation (let* ((pid (read-from-packet packet :int32)) (secret (read-from-packet packet :int32))) #+debug (format t "~&Got cancelation data") (setf (pgcon-pid connection) pid) (setf (pgcon-secret connection) secret))) ((#\S) ;; Status (let* ((parameter (read-from-packet packet :ucstring)) (value (read-from-packet packet :ucstring))) (push (cons parameter value) (pgcon-parameters connection)))) ((#\Z) ;; Ready for Query (let* ((status (read-from-packet packet :byte))) (unless (= status (char-code #\I)) (warn "~&Got status ~S but wanted I~%" (code-char status))) (when encoding (setf (pg-client-encoding connection) encoding)) (and (not *pg-disable-type-coercion*) (null *parsers*) (initialize-parsers connection)) (when *pg-date-style* (setf (pg-date-style connection) *pg-date-style*)) (return connection))) ((#\E) ;; an error, we should abort. (return nil)) ((#\N) ;; a notice, that has already been handled in READ-PACKET t) (t (error 'protocol-error :reason "expected an authentication response")))))) (defun do-followup-query (connection) "Does the followup of a query" (let ((tuples (list)) (attributes (list)) (result (make-pgresult :connection connection))) (loop :for packet = (read-packet connection) :with got-data-p = nil :with receive-data-p = nil :do (case (pg-packet-type packet) ((#\S) ;; ParameterStatus (let* ((parameter (read-from-packet packet :cstring)) (value (read-from-packet packet :cstring))) (push (cons parameter value) (pgcon-parameters connection))) (setf got-data-p t)) ((#\A) ;; NotificationResponse, that has already been handled in READ-PACKET (setf got-data-p t)) ((#\C) ;; CommandComplete (let ((status (read-from-packet packet :cstring))) (setf (pgresult-status result) status) (setf (pgresult-tuples result) (nreverse tuples)) (setf (pgresult-attributes result) attributes)) (setf got-data-p t)) ((#\G) ;; CopyInResponse (cond ((and (streamp (pgcon-sql-stream connection)) (input-stream-p (pgcon-sql-stream connection))) ;; we ignore the data stuff. (handler-case (progn (loop :with buffer = (make-array 4096 :element-type '(unsigned-byte 8) :adjustable t) :for length = (read-sequence buffer (pgcon-sql-stream connection)) :until (= length 0) :do ;; send data (unless (= length 4096) (setf buffer (adjust-array buffer (list length)))) (send-packet connection #\d `((:rawdata ,buffer)))) ;; CopyDone (send-packet connection #\c nil)) ((or error serious-condition) (condition) (warn "Got an error while writing sql data: ~S aborting transfer!" condition) ;; CopyFail (send-packet connection #\f '((:cstring "No input data provided"))))) (%flush connection)) (t (warn "We had to provide data, but my sql-stream isn't an input-stream. Aborting transfer") ;; CopyFail (send-packet connection #\f '((:cstring "No input data provided"))) (%flush connection)))) ((#\H) ;; CopyOutResponse (cond ((and (streamp (pgcon-sql-stream connection)) (output-stream-p (pgcon-sql-stream connection))) (setf receive-data-p t)) (t (setf receive-data-p nil) (warn "I should receive data but my sql-stream isn't an outputstream!~%Ignoring data")))) ((#\d) ;; CopyData (when receive-data-p ;; we break the nice packet abstraction here to ;; get some speed: (let ((length (- (pg-packet-length packet) 4))) (write-sequence (make-array length :element-type '(unsigned-byte 8) :displaced-to (slot-value packet 'data) :displaced-index-offset (slot-value packet 'position)) (pgcon-sql-stream connection))))) ((#\c) ;; CopyDone ;; we do nothing (the exec will return and the user can do something if he/she wants (setf receive-data-p nil) (setf got-data-p t) t) ((#\T) ;; RowDescription (metadata for subsequent tuples) ;; FIXME: implement multiple result groups (and attributes (error "Cannot handle multiple result group")) (setq attributes (read-attributes/v3 packet))) ((#\D) ;; AsciiRow (text data transfer) (setf got-data-p t) (setf (pgcon-binary-p connection) nil) (unless attributes (error 'protocol-error :reason "Tuple received before metadata")) (push (read-tuple/v3 packet attributes) tuples)) ((#\I) ;; EmptyQueryResponse (setf (pgresult-status result) "SELECT") (setf (pgresult-tuples result) nil) (setf (pgresult-attributes result) nil) (return-from do-followup-query result)) ((#\Z) ;; ReadyForQuery (let ((status (read-from-packet packet :byte))) (declare (ignore status)) (when got-data-p (return-from do-followup-query result)))) ((#\s) ;; PortalSuspend ;; an Execute statement has terminated before completing ;; the execution of a portal (due to reaching a nonzero ;; result-row count) (return-from do-followup-query result)) ((#\V) ;; FunctionCallResponse ;; not clear why we would get these here instead of in FN (let* ((length (read-from-packet packet :int32)) (response (unless (= length -1) (read-string-from-packet packet length)))) (setf (pgresult-status result) response)) (setf got-data-p t)) ;; BindComplete / ParseComplete / NoData ((#\2 #\1 #\3) (return-from do-followup-query result)) ((#\n) ;; NoData (setf got-data-p t)) ;; error messages will already have been handled in READ-PACKET ((#\E) (setq got-data-p t)) ;; notice messages will already have been handled in READ-PACKET ((#\N) t) (t (warn "In PG::D-F-Q got unexpected packet: ~S, resetting connection" packet) (send-packet connection #\S nil) ; sync (%flush connection)))))) (defmethod pg-exec ((connection pgcon-v3) &rest args) "Execute the SQL command given by the concatenation of ARGS 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))) (send-packet connection #\Q `((:cstring ,sql))) (%flush connection) (do-followup-query connection))) (defmethod pg-disconnect ((connection pgcon-v3) &key abort) (cond (abort (close (pgcon-stream connection) :abort t)) (t (send-packet connection #\X nil) (%flush connection) (close (pgcon-stream connection)))) (values)) ;; Attribute information is as follows (defun read-attributes/v3 (packet) (let ((attribute-count (read-from-packet packet :int16)) (attributes '())) (do ((i attribute-count (- i 1))) ((zerop i) (nreverse attributes)) (let* ((type-name (read-from-packet packet :cstring)) (table-id (read-from-packet packet :int32)) (column-id (read-from-packet packet :int16)) (type-id (read-from-packet packet :int32)) (type-len (read-from-packet packet :int16)) (type-mod (read-from-packet packet :int32)) (format-code (read-from-packet packet :int16))) (declare (ignore type-mod format-code table-id column-id)) (push (list type-name type-id type-len) attributes))))) (defun read-tuple/v3 (packet attributes) (let* ((num-attributes (length attributes)) (number (read-from-packet packet :int16)) (tuples '())) (unless (= num-attributes number) (error "Should ~S not be equal to ~S" num-attributes number)) (do ((i 0 (+ i 1)) (type-ids (mapcar #'second attributes) (cdr type-ids))) ((= i num-attributes) (nreverse tuples)) (let* ((length (read-from-packet packet :int32)) (raw (unless (= length -1) (read-string-from-packet packet length)))) (if raw (push (parse raw (car type-ids)) tuples) (push nil tuples)))))) ;; Execute one of the large-object functions (lo_open, lo_close etc). ;; Argument FN is either an integer, in which case it is the OID of an ;; element in the pg_proc table, and otherwise it is a string which we ;; look up in the alist *lo-functions* to find the corresponding OID. (defmethod fn ((connection pgcon-v3) fn binary-result &rest args) (or *lo-initialized* (lo-init connection)) (let ((fnid (cond ((integerp fn) fn) ((not (stringp fn)) (error "Expecting a string or an integer: ~s" fn)) ((assoc fn *lo-functions* :test #'string=) (cdr (assoc fn *lo-functions* :test #'string=))) (t (error "Unknown builtin function ~s" fn))))) (send-packet connection #\F `((:int32 ,fnid) (:int16 ,(length args)) ,@(let ((result nil)) (dolist (arg args) (etypecase arg (integer (push `(:int16 1) result)) ((vector (unsigned-byte 8)) (push `(:int16 1) result)) (string (push `(:int16 0) result)))) (nreverse result)) (:int16 ,(length args)) ,@(let ((result nil)) (dolist (arg args) (etypecase arg (integer (push '(:int32 4) result) (push `(:int32 ,arg) result)) ((vector (unsigned-byte 8)) (push `(:int32 ,(length arg)) result) (push `(:rawdata ,arg) result)) (string ;; FIXME this should be STRING-OCTET-LENGTH instead of LENGTH (push `(:int32 ,(1+ (length arg))) result) (push `(:cstring ,arg) result)))) (nreverse result)) (:int16 ,(if binary-result 1 0)))) (%flush connection) (loop :with result = nil :for packet = (read-packet connection) :do (case (pg-packet-type packet) ((#\V) ; FunctionCallResponse (let* ((length (read-from-packet packet :int32)) (data (unless (= length -1) (if binary-result (case length ((1) (read-from-packet packet :byte)) ((2) (read-from-packet packet :int16)) ((4) (read-from-packet packet :int32)) (t (read-octets-from-packet packet length))) (read-string-from-packet packet length))))) (if data (setf result data) (return-from fn nil)))) ((#\Z) (return-from fn result)) ((#\E) ;; an error, we should abort. (return nil)) ((#\N) ;; We ignore Notices t) (t (warn "Got unexpected packet: ~S, resetting connection" packet) (send-packet connection #\S nil) ; sync (%flush connection)))))) (defclass backend-notification () ((severity) (code) (message :initform nil) (detail :initform nil) (hint :initform nil) (position) (where) (file) (line) (routine))) (defmethod print-object ((self backend-notification) stream) (print-unreadable-object (self stream :type t) (with-slots (message detail) self (format stream "Message: ~A, ~A" message detail)))) (defun handle-notice/v3 (connection packet) (loop :with notification = (make-instance 'backend-notification) :for field-type = (read-from-packet packet :byte) :until (= field-type 0) :do (let ((message (read-from-packet packet :cstring)) (slot (ecase (code-char field-type) ((#\S) 'severity) ((#\C) 'code) ((#\M) 'message) ((#\D) 'detail) ((#\H) 'hint) ((#\P) 'position) ((#\W) 'where) ((#\F) 'file) ((#\L) 'line) ((#\R) 'routine)))) (setf (slot-value notification slot) message)) :finally (push notification (pgcon-notices connection))) packet) ;; == prepare/bind/execute functions =================================================== ;; ;; Note that pg-dot-lisp is using the prepared statement support in ;; the FE/BE protocol in synchronous mode; whereas most other ;; PostgreSQL client interfaces use it asynchronously. This makes it ;; possible to support precise error reporting; errors are signaled by ;; the statement that provoked them, rather than by some later ;; statement that happened to read the error messages. However, ;; precision comes at some cost in performance. (defmethod pg-supports-pbe ((connection pgcon-v3)) (declare (ignore connection)) t) (defmethod pg-prepare ((connection pgcon-v3) (statement-name string) (sql-statement string) &optional type-of-parameters) (let ((types (when type-of-parameters (loop :for type :in type-of-parameters :for oid = (or (lookup-type type) (error "type not found")) :collect `(:int32 ,oid))))) (cond (types (send-packet connection #\P `((:cstring ,statement-name) (:cstring ,sql-statement) (:int16 ,(length types)) ,@types))) (t (send-packet connection #\P `((:cstring ,statement-name) (:cstring ,sql-statement) (:int16 0))))) (send-packet connection #\H nil) ; Flush (%flush connection) (do-followup-query connection))) (defmethod pg-bind ((connection pgcon-v3) (portal string) (statement-name string) 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)) (when list-of-types-and-values (loop :for (type value) :in list-of-types-and-values :do (cond ((null value) (push '(:int32 -1) data)) (t (ecase type ((:int32) (push '(:int32 4) data) (push `(:int32 ,value) data)) ((:int16) (push '(:int32 2) data) (push `(:int16 ,value) data)) ((:byte) (push '(:int32 1) data) (push `(:int8 ,value) data)) ((: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) (let ((length (cond ((pg-client-encoding connection) (length (convert-string-to-bytes value (pg-client-encoding connection)))) (t (length value))))) (push `(:int32 ,length) data) (push `(:string ,value) data))))))) (setf data (nreverse data))) (cond (list-of-types-and-values (send-packet connection #\B `((:cstring ,portal) (:cstring ,statement-name) (:int16 ,(length formats)) ,@formats (:int16 ,(length formats)) ,@data (:int16 0)))) (t (send-packet connection #\B `((:cstring ,portal) (:cstring ,statement-name) (:int16 0) (:int16 0) (:int16 0))))) (send-packet connection #\H nil) ; Flush (%flush connection) (do-followup-query connection))) (defmethod pg-execute ((connection pgcon-v3) (portal string) &optional (maximum-number-of-rows 0)) ;; have it describe the result: (send-packet connection #\D `((:char #\P) (:cstring ,portal))) ;; execute the query: (send-packet connection #\E `((:cstring ,portal) (:int32 ,maximum-number-of-rows))) (send-packet connection #\S nil) (%flush connection) (do-followup-query connection)) (defun pg-close (connection name type) (declare (type pgcon connection) (type string name) (type base-char type)) (send-packet connection #\C `((:char ,type) (:cstring ,name))) ;; make it a sync point (send-packet connection #\S nil) (%flush connection) (loop :for packet = (read-packet connection) :do (case (pg-packet-type packet) ((#\3) t) ((#\Z) ;; CloseComplete or ReadyForQuery (return)) (t (warn "Got unexpected packet in PG-CLOSE: ~S, resetting connection" packet) (send-packet connection #\S nil) ; sync (%flush connection))))) (defmethod pg-close-statement ((connection pgcon-v3) (statement-name string)) (pg-close connection statement-name #\S)) (defmethod pg-close-portal ((connection pgcon-v3) (portal string)) (pg-close connection portal #\P)) ;; split out from large-object.lisp (defmethod pglo-read ((connection pgcon-v3) fd bytes) (fn connection "loread" t fd bytes)) ;; EOF