pax_global_header 0000666 0000000 0000000 00000000064 12600736344 0014517 g ustar 00root root 0000000 0000000 52 comment=4210920eadbe67b01238cbd8eb77c126eff56a3d
postmodern-20151031-git/ 0000775 0000000 0000000 00000000000 12600736344 0014730 5 ustar 00root root 0000000 0000000 postmodern-20151031-git/.gitignore 0000664 0000000 0000000 00000000007 12600736344 0016715 0 ustar 00root root 0000000 0000000 *.fasl
postmodern-20151031-git/LICENSE 0000664 0000000 0000000 00000001552 12600736344 0015740 0 ustar 00root root 0000000 0000000 Copyright (c) Marijn Haverbeke, marijnh@gmail.com
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any
damages arising from the use of this software.
Permission is granted to anyone to use this software for any
purpose, including commercial applications, and to alter it and
redistribute it freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must
not claim that you wrote the original software. If you use this
software in a product, an acknowledgment in the product
documentation would be appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must
not be misrepresented as being the original software.
3. This notice may not be removed or altered from any source
distribution.
postmodern-20151031-git/cl-postgres.asd 0000664 0000000 0000000 00000004261 12600736344 0017666 0 ustar 00root root 0000000 0000000 (defpackage :cl-postgres-system
(:use :common-lisp :asdf))
(in-package :cl-postgres-system)
;; Change this to enable/disable unicode manually (mind that it won't
;; work unless your implementation supports it).
(defparameter *unicode*
#+(or sb-unicode unicode ics openmcl-unicode-strings) t
#-(or sb-unicode unicode ics openmcl-unicode-strings) nil)
(defparameter *string-file* (if *unicode* "strings-utf-8" "strings-ascii"))
(defsystem :cl-postgres
:description "Low-level client library for PostgreSQL"
:depends-on (:md5
#-(or sbcl allegro ccl) :usocket
#+sbcl :sb-bsd-sockets)
:components
((:module :cl-postgres
:components ((:file "trivial-utf-8")
(:file "ieee-floats")
(:file "package")
(:file "errors" :depends-on ("package"))
(:file "sql-string" :depends-on ("package"))
(:file #.*string-file* :depends-on ("package" "trivial-utf-8"))
(:file "communicate" :depends-on (#.*string-file* "sql-string"))
(:file "messages" :depends-on ("communicate"))
(:file "interpret" :depends-on ("communicate" "ieee-floats"))
(:file "protocol" :depends-on ("interpret" "messages" "errors"))
(:file "public" :depends-on ("protocol"))
(:file "bulk-copy" :depends-on ("public"))))))
(defsystem :cl-postgres-tests
:depends-on (:cl-postgres :eos :simple-date)
:components
((:module :cl-postgres
:components ((:file "tests")))))
(defmethod perform ((op asdf:test-op) (system (eql (find-system :cl-postgres))))
(asdf:oos 'asdf:load-op :cl-postgres-tests)
(funcall (intern (string :prompt-connection) (string :cl-postgres-tests)))
(funcall (intern (string :run!) (string :Eos)) :cl-postgres))
(defmethod perform :after ((op asdf:load-op) (system (eql (find-system :cl-postgres))))
(when (and (find-package :simple-date)
(not (find-symbol (symbol-name '#:+postgres-day-offset+) :simple-date)))
(asdf:oos 'asdf:load-op :simple-date-postgres-glue)))
postmodern-20151031-git/cl-postgres/ 0000775 0000000 0000000 00000000000 12600736344 0017172 5 ustar 00root root 0000000 0000000 postmodern-20151031-git/cl-postgres/bulk-copy.lisp 0000664 0000000 0000000 00000011425 12600736344 0021773 0 ustar 00root root 0000000 0000000
(in-package :cl-postgres)
(defclass bulk-copier ()
((own-connection :initarg :own-connection :reader bulk-copier-own-connection)
(database :initarg :database :reader copier-database)
(table :initarg :table :reader copier-table)
(columns :initarg :columns :reader copier-columns)
(count :initform 0 :accessor copier-count)))
(defmethod print-object ((self bulk-copier) stream)
(print-unreadable-object (self stream :type t :identity t)
(format stream "~a ~a" (copier-table self)
(copier-columns self))))
(defun open-db-writer (db-spec table columns)
(let* ((own-connection (listp db-spec))
(copier (make-instance 'bulk-copier
:own-connection own-connection
:database (if own-connection (apply 'open-database db-spec) db-spec)
:table table
:columns columns)))
(initialize-copier copier)
copier))
(defun close-db-writer (self &key (abort nil))
(unwind-protect
(let* ((connection (copier-database self))
(socket (connection-socket connection)))
(with-reconnect-restart connection
(using-connection connection
(send-copy-done socket))))
(when (or abort (bulk-copier-own-connection self))
(close-database (copier-database self))))
(copier-count self))
(defun db-write-row (self row &optional (data (prepare-row self row)))
(let* ((connection (copier-database self))
(socket (connection-socket connection)))
(with-reconnect-restart connection
(using-connection connection
(with-syncing
(copy-data-message socket data)))))
(incf (copier-count self)))
(defun copy-query (self)
(format nil "~%copy ~a ~@[(~{~a~^,~})~] ~a ~a"
(copier-table self)
(copier-columns self)
"FROM"
"STDIN"))
(defun send-copy-start (socket query)
(with-syncing
(query-message socket query)
(flush-message socket)
(force-output socket)
(message-case socket
;; Ignore the field formats because we're only supporting plain
;; text for now
(#\G (read-uint1 socket)
(skip-bytes socket (* 2 (read-uint2 socket)))))))
(defun initialize-copier (self)
(let* ((query (copy-query self))
(connection (copier-database self))
(socket (connection-socket connection)))
(with-reconnect-restart connection
(using-connection connection
(send-copy-start socket query)))))
(defun copier-write-value (s val)
(typecase val
(string (let ((pg-string (with-output-to-string (str)
(loop for byte across (cl-postgres-trivial-utf-8:string-to-utf-8-bytes val) do
(case (code-char byte)
(#\Space (princ " " str))
((#\Newline #\Tab) (format str "\\~a" (code-char byte)))
(#\\ (progn (princ #\\ str) (princ #\\ str)))
(otherwise (if (and (< 32 byte)
(> 127 byte))
(write-char (code-char byte) str)
(princ (format nil "\\~o" byte) str))))))))
#+nil(print `(:loading ,pg-string))
(princ pg-string s)))
(number (princ val s))
(null (princ "false" s))
(symbol (case val
(:null (princ "\\N" s))
((t) (princ "true" s))
(otherwise (error "copier-write-val: Symbols shouldn't be getting this far ~a" val))))))
(defun copier-write-sequence (s vector)
(write-char #\{ s)
(loop for (item . more-p) on (coerce vector 'list)
do (cond
((null item) (copier-write-value s :null))
((atom item) (copier-write-value s item))
(t (copier-write-sequence s item)))
when more-p
do (write-char #\, s))
(write-char #\} s))
(defmethod prepare-row (self row)
(declare (ignore self))
(with-output-to-string (s)
(loop for (val . more-p) on row
do (progn
(if (typep val '(or string
(not vector)))
(copier-write-value s val)
(copier-write-sequence s val)))
if more-p do (write-char #\Tab s)
finally
(write-char #\Newline s))))
(defun send-copy-done (socket)
(with-syncing
(setf sync-sent t)
(copy-done-message socket)
(force-output socket)
(message-case socket
(#\C (let* ((command-tag (read-str socket))
(space (position #\Space command-tag :from-end t)))
(when space
(parse-integer command-tag :junk-allowed t :start (1+ space))))))
(block find-ready
(loop (message-case socket
(#\Z (read-uint1 socket)
(return-from find-ready))
(t :skip))))))
postmodern-20151031-git/cl-postgres/communicate.lisp 0000664 0000000 0000000 00000013614 12600736344 0022374 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
;; These are used to synthesize reader and writer names for integer
;; reading/writing functions when the amount of bytes and the
;; signedness is known. Both the macro that creates the functions and
;; some macros that use them create names this way.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun integer-reader-name (bytes signed)
(intern (with-standard-io-syntax
(format nil "~a~a~a~a" '#:read- (if signed "" '#:u) '#:int bytes))))
(defun integer-writer-name (bytes signed)
(intern (with-standard-io-syntax
(format nil "~a~a~a~a" '#:write- (if signed "" '#:u) '#:int bytes)))))
(defmacro integer-reader (bytes)
"Create a function to read integers from a binary stream."
(let ((bits (* bytes 8)))
(labels ((return-form (signed)
(if signed
`(if (logbitp ,(1- bits) result)
(dpb result (byte ,(1- bits) 0) -1)
result)
`result))
(generate-reader (signed)
`(defun ,(integer-reader-name bytes signed) (socket)
(declare (type stream socket)
#.*optimize*)
,(if (= bytes 1)
`(let ((result (the (unsigned-byte 8) (read-byte socket))))
(declare (type (unsigned-byte 8) result))
,(return-form signed))
`(let ((result 0))
(declare (type (unsigned-byte ,bits) result))
,@(loop :for byte :from (1- bytes) :downto 0
:collect `(setf (ldb (byte 8 ,(* 8 byte)) result)
(the (unsigned-byte 8) (read-byte socket))))
,(return-form signed))))))
`(progn
;; This causes weird errors on SBCL in some circumstances. Disabled for now.
;; (declaim (inline ,(integer-reader-name bytes t)
;; ,(integer-reader-name bytes nil)))
(declaim (ftype (function (t) (signed-byte ,bits))
,(integer-reader-name bytes t)))
,(generate-reader t)
(declaim (ftype (function (t) (unsigned-byte ,bits))
,(integer-reader-name bytes nil)))
,(generate-reader nil)))))
(defmacro integer-writer (bytes)
"Create a function to write integers to a binary stream."
(let ((bits (* 8 bytes)))
`(progn
(declaim (inline ,(integer-writer-name bytes t)
,(integer-writer-name bytes nil)))
(defun ,(integer-writer-name bytes nil) (socket value)
(declare (type stream socket)
(type (unsigned-byte ,bits) value)
#.*optimize*)
,@(if (= bytes 1)
`((write-byte value socket))
(loop :for byte :from (1- bytes) :downto 0
:collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
socket)))
(values))
(defun ,(integer-writer-name bytes t) (socket value)
(declare (type stream socket)
(type (signed-byte ,bits) value)
#.*optimize*)
,@(if (= bytes 1)
`((write-byte (ldb (byte 8 0) value) socket))
(loop :for byte :from (1- bytes) :downto 0
:collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
socket)))
(values)))))
;; All the instances of the above that we need.
(integer-reader 1)
(integer-reader 2)
(integer-reader 4)
(integer-reader 8)
(integer-writer 1)
(integer-writer 2)
(integer-writer 4)
(defun write-bytes (socket bytes)
"Write a byte-array to a stream."
(declare (type stream socket)
(type (simple-array (unsigned-byte 8)) bytes)
#.*optimize*)
(write-sequence bytes socket))
(defun write-str (socket string)
"Write a null-terminated string to a stream \(encoding it when UTF-8
support is enabled.)."
(declare (type stream socket)
(type string string)
#.*optimize*)
(enc-write-string string socket)
(write-uint1 socket 0))
(declaim (ftype (function (t unsigned-byte)
(simple-array (unsigned-byte 8) (*)))
read-bytes))
(defun read-bytes (socket length)
"Read a byte array of the given length from a stream."
(declare (type stream socket)
(type fixnum length)
#.*optimize*)
(let ((result (make-array length :element-type '(unsigned-byte 8))))
(read-sequence result socket)
result))
(declaim (ftype (function (t) string) read-str))
(defun read-str (socket)
"Read a null-terminated string from a stream. Takes care of encoding
when UTF-8 support is enabled."
(declare (type stream socket)
#.*optimize*)
(enc-read-string socket :null-terminated t))
(declaim (ftype (function (t) string) read-simple-str))
(defun read-simple-str (socket)
"Read a null-terminated string from a stream. Interprets it as ASCII."
(declare (type stream socket)
#.*optimize*)
(with-output-to-string (out)
(loop :for b := (read-byte socket nil 0) :do
(cond ((eq b 0) (return))
((< b 128) (write-char (code-char b) out))))))
(defun skip-bytes (socket length)
"Skip a given number of bytes in a binary stream."
(declare (type stream socket)
(type (unsigned-byte 32) length)
#.*optimize*)
(dotimes (i length)
(read-byte socket)))
(defun skip-str (socket)
"Skip a null-terminated string."
(declare (type stream socket)
#.*optimize*)
(loop :for char :of-type fixnum = (read-byte socket)
:until (zerop char)))
(defun ensure-socket-is-closed (socket &key abort)
(when (open-stream-p socket)
(handler-case
(close socket :abort abort)
(error (error)
(warn "Ignoring the error which happened while trying to close PostgreSQL socket: ~A" error)))))
postmodern-20151031-git/cl-postgres/errors.lisp 0000664 0000000 0000000 00000016246 12600736344 0021410 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
(defparameter *current-query* nil)
(defparameter *query-log* nil)
(defparameter *query-callback* 'log-query)
(defun log-query (query time-units)
(when *query-log*
(format *query-log* "CL-POSTGRES query (~ams): ~a~%"
(round (/ (* 1000 time-units)
internal-time-units-per-second))
query)))
(defmacro with-query ((query) &body body)
(let ((time-name (gensym)))
`(let ((*current-query* ,query)
(,time-name (if *query-callback* (get-internal-real-time) 0)))
(multiple-value-prog1 (progn ,@body)
(when *query-callback*
(funcall *query-callback*
*current-query*
(- (get-internal-real-time) ,time-name)))))))
;;
;; See http://www.postgresql.org/docs/9.3/static/protocol-error-fields.html
;; for details, including documentation strings.
;;
(define-condition database-error (error)
((error-code :initarg :code :initform nil :reader database-error-code
:documentation "Code: the SQLSTATE code for the error (see Appendix A). Not localizable. Always present.")
(message :initarg :message :accessor database-error-message
:documentation "Message: the primary human-readable error message. This should be accurate but terse (typically one line). Always present.")
(detail :initarg :detail :initform nil :reader database-error-detail
:documentation "Detail: an optional secondary error message carrying more detail about the problem. Might run to multiple lines.")
(hint :initarg :hint :initform nil :reader database-error-hint
:documentation "Hint: an optional suggestion what to do about the problem.")
(context :initarg :context :initform nil :reader database-error-context
:documentation "Where: an indication of the context in which the error occurred. Presently this includes a call stack traceback of active procedural language functions and internally-generated queries. The trace is one entry per line, most recent first."
)
(query :initform *current-query* :reader database-error-query
:documentation "Query that led to the error, if any.")
(position :initarg :position :initform nil :reader database-error-position
:documentation "Position: the field value is a decimal ASCII integer, indicating an error cursor position as an index into the original query string. The first character has index 1, and positions are measured in characters not bytes.")
(cause :initarg :cause :initform nil :reader database-error-cause))
(:report (lambda (err stream)
(format stream "Database error~@[ ~A~]: ~A~@[~&DETAIL: ~A~]~@[~&HINT: ~A~]~@[~&CONTEXT: ~A~]~@[~&QUERY: ~A~]~@[~VT^~]"
(database-error-code err)
(database-error-message err)
(database-error-detail err)
(database-error-hint err)
(database-error-context err)
(database-error-query err)
(database-error-position err))))
(:documentation "This is the condition type that will be used to
signal virtually all database-related errors \(though in some cases
socket errors may be raised when a connection fails on the IP
level)."))
(defun database-error-constraint-name (err)
"Given a database-error for an integrity violation, will attempt to
extract the constraint name."
(labels ((extract-quoted-part (string n)
"Extracts the Nth quoted substring from STRING."
(let* ((start-quote-inst (* 2 n))
(start-quote-pos (position-nth #\" string start-quote-inst))
(end-quote-pos (position #\" string :start (1+ start-quote-pos))))
(subseq string (1+ start-quote-pos) end-quote-pos)))
(position-nth (item seq n)
"Finds the position of the zero-indexed Nth ITEM in SEQ."
(loop :with pos = -1 :repeat (1+ n)
:do (setf pos (position item seq :start (1+ pos)))
:finally (return pos))))
(let ((message (database-error-message err)))
(typecase err
(cl-postgres-error:not-null-violation (extract-quoted-part message 0))
(cl-postgres-error:unique-violation (extract-quoted-part message 0))
(cl-postgres-error:foreign-key-violation (extract-quoted-part message 1))
(cl-postgres-error:check-violation (extract-quoted-part message 1))))))
(define-condition database-connection-error (database-error) ()
(:documentation "Conditions of this type are signalled when an error
occurs that breaks the connection socket. They offer a :reconnect
restart."))
(define-condition database-connection-lost (database-connection-error) ()
(:documentation "Raised when a query is initiated on a disconnected
connection object."))
(define-condition database-socket-error (database-connection-error) ()
(:documentation "Used to wrap stream-errors and socket-errors,
giving them a database-connection-error superclass."))
(defun wrap-socket-error (err)
(make-instance 'database-socket-error
:message (princ-to-string err)
:cause err))
(in-package :cl-postgres-error)
(defparameter *error-table* (make-hash-table :test 'equal))
(defmacro deferror (code typename &optional (superclass 'database-error))
`(progn (define-condition ,typename (,superclass) ())
(setf (gethash ,code *error-table*) ',typename)))
(deferror "0A" feature-not-supported)
(deferror "22" data-exception)
(deferror "22012" db-division-by-zero data-exception)
(deferror "22007" invalid-datetime-format data-exception)
(deferror "22003" numeric-value-out-of-range data-exception)
(deferror "22P01" floating-point-exception data-exception)
(deferror "23" integrity-violation)
(deferror "23001" restrict-violation integrity-violation)
(deferror "23502" not-null-violation integrity-violation)
(deferror "23503" foreign-key-violation integrity-violation)
(deferror "23505" unique-violation integrity-violation)
(deferror "23514" check-violation integrity-violation)
(deferror "42" syntax-error-or-access-violation)
(deferror "42501" insufficient-privilege syntax-error-or-access-violation)
(deferror "40" transaction-rollback)
(deferror "40001" serialization-failure transaction-rollback)
(deferror "40002" transaction-integrity-constraint-violation transaction-rollback)
(deferror "40003" statement-completion-unknown transaction-rollback)
(deferror "40P01" deadlock-detected transaction-rollback)
(deferror "53" insufficient-resources)
(deferror "54" program-limit-exceeded)
(deferror "55" object-state-error)
(deferror "55006" object-in-use object-state-error)
(deferror "55P03" lock-not-available object-state-error)
(deferror "57" operator-intervention)
(deferror "57014" query-canceled operator-intervention)
(define-condition server-shutdown (operator-intervention database-connection-error) ())
(deferror "57P01" admin-shutdown server-shutdown)
(deferror "57P02" crash-shutdown server-shutdown)
(deferror "57P03" cannot-connect-now operator-intervention)
(deferror "58" system-error)
(deferror "XX" internal-error)
(defun get-error-type (code)
(or (gethash code *error-table*)
(and code (gethash (subseq code 0 2) *error-table*))
'database-error))
postmodern-20151031-git/cl-postgres/ieee-floats.lisp 0000664 0000000 0000000 00000014230 12600736344 0022260 0 ustar 00root root 0000000 0000000 ;;; Functions for converting floating point numbers represented in
;;; IEEE 754 style to lisp numbers.
;;;
;;; See http://common-lisp.net/project/ieee-floats/
(defpackage :cl-postgres-ieee-floats
(:use :common-lisp)
(:export :make-float-converters
:encode-float32
:decode-float32
:encode-float64
:decode-float64))
(in-package :cl-postgres-ieee-floats)
;; The following macro may look a bit overcomplicated to the casual
;; reader. The main culprit is the fact that NaN and infinity can be
;; optionally included, which adds a bunch of conditional parts.
;;
;; Assuming you already know more or less how floating point numbers
;; are typically represented, I'll try to elaborate a bit on the more
;; confusing parts, as marked by letters:
;;
;; (A) Exponents in IEEE floats are offset by half their range, for
;; example with 8 exponent bits a number with exponent 2 has 129
;; stored in its exponent field.
;;
;; (B) The maximum possible exponent is reserved for special cases
;; (NaN, infinity).
;;
;; (C) If the exponent fits in the exponent-bits, we have to adjust
;; the significand for the hidden bit. Because decode-float will
;; return a significand between 0 and 1, and we want one between 1
;; and 2 to be able to hide the hidden bit, we double it and then
;; subtract one (the hidden bit) before converting it to integer
;; representation (to adjust for this, 1 is subtracted from the
;; exponent earlier). When the exponent is too small, we set it to
;; zero (meaning no hidden bit, exponent of 1), and adjust the
;; significand downward to compensate for this.
;;
;; (D) Here the hidden bit is added. When the exponent is 0, there is
;; no hidden bit, and the exponent is interpreted as 1.
;;
;; (E) Here the exponent offset is subtracted, but also an extra
;; factor to account for the fact that the bits stored in the
;; significand are supposed to come after the 'decimal dot'.
(defmacro make-float-converters (encoder-name
decoder-name
exponent-bits
significand-bits
support-nan-and-infinity-p)
"Writes an encoder and decoder function for floating point
numbers with the given amount of exponent and significand
bits (plus an extra sign bit). If support-nan-and-infinity-p is
true, the decoders will also understand these special cases. NaN
is represented as :not-a-number, and the infinities as
:positive-infinity and :negative-infinity. Note that this means
that the in- or output of these functions is not just floating
point numbers anymore, but also keywords."
(let* ((total-bits (+ 1 exponent-bits significand-bits))
(exponent-offset (1- (expt 2 (1- exponent-bits)))) ; (A)
(sign-part `(ldb (byte 1 ,(1- total-bits)) bits))
(exponent-part `(ldb (byte ,exponent-bits ,significand-bits) bits))
(significand-part `(ldb (byte ,significand-bits 0) bits))
(nan support-nan-and-infinity-p)
(max-exponent (1- (expt 2 exponent-bits)))) ; (B)
`(progn
(defun ,encoder-name (float)
,@(unless nan `((declare (type float float))))
(multiple-value-bind (sign significand exponent)
(cond ,@(when nan `(((eq float :not-a-number)
(values 0 1 ,max-exponent))
((eq float :positive-infinity)
(values 0 0 ,max-exponent))
((eq float :negative-infinity)
(values 1 0 ,max-exponent))))
((zerop float)
(values 0 0 0))
(t
(multiple-value-bind (significand exponent sign) (decode-float float)
(let ((exponent (+ (1- exponent) ,exponent-offset))
(sign (if (= sign 1.0) 0 1)))
(unless (< exponent ,(expt 2 exponent-bits))
(error "Floating point overflow when encoding ~A." float))
(if (< exponent 0) ; (C)
(values sign (ash (round (* ,(expt 2 significand-bits) significand)) exponent) 0)
(values sign (round (* ,(expt 2 significand-bits) (1- (* significand 2)))) exponent))))))
(let ((bits 0))
(declare (type (unsigned-byte ,total-bits) bits))
(setf ,sign-part sign
,exponent-part exponent
,significand-part significand)
bits)))
(defun ,decoder-name (bits)
(declare (type (unsigned-byte ,total-bits) bits))
(let* ((sign ,sign-part)
(exponent ,exponent-part)
(significand ,significand-part))
,@(when nan `((when (= exponent ,max-exponent)
(return-from ,decoder-name
(cond ((not (zerop significand)) :not-a-number)
((zerop sign) :positive-infinity)
(t :negative-infinity))))))
(if (zerop exponent) ; (D)
(setf exponent 1)
(setf (ldb (byte 1 ,significand-bits) significand) 1))
(unless (zerop sign)
(setf significand (- significand)))
(scale-float (float significand ,(if (> total-bits 32) 1.0d0 1.0))
(- exponent ,(+ exponent-offset significand-bits)))))))) ; (E)
;; And instances of the above for the common forms of floats.
(make-float-converters encode-float32 decode-float32 8 23 nil)
(make-float-converters encode-float64 decode-float64 11 52 nil)
;;; Copyright (c) 2006 Marijn Haverbeke
;;;
;;; This software is provided 'as-is', without any express or implied
;;; warranty. In no event will the authors be held liable for any
;;; damages arising from the use of this software.
;;;
;;; Permission is granted to anyone to use this software for any
;;; purpose, including commercial applications, and to alter it and
;;; redistribute it freely, subject to the following restrictions:
;;;
;;; 1. The origin of this software must not be misrepresented; you must
;;; not claim that you wrote the original software. If you use this
;;; software in a product, an acknowledgment in the product
;;; documentation would be appreciated but is not required.
;;;
;;; 2. Altered source versions must be plainly marked as such, and must
;;; not be misrepresented as being the original software.
;;;
;;; 3. This notice may not be removed or altered from any source
;;; distribution.
postmodern-20151031-git/cl-postgres/interpret.lisp 0000664 0000000 0000000 00000024332 12600736344 0022103 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
(defparameter *timestamp-format* :unbound
"This is used to communicate the format \(integer or float) used for
timestamps and intervals in the current connection, so that the
interpreters for those types know how to parse them.")
(defparameter *sql-readtable* (make-hash-table)
"The exported special var holding the current read table, a hash
mapping OIDs to (binary-p . interpreter-function) pairs.")
(defun interpret-as-text (stream size)
"This interpreter is used for types that we have no specific
interpreter for -- it just reads the value as a string. \(Values of
unknown types are passed in text form.)"
(enc-read-string stream :byte-length size))
(let ((default-interpreter (cons nil #'interpret-as-text)))
(defun type-interpreter (oid)
"Returns a pair representing the interpretation rules for this
type. The car is a boolean indicating whether the type should be
fetched as binary, and the cdr is a function that will read the value
from the socket and build a Lisp value from it."
(gethash oid *sql-readtable* default-interpreter)))
(defun set-sql-reader (oid function &key (table *sql-readtable*) binary-p)
"Add an sql reader to a readtable. When the reader is not binary, it
is wrapped by a function that will read the string from the socket."
(setf (gethash oid table)
(if binary-p
(cons t function)
(cons nil (lambda (stream size)
(funcall function
(enc-read-string stream :byte-length size))))))
table)
(defmacro binary-reader (fields &body value)
"A slightly convoluted macro for defining interpreter functions. It
allows two forms. The first is to pass a single type identifier, in
which case a value of this type will be read and returned directly.
The second is to pass a list of lists containing names and types, and
then a body. In this case the names will be bound to values read from
the socket and interpreted as the given types, and then the body will
be run in the resulting environment. If the last field is of type
bytes, string, or uint2s, all remaining data will be read and
interpreted as an array of the given type."
(let ((stream-name (gensym))
(size-name (gensym))
(length-used 0))
(flet ((read-type (type &optional modifier)
(ecase type
(bytes `(read-bytes ,stream-name (- ,size-name ,length-used)))
(string `(enc-read-string ,stream-name :byte-length (- ,size-name ,length-used)))
(uint2s `(let* ((size (/ (- ,size-name ,length-used) 2))
(result (make-array size :element-type '(unsigned-byte 16))))
(dotimes (i size)
(setf (elt result i) (read-uint2 ,stream-name)))
result))
(int (assert (integerp modifier))
(incf length-used modifier)
`(,(integer-reader-name modifier t) ,stream-name))
(uint (assert (integerp modifier))
(incf length-used modifier)
`(,(integer-reader-name modifier nil) ,stream-name)))))
`(lambda (,stream-name ,size-name)
(declare (type stream ,stream-name)
(type integer ,size-name)
(ignorable ,size-name))
,(if (consp fields)
`(let ,(loop :for field :in fields
:collect `(,(first field) ,(apply #'read-type (cdr field))))
,@value)
(read-type fields (car value)))))))
(defmacro define-interpreter (oid name fields &body value)
"Shorthand for defining binary readers."
(declare (ignore name)) ;; Names are there just for clarity
`(set-sql-reader ,oid (binary-reader ,fields ,@value) :binary-p t))
(define-interpreter 18 "char" int 1)
(define-interpreter 21 "int2" int 2)
(define-interpreter 23 "int4" int 4)
(define-interpreter 20 "int8" int 8)
(define-interpreter 26 "oid" uint 4)
(define-interpreter 16 "bool" ((value int 1))
(if (zerop value) nil t))
(define-interpreter 17 "bytea" bytes)
(define-interpreter 25 "text" string)
(define-interpreter 1042 "bpchar" string)
(define-interpreter 1043 "varchar" string)
(define-interpreter 700 "float4" ((bits uint 4))
(cl-postgres-ieee-floats:decode-float32 bits))
(define-interpreter 701 "float8" ((bits uint 8))
(cl-postgres-ieee-floats:decode-float64 bits))
;; Numeric types are rather involved. I got some clues on their
;; structure from http://archives.postgresql.org/pgsql-interfaces/2004-08/msg00000.php
(define-interpreter 1700 "numeric"
((length uint 2)
(weight int 2)
(sign int 2)
(dscale int 2)
(digits uint2s))
(declare (ignore dscale))
(let ((total (loop :for i :from (1- length) :downto 0
:for scale = 1 :then (* scale #.(expt 10 4))
:summing (* scale (elt digits i))))
(scale (- length weight 1)))
(unless (zerop sign)
(setf total (- total)))
(/ total (expt 10000 scale))))
;; Since date and time types are the most likely to require custom
;; readers, there is a hook for easily adding binary readers for them.
(defun set-date-reader (f table)
(set-sql-reader 1082 (binary-reader ((days int 4))
(funcall f days))
:table table
:binary-p t))
(defun interpret-usec-bits (bits)
"Decode a 64 bit time-related value based on the timestamp format
used. Correct for sign bit when using integer format."
(ecase *timestamp-format*
(:float (round (* (cl-postgres-ieee-floats:decode-float64 bits) 1000000)))
(:integer (if (logbitp 63 bits)
(dpb bits (byte 63 0) -1)
bits))))
(defun set-interval-reader (f table)
(set-sql-reader 1186 (binary-reader ((usec-bits uint 8) (days int 4) (months int 4))
(funcall f months days (interpret-usec-bits usec-bits)))
:table table
:binary-p t))
(defun set-usec-reader (oid f table)
(set-sql-reader oid (binary-reader ((usec-bits uint 8))
(funcall f (interpret-usec-bits usec-bits)))
:table table
:binary-p t))
;; Public interface for adding date/time readers
(defun set-sql-datetime-readers (&key date timestamp timestamp-with-timezone interval time
(table *sql-readtable*))
(when date (set-date-reader date table))
(when timestamp (set-usec-reader 1114 timestamp table))
(when timestamp-with-timezone (set-usec-reader 1184 timestamp-with-timezone table))
(when interval (set-interval-reader interval table))
(when time (set-usec-reader 1083 time table))
table)
;; Provide meaningful defaults for the date/time readers.
(defconstant +start-of-2000+ (encode-universal-time 0 0 0 1 1 2000 0))
(defconstant +seconds-in-day+ (* 60 60 24))
(set-sql-datetime-readers
:date (lambda (days-since-2000)
(+ +start-of-2000+ (* days-since-2000 +seconds-in-day+)))
:timestamp (lambda (useconds-since-2000)
(+ +start-of-2000+ (floor useconds-since-2000 1000000)))
:interval (lambda (months days useconds)
(multiple-value-bind (sec us) (floor useconds 1000000)
`((:months ,months) (:days ,days) (:seconds ,sec) (:useconds ,us)))))
;; Readers for a few of the array types
(defun read-array-value (transform)
(declare #.*optimize*)
(lambda (value)
(declare (type string value))
(let ((pos 0))
(declare (type fixnum pos))
(labels ((readelt ()
(case (char value pos)
(#\" (interpret
(with-output-to-string (out)
(loop :with escaped := nil :for ch := (char value (incf pos)) :do
(when (and (char= ch #\") (not escaped)) (return))
(setf escaped (and (not escaped) (char= ch #\\)))
(unless escaped (write-char ch out)))
(incf pos))))
(#\{ (incf pos)
(unless (char= (char value pos) #\})
(loop :for val := (readelt) :collect val :into vals :do
(let ((next (char value pos)))
(incf pos)
(ecase next (#\,) (#\} (return vals)))))))
(t (let ((start pos))
(loop :for ch := (char value pos) :do
(when (or (char= ch #\,) (char= ch #\}))
(return (interpret (subseq value start pos))))
(incf pos))))))
(interpret (word)
(if (string= word "NULL") :null (funcall transform word))))
(let* ((arr (readelt))
(dim (if arr (loop :for x := arr :then (car x) :while (consp x) :collect (length x)) '(0))))
(make-array dim :initial-contents arr))))))
;; Integral array types
(let ((read-integral (read-array-value #'parse-integer)))
(dolist (oid '(1561 1005 1007 1016 1028))
(set-sql-reader oid read-integral)))
;; String array types
(let ((read-strings (read-array-value #'identity)))
(dolist (oid '(1014 1002 1009 1015))
(set-sql-reader oid read-strings)))
;; Floating point arrays
(set-sql-reader 1231 (read-array-value 'read-from-string))
(set-sql-reader 1021 (read-array-value (lambda (x) (float (read-from-string x)))))
;; Bit of a hack, really. CL needs a proper float parser.
(flet ((read-as-double (str)
(loop :for ch :across str :for i :from 0 :do
(when (char= ch #\e) (setf (char str i) #\d)))
(coerce (read-from-string str) 'double-float)))
(set-sql-reader 1022 (read-array-value #'read-as-double)))
;; Boolean arrays
(flet ((read-as-bool (str) (equal str "t")))
(set-sql-reader 1000 (read-array-value #'read-as-bool)))
;; Working with tables.
(defun copy-sql-readtable (&optional (table *sql-readtable*))
(let ((new-table (make-hash-table)))
(maphash (lambda (oid interpreter) (setf (gethash oid new-table) interpreter))
table)
new-table))
(defparameter *default-sql-readtable* (copy-sql-readtable *sql-readtable*)
"A copy of the default readtable that client code can fall back
on.")
(defun default-sql-readtable ()
*default-sql-readtable*)
postmodern-20151031-git/cl-postgres/messages.lisp 0000664 0000000 0000000 00000022465 12600736344 0021703 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
;; For more information about the PostgreSQL scocket protocol, see
;; http://www.postgresql.org/docs/current/interactive/protocol.html
(defmacro define-message (name id (&rest arglist) &body parts)
"This macro synthesizes a function to send messages of a specific
type. It takes care of the plumbing -- calling writer functions on a
stream, keeping track of the length of the message -- so that the
message definitions themselves stay readable."
(let ((writers nil)
(socket (gensym))
(strings ())
(base-length 4)
(extra-length ()))
(setf writers
(mapcar (lambda (part)
(let ((name (gensym)))
(ecase (first part)
(uint
(incf base-length (second part))
`(,(integer-writer-name (second part) nil) ,socket ,(third part)))
(string
(push `(,name ,(second part)) strings)
(incf base-length 1) ;; The null terminator
(push `(enc-byte-length ,name) extra-length)
`(write-str ,socket ,name))
(bytes
(push `(,name ,(second part)) strings)
(push `(length ,name) extra-length)
`(write-bytes ,socket ,name)))))
parts))
(push `(write-uint4 ,socket (+ ,base-length ,@extra-length))
writers)
(when id
(push `(write-uint1 ,socket ,(char-code id)) writers))
`(defun ,name ,(cons socket arglist)
(declare (type stream ,socket)
#.*optimize*)
(let ,strings ,@writers))))
;; Try to enable SSL for a connection.
(define-message ssl-request-message nil ()
(uint 4 80877103))
;; Sends the initial message and sets a few parameters.
(define-message startup-message nil (user database)
(uint 4 196608) ;; Identifies protocol 3.0
(string "user")
(string user)
(string "database")
(string database)
(string "client_encoding")
(string *client-encoding*)
(uint 1 0)) ;; Terminates the parameter list
;; Identify a user with a plain-text password.
(define-message plain-password-message #\p (password)
(string password))
(defun bytes-to-hex-string (bytes)
"Convert an array of 0-255 numbers into the corresponding string of
\(lowercase) hex codes."
(declare (type (vector (unsigned-byte 8)) bytes)
#.*optimize*)
(let ((digits #.(coerce "0123456789abcdef" 'simple-base-string))
(result (make-string (* (length bytes) 2) :element-type 'base-char)))
(loop :for byte :across bytes
:for pos :from 0 :by 2
:do (setf (char result pos) (aref digits (ldb (byte 4 4) byte))
(char result (1+ pos)) (aref digits (ldb (byte 4 0) byte))))
result))
(defun md5-password (password user salt)
"Apply the hashing that PostgreSQL expects to a password."
(declare (type string user password)
(type (vector (unsigned-byte 8)) salt)
#.*optimize*)
(flet ((md5-and-hex (sequence)
(bytes-to-hex-string (md5:md5sum-sequence sequence))))
(let* ((pass1 (md5-and-hex (enc-string-bytes (concatenate 'string password user))))
(pass2 (md5-and-hex (concatenate '(vector (unsigned-byte 8) *) (enc-string-bytes pass1) salt))))
(concatenate 'string "md5" pass2))))
;; Identify a user with an MD5-hashed password.
(define-message md5-password-message #\p (password user salt)
(string (md5-password password user salt)))
(define-message gss-auth-buffer-message #\p (buf)
(bytes buf))
;; Send a query, the simple way.
(define-message query-message #\Q (query)
(string query))
;; Parse a query
(define-message simple-parse-message #\P (query)
(uint 1 0) ;; Name of the prepared statement
(string query)
(uint 2 0)) ;; Parameter types
;; Parse a query, giving it a name.
(define-message parse-message #\P (name query)
(string name)
(string query)
(uint 2 0))
;; Close a named parsed query, freeing the name.
(define-message close-prepared-message #\C (name)
(uint 1 #.(char-code #\S)) ;; Prepared statement
(string name))
(defun formats-to-bytes (formats)
"Formats have to be passed as arrays of 2-byte integers, with 1
indicating binary and 0 indicating plain text."
(declare (type vector formats)
#.*optimize*)
(let* ((result (make-array (* 2 (length formats))
:element-type '(unsigned-byte 8)
:initial-element 0)))
(loop :for format :across formats
:for pos :from 1 :by 2
:do (when format (setf (elt result pos) 1)))
result))
;; Bind the unnamed prepared query, asking for the given result
;; formats.
(define-message simple-bind-message #\B (formats)
(uint 1 0) ;; Name of the portal
(uint 1 0) ;; Name of the prepared statement
(uint 2 0) ;; Number of parameter format specs
(uint 2 0) ;; Number of parameter specifications
(uint 2 (length formats)) ;; Number of result format specifications
(bytes (formats-to-bytes formats))) ;; Result format
;; This one was a bit too complex to put into define-message format,
;; so it does everything by hand.
(defun bind-message (socket name result-formats parameters)
"Bind a prepared statement, ask for the given formats, and pass the
given parameters, that can be either string or byte vector.
\(vector \(unsigned-byte 8)) parameters will be sent as binary data, useful
for binding data for binary long object columns."
(declare (type stream socket)
(type string name)
(type vector result-formats)
(type list parameters)
#.*optimize*)
(let* ((n-params (length parameters))
(param-formats (make-array n-params :element-type 'fixnum))
(param-sizes (make-array n-params :element-type 'fixnum))
(param-values (make-array n-params))
(n-result-formats (length result-formats)))
(declare (type (unsigned-byte 16) n-params n-result-formats))
(loop :for param :in parameters
:for i :from 0
:do (flet ((set-param (format size value)
(setf (aref param-formats i) format
(aref param-sizes i) size
(aref param-values i) value)))
(declare (inline set-param))
(cond ((eq param :null)
(set-param 0 0 nil))
((typep param '(vector (unsigned-byte 8)))
(set-param 1 (length param) param))
(t
(unless (typep param 'string)
(setf param (serialize-for-postgres param)))
(etypecase param
(string
(set-param 0 (enc-byte-length param) param))
((vector (unsigned-byte 8))
(set-param 1 (length param) param)))))))
(write-uint1 socket #.(char-code #\B))
(write-uint4 socket (+ 12
(enc-byte-length name)
(* 6 n-params) ;; Input formats and sizes
(* 2 n-result-formats)
(loop :for size :of-type fixnum :across param-sizes
:sum size)))
(write-uint1 socket 0) ;; Name of the portal
(write-str socket name) ;; Name of the prepared statement
(write-uint2 socket n-params) ;; Number of parameter format specs
(loop :for format :across param-formats ;; Param formats (text/binary)
:do (write-uint2 socket format))
(write-uint2 socket n-params) ;; Number of parameter specifications
(loop :for param :across param-values
:for size :across param-sizes
:do (write-int4 socket (if param size -1))
:do (when param
(if (typep param '(vector (unsigned-byte 8)))
(write-sequence param socket)
(enc-write-string param socket))))
(write-uint2 socket n-result-formats) ;; Number of result formats
(loop :for format :across result-formats ;; Result formats (text/binary)
:do (write-uint2 socket (if format 1 0)))))
;; Describe the anonymous portal, so we can find out what kind of
;; result types will be passed.
(define-message simple-describe-message #\D ()
(uint 1 #.(char-code #\S)) ;; This is a statement describe
(uint 1 0)) ;; Name of the portal
;; Describe a named portal.
(define-message describe-prepared-message #\D (name)
(uint 1 #.(char-code #\S)) ;; This is a statement describe
(string name))
;; Execute a bound statement.
(define-message simple-execute-message #\E ()
(uint 1 0) ;; Name of the portal
(uint 4 0)) ;; Max amount of rows (0 = all rows)
;; Flush the sent messages, force server to start responding.
(define-message flush-message #\H ())
;; For re-synchronizing a socket.
(define-message sync-message #\S ())
;; Tell the server we are about to close the connection.
(define-message terminate-message #\X ())
;; To get out of the copy-in protocol.
(define-message copy-done-message #\c ())
(defun copy-data-message (socket data)
(declare (type string data)
#.*optimize*)
(write-uint1 socket 100)
(write-uint4 socket (+ 4 (length data)))
(enc-write-string data socket))
(define-message copy-fail-message #\f (reason)
(string reason))
postmodern-20151031-git/cl-postgres/package.lisp 0000664 0000000 0000000 00000006226 12600736344 0021464 0 ustar 00root root 0000000 0000000 (defpackage :cl-postgres
(:use :common-lisp)
(:export #:database-error
#:database-connection-lost
#:database-error-message
#:database-error-code
#:database-error-detail
#:database-error-query
#:database-error-cause
#:database-error-constraint-name
#:database-connection
#:database-connection-error
#:database-socket-error
#:connection-meta
#:connection-parameters
#:open-database
#:reopen-database
#:database-open-p
#:close-database
#:wait-for-notification
#:exec-query
#:prepare-query
#:unprepare-query
#:exec-prepared
#:field-name
#:field-type
#:row-reader
#:def-row-reader
#:next-row
#:next-field
#:list-row-reader
#:log-query
#:vector-row-reader
#:alist-row-reader
#:postgresql-notification
#:postgresql-notification-channel
#:postgresql-notification-payload
#:postgresql-notification-pid
#:postgresql-warning
#:ignore-row-reader
#:*sql-readtable*
#:copy-sql-readtable
#:default-sql-readtable
#:set-sql-reader
#:set-sql-datetime-readers
#:serialize-for-postgres
#:to-sql-string
#:*silently-truncate-rationals*
#:*query-callback*
#:*query-log*
#:open-db-writer
#:db-write-row
#:close-db-writer
#:*ssl-certificate-file*
#:*ssl-key-file*
#+(and sbcl unix) #:*unix-socket-dir*))
(defpackage :cl-postgres-error
(:use :common-lisp :cl-postgres)
(:export #:admin-shutdown
#:cannot-connect-now
#:check-violation
#:crash-shutdown
#:data-exception
#:db-division-by-zero
#:feature-not-supported
#:floating-point-exception
#:foreign-key-violation
#:insufficient-resources
#:insufficient-privilege
#:transaction-rollback
#:serialization-failure
#:transaction-integrity-constraint-violation
#:statement-completion-unknown
#:deadlock-detected
#:integrity-violation
#:internal-error
#:invalid-datetime-format
#:lock-not-available
#:not-null-violation
#:numeric-value-out-of-range
#:object-in-use
#:object-state-error
#:operator-intervention
#:program-limit-exceeded
#:query-canceled
#:restrict-violation
#:server-shutdown
#:syntax-error-or-access-violation
#:system-error
#:unique-violation))
(in-package :cl-postgres)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; Optimization settings (only used by functions that need it).
(defparameter *optimize*
'(optimize
(speed 3)
#-ecl(safety 0) #+ecl(safety 1)
(space 1)
(debug 1)
(compilation-speed 0))))
postmodern-20151031-git/cl-postgres/protocol.lisp 0000664 0000000 0000000 00000051422 12600736344 0021730 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
;; For more information about the PostgreSQL scocket protocol, see
;; http://www.postgresql.org/docs/current/interactive/protocol.html
(define-condition protocol-error (error)
((message :initarg :message))
(:report (lambda (err stream)
(format stream "PostgreSQL protocol error: ~A"
(slot-value err 'message))))
(:documentation "This is raised if something really unexpected
happens in the communcation with the server. Should only happen in
case of a bug or a connection to something that is not a \(supported)
PostgreSQL server at all."))
(defmacro message-case (socket &body clauses)
"Helper macro for reading messages from the server. A list of cases
\(characters that identify the message) can be given, each with a body
that handles the message, or the keyword :skip to skip the message.
Cases for error and warning messages are always added.
The body may contain an initial parameter of the form :LENGTH-SYM SYMBOL
where SYMBOL is a symbol to which the remaining length of the packet is
bound. This value indicates the number of bytes that have to be read
from the socket."
(let ((socket-name (gensym))
(size-name (gensym))
(char-name (gensym))
(iter-name (gensym))
(t-found nil)
(size-sym (and (eq (car clauses) :length-sym) (progn (pop clauses) (pop clauses)))))
(flet ((expand-characters (chars)
(cond ((eq chars t) (setf t-found t) t)
((consp chars) (mapcar #'char-code chars))
(t (char-code chars)))))
`(let* ((,socket-name ,socket))
(declare (type stream ,socket-name))
(labels ((,iter-name ()
(let ((,char-name (read-uint1 ,socket-name))
(,size-name (read-uint4 ,socket-name)))
(declare (type (unsigned-byte 8) ,char-name)
(type (unsigned-byte 32) ,size-name)
(ignorable ,size-name))
(case ,char-name
(#.(char-code #\A)
(get-notification ,socket-name)
(,iter-name))
(#.(char-code #\E) (get-error ,socket-name))
(#.(char-code #\S) ;; ParameterStatus: read and continue
(update-parameter ,socket-name)
(,iter-name))
(#.(char-code #\N) ;; A warning
(get-warning ,socket-name)
(,iter-name))
,@(mapcar (lambda (clause)
`(,(expand-characters (first clause))
,(if (eq (second clause) :skip)
`(skip-bytes ,socket-name (- ,size-name 4))
(if size-sym
`(let ((,size-sym (- ,size-name 4)))
,@(cdr clause))
`(progn ,@(cdr clause))))))
clauses)
,@(unless t-found
`((t (ensure-socket-is-closed ,socket-name)
(error 'protocol-error
:message (format nil "Unexpected message received: ~A"
(code-char ,char-name))))))))))
(,iter-name))))))
(defparameter *connection-params* nil
"Bound to the current connection's parameter table when executing
a query.")
(defun update-parameter (socket)
(let ((name (read-str socket))
(value (read-str socket)))
(setf (gethash name *connection-params*) value)))
(defun read-byte-delimited (socket)
"Read the fields of a null-terminated list of byte + string values
and put them in an alist."
(loop :for type = (read-uint1 socket)
:until (zerop type)
:collect (cons (code-char type) (read-simple-str socket))))
(define-condition postgresql-notification (simple-warning)
((pid :initarg :pid :accessor postgresql-notification-pid)
(channel :initarg :channel :accessor postgresql-notification-channel)
(payload :initarg :payload :accessor postgresql-notification-payload)))
(defun get-notification (socket)
"Read an asynchronous notification message from the socket and
signal a condition for it."
(let ((pid (read-int4 socket))
(channel (read-str socket))
(payload (read-str socket)))
(warn 'postgresql-notification
:pid pid
:channel channel
:payload payload
:format-control "Asynchronous notification ~S~@[ (payload: ~S)~] received from ~
server process with PID ~D."
:format-arguments (list channel payload pid))))
(defun get-error (socket)
"Read an error message from the socket and raise the corresponding
database-error condition."
(let ((data (read-byte-delimited socket)))
(flet ((get-field (char)
(cdr (assoc char data))))
(let ((code (get-field #\C)))
;; These are the errors "ADMIN SHUTDOWN" and "CRASH SHUTDOWN",
;; in which case the server will close the connection right
;; away.
(when (or (string= code "57P01") (string= code "57P02"))
(ensure-socket-is-closed socket))
(error (cl-postgres-error::get-error-type code)
:code code
:message (get-field #\M)
:detail (get-field #\D)
:hint (get-field #\H)
:context (get-field #\W)
:position (let ((position (get-field #\p)))
(when position (parse-integer position))))))))
(define-condition postgresql-warning (simple-warning)
())
(defun get-warning (socket)
"Read a warning from the socket and emit it."
(let ((data (read-byte-delimited socket)))
(flet ((get-field (char)
(cdr (assoc char data))))
(warn 'postgresql-warning
:format-control "PostgreSQL warning: ~A~@[~%~A~]"
:format-arguments (list (get-field #\M) (or (get-field #\D) (get-field #\H)))))))
(defparameter *ssl-certificate-file* nil
"When set to a filename, this file will be used as client
certificate for SSL connections.")
(defparameter *ssl-key-file* nil
"When set to a filename, this file will be used as client key for
SSL connections.")
;; The let is used to remember that we have found the
;; cl+ssl:make-ssl-client-stream function before.
(let ((make-ssl-stream nil))
(defun initiate-ssl (socket required)
"Initiate SSL handshake with the PostgreSQL server, and wrap the
socket in an SSL stream. When require is true, an error will be raised
when the server does not support SSL."
(unless make-ssl-stream
(unless (find-package :cl+ssl)
(error 'database-error :message "CL+SSL is not loaded. Load it to enable SSL."))
(setf make-ssl-stream (intern (string '#:make-ssl-client-stream) :cl+ssl)))
(ssl-request-message socket)
(force-output socket)
(ecase (read-byte socket)
(#.(char-code #\S)
(setf socket (funcall make-ssl-stream socket :key *ssl-key-file*
:certificate *ssl-certificate-file*)))
(#.(char-code #\N)
(when required
(error 'database-error :message "Server does not support SSL encryption."))))))
(defun authenticate (socket conn)
"Try to initiate a connection. Caller should close the socket if
this raises a condition."
(let ((gss-context nil)
(gss-init-function nil)
(user (connection-user conn))
(password (connection-password conn))
(database (connection-db conn))
(use-ssl (connection-use-ssl conn)))
(unless (eq use-ssl :no)
(setf socket (initiate-ssl socket (eq use-ssl :yes))))
(startup-message socket user database)
(force-output socket)
(labels ((init-gss-msg (in-buffer)
(when (null gss-init-function)
(when (null (find-package "CL-GSS"))
(error 'database-error :message "To use GSS authentication, make sure the CL-GSS package is loaded."))
(setq gss-init-function (find-symbol "INIT-SEC" "CL-GSS"))
(unless gss-init-function
(error 'database-error :message "INIT-SEC not found in CL-GSS package")))
(multiple-value-bind (continue-needed context buffer flags)
(funcall gss-init-function
(format nil "~a@~a" (connection-service conn) (connection-host conn))
:flags '(:mutual)
:context gss-context
:input-token in-buffer)
(declare (ignore flags))
(setq gss-context context)
(when buffer
(gss-auth-buffer-message socket buffer))
(force-output socket)
continue-needed)))
(loop
(message-case socket :length-sym size
;; Authentication message
(#\R (let ((type (read-uint4 socket)))
(ecase type
(0 (return))
(2 (error 'database-error :message "Unsupported Kerberos authentication requested."))
(3 (unless password (error "Server requested plain-password authentication, but no password was given."))
(plain-password-message socket password)
(force-output socket))
(4 (error 'database-error :message "Unsupported crypt authentication requested."))
(5 (unless password (error "Server requested md5-password authentication, but no password was given."))
(md5-password-message socket password user (read-bytes socket 4))
(force-output socket))
(6 (error 'database-error :message "Unsupported SCM authentication requested."))
(7 (when gss-context
(error 'database-error :message "Got GSS init message when a context was already established"))
(init-gss-msg nil))
(8 (unless gss-context
(error 'database-error :message "Got GSS continuation message without a context"))
(init-gss-msg (read-bytes socket (- size 4)))))))))))
(loop
(message-case socket
;; BackendKeyData - ignore
(#\K :skip)
;; ReadyForQuery
(#\Z (read-uint1 socket)
(return))))
socket)
(defclass field-description ()
((name :initarg :name :accessor field-name)
(type-id :initarg :type-id :accessor field-type)
(interpreter :initarg :interpreter :accessor field-interpreter)
(receive-binary-p :initarg :receive-binary-p :accessor field-binary-p))
(:documentation "Description of a field in a query result."))
(defun read-field-descriptions (socket)
"Read the field descriptions for a query result and put them into an
array of field-description objects."
(declare (type stream socket)
#.*optimize*)
(let* ((number (read-uint2 socket))
(descriptions (make-array number)))
(declare (type fixnum number)
(type (simple-array field-description) descriptions))
(dotimes (i number)
(let* ((name (read-str socket))
(table-oid (read-uint4 socket))
(column (read-uint2 socket))
(type-id (read-uint4 socket))
(size (read-uint2 socket))
(type-modifier (read-uint4 socket))
(format (read-uint2 socket))
(interpreter (type-interpreter type-id)))
(declare (ignore table-oid column size type-modifier format)
(type string name)
(type (unsigned-byte 32) type-id))
(setf (elt descriptions i)
(make-instance 'field-description :name name :type-id type-id
:interpreter (cdr interpreter)
:receive-binary-p (car interpreter)))))
descriptions))
(defun terminate-connection (socket)
"Close a connection, notifying the server."
(terminate-message socket)
(close socket))
;; This is a hacky way to communicate the amount of effected rows up
;; from look-for-row to the send-execute or send-query that (directly
;; or indirectly) called it.
(defparameter *effected-rows* nil)
(defun look-for-row (socket)
"Read server messages until either a new row can be read, or there
are no more results. Return a boolean indicating whether any more
results are available, and, if available, stores the amount of
effected rows in *effected-rows*. Also handle getting out of
copy-in/copy-out states \(which are not supported)."
(declare (type stream socket)
#.*optimize*)
(loop
(message-case socket
;; CommandComplete
(#\C (let* ((command-tag (read-str socket))
(space (position #\Space command-tag :from-end t)))
(when space
(setf *effected-rows* (parse-integer command-tag :junk-allowed t
:start (1+ space))))
(return-from look-for-row nil)))
;; CopyInResponse
(#\G (read-uint1 socket)
(skip-bytes socket (* 2 (read-uint2 socket))) ;; The field formats
(copy-done-message socket)
(error 'database-error :message "Copy-in not supported."))
;; CopyOutResponse
(#\H (read-uint1 socket)
(skip-bytes socket (* 2 (read-uint2 socket))) ;; The field formats
(error 'database-error :message "Copy-out not supported."))
;; DataRow
(#\D (skip-bytes socket 2)
(return-from look-for-row t))
;; EmptyQueryResponse
(#\I (warn "Empty query sent.")
(return-from look-for-row nil)))))
(defun try-to-sync (socket sync-sent)
"Try to re-synchronize a connection by sending a sync message if it
hasn't already been sent, and then looking for a ReadyForQuery
message."
(when (open-stream-p socket)
(let ((ok nil))
(unwind-protect
(progn
(unless sync-sent
(sync-message socket)
(force-output socket))
;; TODO initiate timeout on the socket read, signal timeout error
(loop :while (and (not ok) (open-stream-p socket))
:do (message-case socket
(#\Z (read-uint1 socket)
(setf ok t))
(t :skip))))
(unless ok
;; if we can't sync, make sure the socket is shot
;; (e.g. a timeout, or aborting execution with a restart from sldb)
(ensure-socket-is-closed socket :abort t))))))
(defmacro with-syncing (&body body)
"Macro to wrap a block in a handler that will try to re-sync the
connection if something in the block raises a condition. Not hygienic
at all, only used right below here."
`(let ((sync-sent nil)
(ok nil))
(handler-case
(unwind-protect
(multiple-value-prog1
(progn ,@body)
(setf ok t))
(unless ok
(try-to-sync socket sync-sent)))
(end-of-file (c)
(ensure-socket-is-closed socket :abort t)
(error c)))))
(defmacro returning-effected-rows (value &body body)
"Computes a value, then runs a body, then returns, as multiple
values, that value and the amount of effected rows, if any (see
*effected rows*)."
(let ((value-name (gensym)))
`(let* ((*effected-rows* nil)
(,value-name ,value))
,@body
(if *effected-rows*
(values ,value-name *effected-rows*)
,value-name))))
(defun send-query (socket query row-reader)
"Send a query to the server, and apply the given row-reader to the
results."
(declare (type stream socket)
(type string query)
#.*optimize*)
(with-syncing
(with-query (query)
(let ((row-description nil))
(simple-parse-message socket query)
(simple-describe-message socket)
(flush-message socket)
(force-output socket)
(message-case socket
;; ParseComplete
(#\1))
(message-case socket
;; ParameterDescription
(#\t :skip))
(message-case socket
;; RowDescription
(#\T (setf row-description (read-field-descriptions socket)))
;; NoData
(#\n))
(simple-bind-message socket (map 'vector 'field-binary-p row-description))
(simple-execute-message socket)
(sync-message socket)
(setf sync-sent t)
(force-output socket)
(message-case socket
;; BindComplete
(#\2))
(returning-effected-rows
(if row-description
(funcall row-reader socket row-description)
(look-for-row socket))
(message-case socket
;; ReadyForQuery, skipping transaction status
(#\Z (read-uint1 socket))))))))
(defun send-parse (socket name query)
"Send a parse command to the server, giving it a name."
(declare (type stream socket)
(type string name query)
#.*optimize*)
(with-syncing
(with-query (query)
(parse-message socket name query)
(flush-message socket)
(force-output socket)
(message-case socket
;; ParseComplete
(#\1)))))
(defun send-close (socket name)
"Send a close command to the server, giving it a name."
(declare (type stream socket)
(type string name)
#.*optimize*)
(with-syncing
(close-prepared-message socket name)
(flush-message socket)
(force-output socket)
(message-case socket
;; CloseComplete
(#\3))))
(defun send-execute (socket name parameters row-reader)
"Execute a previously parsed query, and apply the given row-reader
to the result."
(declare (type stream socket)
(type string name)
(type list parameters)
#.*optimize*)
(with-syncing
(let ((row-description nil)
(n-parameters 0))
(declare (type (unsigned-byte 16) n-parameters))
(describe-prepared-message socket name)
(flush-message socket)
(force-output socket)
(message-case socket
;; ParameterDescription
(#\t (setf n-parameters (read-uint2 socket))
(skip-bytes socket (* 4 n-parameters))))
(message-case socket
;; RowDescription
(#\T (setf row-description (read-field-descriptions socket)))
;; NoData
(#\n))
(unless (= (length parameters) n-parameters)
(error 'database-error
:message (format nil "Incorrect number of parameters given for prepared statement ~A." name)))
(bind-message socket name (map 'vector 'field-binary-p row-description)
parameters)
(simple-execute-message socket)
(sync-message socket)
(setf sync-sent t)
(force-output socket)
(message-case socket
;; BindComplete
(#\2))
(returning-effected-rows
(if row-description
(funcall row-reader socket row-description)
(look-for-row socket))
(message-case socket
;; CommandComplete
(#\C (read-str socket)
(message-case socket
(#\Z (read-uint1 socket))))
;; ReadyForQuery, skipping transaction status
(#\Z (read-uint1 socket)))))))
(defun build-row-reader (function-form fields body)
"Helper for the following two macros."
(let ((socket (gensym)))
`(,@function-form (,socket ,fields)
(declare (type stream ,socket)
(type (simple-array field-description) ,fields))
(flet ((next-row ()
(look-for-row ,socket))
(next-field (field)
(declare (type field-description field))
(let ((size (read-int4 ,socket)))
(declare (type (signed-byte 32) size))
(if (eq size -1)
:null
(funcall (field-interpreter field)
,socket size)))))
,@body))))
(defmacro row-reader ((fields) &body body)
"Create a row-reader, using the given name for the fields argument
and the given body for reading the rows. A row reader is a function
that is used to do something with the results of a query. It has two
local functions: next-row and next-field, the first should be called
once per row and will return a boolean indicating whether there are
any more rows, the second should be called once for every element in
the fields vector, with that field as argument, to read a single value
in a row. See list-row-reader in public.lisp for an example."
(build-row-reader '(lambda) fields body))
(defmacro def-row-reader (name (fields) &body body)
"Create a row reader, as in the row-reader macro, and assign a name
to it."
(build-row-reader `(defun ,name) fields body))
postmodern-20151031-git/cl-postgres/public.lisp 0000664 0000000 0000000 00000031551 12600736344 0021346 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
(defclass database-connection ()
((host :initarg :host :reader connection-host)
(port :initarg :port :reader connection-port)
(database :initarg :db :reader connection-db)
(user :initarg :user :reader connection-user)
(password :initarg :password :reader connection-password)
(use-ssl :initarg :ssl :reader connection-use-ssl)
(service :initarg :service :accessor connection-service)
(socket :initarg :socket :accessor connection-socket)
(meta :initform nil)
(available :initform t :accessor connection-available)
(parameters :accessor connection-parameters)
(timestamp-format :accessor connection-timestamp-format))
(:documentation "Representation of a database connection. Contains
login information in order to be able to automatically re-establish a
connection when it is somehow closed."))
(defun connection-meta (connection)
"Retrieves the meta field of a connection, the primary purpose of
which is to store information about the prepared statements that
exists for it."
(or (slot-value connection 'meta)
(let ((meta-data (make-hash-table)))
(setf (slot-value connection 'meta) meta-data)
meta-data)))
(defun database-open-p (connection)
"Returns a boolean indicating whether the given connection is
currently connected."
(and (connection-socket connection)
(open-stream-p (connection-socket connection))))
(defun open-database (database user password host &optional (port 5432) (use-ssl :no) (service "postgres"))
"Create and connect a database object. use-ssl may be :no, :yes, or :try."
(check-type database string)
(check-type user string)
(check-type password (or null string))
(check-type host (or string (eql :unix)) "a string or :unix")
(check-type port (integer 1 65535) "an integer from 1 to 65535")
(check-type use-ssl (member :no :yes :try) ":no, :yes, or :try")
(let ((conn (make-instance 'database-connection :host host :port port :user user
:password password :socket nil :db database :ssl use-ssl
:service service)))
(initiate-connection conn)
conn))
#+(and (or sbcl ccl allegro) unix)
(progn
(defparameter *unix-socket-dir*
#-(or freebsd darwin) "/var/run/postgresql/"
#+(or darwin freebsd) "/tmp/"
"Directory where the Unix domain socket for PostgreSQL be found.")
(defun unix-socket-path (base-dir port)
(unless (char= #\/ (aref base-dir (1- (length base-dir))))
(setf base-dir (concatenate 'string base-dir "/")))
(format nil "~a.s.PGSQL.~a" base-dir port))
#+sbcl
(defun unix-socket-connect (path)
(let ((sock (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
(sb-bsd-sockets:socket-connect sock path)
(sb-bsd-sockets:socket-make-stream
sock :input t :output t :element-type '(unsigned-byte 8))))
#+ccl
(defun unix-socket-connect (path)
(ccl:make-socket :type :stream
:address-family :file
:format :binary
:remote-filename path))
#+allegro
(defun unix-socket-connect (path)
(socket:make-socket :type :stream
:address-family :file
:format :binary
:remote-filename path)))
#+sbcl
(defun inet-socket-connect (host port)
(let ((sock (make-instance 'sb-bsd-sockets:inet-socket
:type :stream :protocol :tcp))
(host (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name host))))
(sb-bsd-sockets:socket-connect sock host port)
(sb-bsd-sockets:socket-make-stream
sock :input t :output t :buffering :full :element-type '(unsigned-byte 8))))
#+ccl
(defun inet-socket-connect (host port)
(ccl:make-socket :format :binary
:remote-host host
:remote-port port))
#+allegro
(defun inet-socket-connect (host port)
(socket:make-socket :remote-host host
:remote-port port
:format :binary
:type :stream))
(defun initiate-connection (conn)
"Check whether a connection object is connected, try to connect it
if it isn't."
(flet ((add-restart (err)
(restart-case (error (wrap-socket-error err))
(:reconnect () :report "Try again." (initiate-connection conn))))
(assert-unix ()
#+unix t
#-unix (error "Unix sockets only available on Unix (really)")))
(handler-case
(let ((socket #-(or allegro sbcl ccl)
(usocket:socket-stream
(usocket:socket-connect (connection-host conn)
(connection-port conn)
:element-type '(unsigned-byte 8)))
#+(or allegro sbcl ccl)
(cond
((equal (connection-host conn) :unix)
(assert-unix)
(unix-socket-connect (unix-socket-path *unix-socket-dir* (connection-port conn))))
((and (stringp (connection-host conn))
(char= #\/ (aref (connection-host conn) 0)))
(assert-unix)
(unix-socket-connect (unix-socket-path (connection-host conn) (connection-port conn))))
((and (pathnamep (connection-host conn))
(eql :absolute (pathname-directory (connection-host conn))))
(assert-unix)
(unix-socket-connect (unix-socket-path (namestring (connection-host conn))
(connection-port conn))))
(t
(inet-socket-connect (connection-host conn)
(connection-port conn)))))
(finished nil)
(*connection-params* (make-hash-table :test 'equal)))
(setf (slot-value conn 'meta) nil
(connection-parameters conn) *connection-params*)
(unwind-protect
(setf socket (authenticate socket conn)
(connection-timestamp-format conn)
(if (string= (gethash "integer_datetimes" (connection-parameters conn)) "on")
:integer :float)
(connection-socket conn) socket
finished t)
(unless finished
(ensure-socket-is-closed socket))))
#-(or allegro sbcl ccl)(usocket:socket-error (e) (add-restart e))
#+ccl (ccl:socket-error (e) (add-restart e))
#+allegro(excl:socket-error (e) (add-restart e))
#+sbcl(sb-bsd-sockets:socket-error (e) (add-restart e))
(stream-error (e) (add-restart e))))
(values))
(defun reopen-database (conn)
"Reconnect a disconnected database connection."
(unless (database-open-p conn)
(initiate-connection conn)))
(defun ensure-connection (conn)
"Used to make sure a connection object is connected before doing
anything with it."
(unless conn
(error "No database connection selected."))
(unless (database-open-p conn)
(restart-case (error 'database-connection-lost :message "Connection to database server lost.")
(:reconnect () :report "Try to reconnect." (initiate-connection conn)))))
(defun close-database (connection)
"Gracefully disconnect a database connection."
(when (database-open-p connection)
(terminate-connection (connection-socket connection)))
(values))
(defmacro using-connection (connection &body body)
"This is used to prevent a row-reader from recursively calling some
query function. Because the connection is still returning results from
the previous query when a row-reading is being executed, starting
another query will not work as expected \(or at all, in general). This
might also raise an error when you are using a single database
connection from multiple threads, but you should not do that at all.
Also binds *timestamp-format* and *connection-params*, which might be
needed by the code interpreting the query results."
(let ((connection-name (gensym)))
`(let* ((,connection-name ,connection)
(*timestamp-format* (connection-timestamp-format ,connection-name))
(*connection-params* (connection-parameters ,connection-name)))
(when (not (connection-available ,connection-name))
(error 'database-error :message "This connection is still processing another query."))
(setf (connection-available ,connection-name) nil)
(unwind-protect (progn ,@body)
(setf (connection-available ,connection-name) t)))))
(defmacro with-reconnect-restart (connection &body body)
"When, inside the body, an error occurs that breaks the connection
socket, a condition of type database-connection-error is raised,
offering a :reconnect restart."
(let ((connection-name (gensym))
(body-name (gensym))
(retry-name (gensym)))
`(let ((,connection-name ,connection))
(ensure-connection ,connection-name)
(labels ((,body-name ()
(handler-case (progn ,@body)
(stream-error (e)
(cond ((eq (connection-socket ,connection-name) (stream-error-stream e))
(ensure-socket-is-closed (connection-socket ,connection-name) :abort t)
(,retry-name (wrap-socket-error e)))
(t (error e))))
(cl-postgres-error:server-shutdown (e)
(ensure-socket-is-closed (connection-socket ,connection-name) :abort t)
(,retry-name e))))
(,retry-name (err)
(restart-case (error err)
(:reconnect () :report "Try to reconnect"
(reopen-database ,connection-name)
(,body-name)))))
(,body-name)))))
(defun wait-for-notification (connection)
"Perform a blocking wait for asynchronous notification. Return the
channel string, the payload and notifying pid as multiple values."
(block nil
(with-reconnect-restart connection
(handler-bind ((postgresql-notification
(lambda (c)
(return (values (postgresql-notification-channel c)
(postgresql-notification-payload c)
(postgresql-notification-pid c))))))
(message-case (connection-socket connection))))))
(defun exec-query (connection query &optional (row-reader 'ignore-row-reader))
"Execute a query string and apply the given row-reader to the
result."
(check-type query string)
(with-reconnect-restart connection
(using-connection connection
(send-query (connection-socket connection) query row-reader))))
(defun prepare-query (connection name query)
"Prepare a query string and store it under the given name."
(check-type query string)
(check-type name string)
(with-reconnect-restart connection
(using-connection connection
(send-parse (connection-socket connection) name query)
(values))))
(defun unprepare-query (connection name)
"Close the prepared query given by name."
(check-type name string)
(with-reconnect-restart connection
(using-connection connection
(send-close (connection-socket connection) name)
(values))))
(defun exec-prepared (connection name parameters &optional (row-reader 'ignore-row-reader))
"Execute a previously prepared query with the given parameters,
apply a row-reader to the result."
(check-type name string)
(check-type parameters list)
(with-reconnect-restart connection
(using-connection connection
(send-execute (connection-socket connection)
name parameters row-reader))))
;; A row-reader that returns a list of (field-name . field-value)
;; alist for the returned rows.
(def-row-reader alist-row-reader (fields)
(loop :while (next-row)
:collect (loop :for field :across fields
:collect (cons (field-name field)
(next-field field)))))
;; Row-reader that returns a list of lists.
(def-row-reader list-row-reader (fields)
(loop :while (next-row)
:collect (loop :for field :across fields
:collect (next-field field))))
;; Row-reader that returns a vector of vectors.
(def-row-reader vector-row-reader (fields)
(let ((rows (make-array 1 :adjustable t :fill-pointer 0)))
(loop :for row = (make-array (length fields))
:while (next-row)
:do (progn
(loop :for field :across fields
:for idx :upfrom 0
:do (setf (aref row idx) (next-field field)))
(vector-push-extend row rows)))
rows))
;; Row-reader that discards the query results.
(def-row-reader ignore-row-reader (fields)
(loop :while (next-row)
:do (loop :for field :across fields
:do (next-field field)))
(values))
postmodern-20151031-git/cl-postgres/sql-string.lisp 0000664 0000000 0000000 00000011754 12600736344 0022176 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
(defun escape-bytes (bytes)
"Escape an array of octets in PostgreSQL's horribly inefficient
textual format for binary data."
(let ((*print-pretty* nil))
(with-output-to-string (out)
(loop :for byte :of-type fixnum :across bytes
:do (if (or (< byte 32) (> byte 126) (= byte 39) (= byte 92))
(progn
(princ #\\ out)
(princ (digit-char (ldb (byte 3 6) byte) 8) out)
(princ (digit-char (ldb (byte 3 3) byte) 8) out)
(princ (digit-char (ldb (byte 3 0) byte) 8) out))
(princ (code-char byte) out))))))
(defparameter *silently-truncate-rationals* t)
(defun write-rational-as-floating-point (number stream digit-length-limit)
(declare #.*optimize*)
(flet ((fail ()
(if *silently-truncate-rationals*
(return-from write-rational-as-floating-point)
(error 'database-error :message
(format nil "Can not write the rational ~a with only ~a digits"
number digit-length-limit)))))
(multiple-value-bind (quotient remainder)
(truncate (if (< number 0) (prog1 (- number) (write-char #\- stream)) number))
(let* ((quotient-part (princ-to-string quotient))
(decimal-length-limit (- digit-length-limit (length quotient-part))))
(write-string quotient-part stream)
(when (<= decimal-length-limit 0) (fail))
(unless (zerop remainder) (write-char #\. stream))
(loop :for decimal-digits :upfrom 1 :until (zerop remainder)
:do (when (> decimal-digits decimal-length-limit) (fail))
:do (multiple-value-bind (quotient rem) (floor (* remainder 10))
(princ quotient stream)
(setf remainder rem)))))))
(defun write-quoted (string out)
(write-char #\" out)
(loop :for ch :across string :do
(when (member ch '(#\" #\\))
(write-char #\\ out))
(write-char ch out))
(write-char #\" out))
(defgeneric to-sql-string (arg)
(:documentation "Turn a lisp value into a string containing its SQL
representation. Returns an optional second value that indicates
whether the string should be escaped before being put into a query.")
(:method ((arg string))
(values arg t))
(:method ((arg vector))
(if (typep arg '(vector (unsigned-byte 8)))
(values (escape-bytes arg) t)
(values
(with-output-to-string (out)
(write-char #\{ out)
(loop :for sep := "" :then #\, :for x :across arg :do
(princ sep out)
(multiple-value-bind (string escape) (to-sql-string x)
(if escape (write-quoted string out) (write-string string out))))
(write-char #\} out))
t)))
(:method ((arg array))
(values
(with-output-to-string (out)
(labels ((recur (dims off)
(write-char #\{ out)
(if (cdr dims)
(let ((factor (reduce #'* (cdr dims))))
(loop :for i :below (car dims) :for sep := "" :then #\, :do
(princ sep out)
(recur (cdr dims) (+ off (* factor i)))))
(loop :for sep := "" :then #\, :for i :from off :below (+ off (car dims)) :do
(princ sep out)
(multiple-value-bind (string escape) (to-sql-string (row-major-aref arg i))
(if escape (write-quoted string out) (write-string string out)))))
(write-char #\} out)))
(recur (array-dimensions arg) 0)))
t))
(:method ((arg integer))
(princ-to-string arg))
(:method ((arg float))
(format nil "~f" arg))
#-clisp (:method ((arg double-float)) ;; CLISP doesn't allow methods on double-float
(format nil "~,,,,,,'EE" arg))
(:method ((arg ratio))
;; Possible optimization: we could probably build up the same binary structure postgres
;; sends us instead of sending it as a string. See the "numeric" interpreter for more details...
(with-output-to-string (result)
;; PostgreSQL happily handles 200+ decimal digits, but the SQL standard only requires
;; 38 digits from the NUMERIC type, and Oracle also doesn't handle more. For practical
;; reasons we also draw the line there. If someone needs full rational numbers then
;; 200 wouldn't help them much more than 38...
(write-rational-as-floating-point arg result 38)))
(:method ((arg (eql t)))
"true")
(:method ((arg (eql nil)))
"false")
(:method ((arg (eql :null)))
"NULL")
(:method ((arg t))
(error "Value ~S can not be converted to an SQL literal." arg)))
(defgeneric serialize-for-postgres (arg)
(:documentation "Conversion function used to turn a lisp value into a value that PostgreSQL understands when sent through its socket connection. May return a string or a (vector (unsigned-byte 8)).")
(:method (arg)
(to-sql-string arg)))
postmodern-20151031-git/cl-postgres/strings-ascii.lisp 0000664 0000000 0000000 00000003131 12600736344 0022640 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
(defparameter *client-encoding* "SQL_ASCII")
(declaim (inline enc-byte-length))
(defun enc-byte-length (sequence)
(length sequence))
(declaim (ftype (function (t &key (:null-terminated t)
(:byte-length unsigned-byte))
string)
enc-read-string))
(defun enc-read-string (stream &key null-terminated byte-length)
"Read an ascii-string from a byte stream, until either a null byte
is reached or the given amount of bytes have been read."
(declare (type stream stream)
(type (or null fixnum) byte-length)
#.*optimize*)
(let ((bytes-read 0)
(string (make-array 64 :element-type 'character
:adjustable t :fill-pointer 0)))
(loop
(when (and byte-length (>= bytes-read byte-length))
(return))
(let ((next-char (read-byte stream)))
(incf bytes-read)
(when (and null-terminated (eq next-char 0))
(return))
(vector-push-extend (code-char next-char) string)))
string))
(declaim (ftype (function (string) (simple-array (unsigned-byte 8) (*)))
enc-string-bytes))
(defun enc-string-bytes (string)
"Convert an ascii string to an array of octets."
(map '(simple-array (unsigned-byte 8) (*)) 'char-code string))
(defun enc-write-string (string stream)
"Write an ascii string to a stream."
(declare (type stream stream)
(type string string)
#.*optimize*)
(loop :for char :of-type character :across string
:do (write-byte (char-code char) stream)))
postmodern-20151031-git/cl-postgres/strings-utf-8.lisp 0000664 0000000 0000000 00000002004 12600736344 0022511 0 ustar 00root root 0000000 0000000 (in-package :cl-postgres)
(defparameter *client-encoding* "UNICODE")
(declaim (inline enc-byte-length))
(defun enc-byte-length (sequence)
(cl-postgres-trivial-utf-8:utf-8-byte-length sequence))
(declaim (inline enc-write-string))
(defun enc-write-string (string output &key null-terminate)
(cl-postgres-trivial-utf-8:write-utf-8-bytes string output
:null-terminate null-terminate))
(declaim (inline enc-read-string))
(declaim (ftype (function (t &key (:null-terminated t)
(:byte-length unsigned-byte))
string)
enc-read-string))
(defun enc-read-string (input &key null-terminated (byte-length -1))
(cl-postgres-trivial-utf-8:read-utf-8-string
input :null-terminated null-terminated :byte-length byte-length))
(declaim (inline enc-string-bytes))
(defun enc-string-bytes (string &key null-terminate)
(cl-postgres-trivial-utf-8:string-to-utf-8-bytes
string :null-terminate null-terminate))
postmodern-20151031-git/cl-postgres/tests.lisp 0000664 0000000 0000000 00000013551 12600736344 0021232 0 ustar 00root root 0000000 0000000 (defpackage :cl-postgres-tests
(:use :common-lisp :Eos :simple-date :cl-postgres :cl-postgres-error)
(:export #:prompt-connection))
(in-package :cl-postgres-tests)
(defparameter *test-connection* '("test" "test" "" "localhost"))
(defun prompt-connection (&optional (list *test-connection*))
(flet ((ask (name pos)
(format *query-io* "~a (enter to keep '~a'): " name (nth pos list))
(finish-output *query-io*)
(let ((answer (read-line *query-io*)))
(unless (string= answer "") (setf (nth pos list) answer)))))
(format *query-io* "~%To run this test, you must configure a database connection.~%")
(ask "Database name" 0)
(ask "User" 1)
(ask "Password" 2)
(ask "Hostname" 3)))
;; Adjust the above to some db/user/pass/host/[port] combination that
;; refers to a valid postgresql database, then after loading the file,
;; run the tests with (Eos:run! :cl-postgres)
(def-suite :cl-postgres)
(in-suite :cl-postgres)
(defmacro with-test-connection (&body body)
`(let ((connection (apply 'open-database *test-connection*)))
(unwind-protect (progn ,@body)
(close-database connection))))
(test connect-sanity
(with-test-connection
(is (database-open-p connection))))
(test simple-query
(with-test-connection
(destructuring-bind ((a b c d e))
(exec-query connection "select 22::integer, 44.5::double precision, 'abcde'::varchar, true::boolean, 4.5::numeric(5,2)"
'list-row-reader)
(is (eql a 22))
(is (eql b 44.5d0))
(is (string= c "abcde"))
(is (eql d t))
(is (eql e 9/2)))))
(test sql-strings
(is (string= (to-sql-string :null) "NULL"))
(is (string= (to-sql-string t) "true"))
(is (string= (to-sql-string 400) "400"))
(is (string= (to-sql-string "foo") "foo"))
(is (eq t (nth-value 1 (to-sql-string "bar"))))
(is (eq nil (nth-value 1 (to-sql-string 10)))))
(test date-query
(with-test-connection
(destructuring-bind ((a b c))
(exec-query connection "select '1980-02-01'::date, '2010-04-05 14:42:21.500'::timestamp, '2 years -4 days'::interval"
'list-row-reader)
(is (time= a (encode-date 1980 2 1)))
(is (time= b (encode-timestamp 2010 4 5 14 42 21 500)))
(is (time= c (encode-interval :year 2 :day -4))))))
(test alist-row-reader
(with-test-connection
(is (equal (exec-query connection "select 42 as foo, 99 as bar" 'alist-row-reader)
'((("foo" . 42) ("bar" . 99)))))))
(test prepared-statement
(with-test-connection
(prepare-query connection "test" "select $1::integer, $2::boolean, $3::text")
(is (equal (exec-prepared connection "test" '(42 nil "foo") 'list-row-reader)
'((42 nil "foo"))))))
(test unprepare-statement
(with-test-connection
(prepare-query connection "test" "select true")
(unprepare-query connection "test")
(prepare-query connection "test" "select false")
(is (equal (exec-prepared connection "test" '() 'list-row-reader)
'((nil))))))
(test prepared-array-param
(with-test-connection
(prepare-query connection "test" "select ($1::int[])[2]")
(is (equal (exec-prepared connection "test" '(#(1 2 3)) 'list-row-reader)
'((2))))
(prepare-query connection "test2" "select ($1::text[])[2]")
(is (equal (exec-prepared connection "test2" '(#("A" "B" "C")) 'list-row-reader)
'(("B"))))))
(test blob
(with-test-connection
(let* ((str "foobar42")
(bytes (coerce #(102 111 111 98 97 114 52 50) '(vector (unsigned-byte 8)))))
(prepare-query connection "test" "select $1::varchar, $2::bytea")
(is (equalp (exec-prepared connection "test" (list str bytes) 'list-row-reader)
(list (list str bytes)))))))
(test recover-error
(with-test-connection
(signals cl-postgres-error:syntax-error-or-access-violation
(exec-query connection "gubble gubble gabble goo"))
(is (equal (exec-query connection "select false" 'list-row-reader)
'((nil))))))
(test unique-violation-error
(with-test-connection
(exec-query connection "create table test (id int not null primary key, name text)")
(exec-query connection "insert into test values (1, 'bert')")
(signals unique-violation
(exec-query connection "insert into test values (1, 'harry')"))
(exec-query connection "drop table test")))
(test sql-reader
(with-test-connection
(let ((*sql-readtable* (copy-sql-readtable)))
(set-sql-reader 2249 (lambda (text)
(with-input-from-string (*standard-input* text)
(read-char) ;; opening paren
(let ((x (read)))
(read-char) ;; comma
(cons x (read))))))
(is (equal (exec-query connection "select (10,20)" 'list-row-reader)
'(((10 . 20))))))
(is (equal (exec-query connection "select (30,40)" 'list-row-reader)
'(("(30,40)"))))))
(test bulk-writer
(with-test-connection
(exec-query connection "create table test (a int, b text, c date, d timestamp, e int[])")
(let ((stream (open-db-writer *test-connection* 'test '(a b c d e))))
;; test a variety of types (int, text, date, timstamp, int array)
(loop for row in '((1 "one" "2012-01-01" "2012-01-01 00:00" #(1 2 3 42))
(2 "two" "2012-01-01" "2012-01-01 00:00" #(3 2 1 42))
;; make sure utf-8 gets through ok
(3 "κόσμε" "2012-01-01" "2012-01-01 00:00" #(1))
;; make sure tabs get through ok
(4 "one two three" "2012-01-01" "2012-01-01 00:00" #(1)))
do
(db-write-row stream row))
(close-db-writer stream))
(print (exec-query connection "select * from test"))
(exec-query connection "drop table test")))
postmodern-20151031-git/cl-postgres/trivial-utf-8.lisp 0000664 0000000 0000000 00000021506 12600736344 0022502 0 ustar 00root root 0000000 0000000 ;;; Minimal utf-8 decoding and encoding library.
;;;
;;; See http://common-lisp.net/project/trivial-utf-8/
(defpackage :cl-postgres-trivial-utf-8
(:use :common-lisp)
(:export #:utf-8-byte-length
#:string-to-utf-8-bytes
#:write-utf-8-bytes
#:utf-8-group-size
#:utf-8-bytes-to-string
#:read-utf-8-string
#:utf-8-decoding-error))
(in-package :cl-postgres-trivial-utf-8)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *optimize*
'(optimize
(speed 3)
#-ecl(safety 0) #+ecl(safety 1)
(space 0)
(debug 1)
(compilation-speed 0))))
(defun utf-8-byte-length (string)
"Calculate the amount of bytes needed to encode a string."
(declare (type string string)
#'*optimize*)
(let ((length (length string))
(string (coerce string 'simple-string)))
(loop :for char :across string
:do (let ((code (char-code char)))
(when (> code 127)
(incf length
(cond ((< code 2048) 1)
((< code 65536) 2)
(t 3))))))
length))
(defmacro as-utf-8-bytes (char writer)
"Given a character, calls the writer function for every byte in the
encoded form of that character."
(let ((char-code (gensym)))
`(let ((,char-code (char-code ,char)))
(declare (type fixnum ,char-code))
(cond ((< ,char-code 128)
(,writer ,char-code))
((< ,char-code 2048)
(,writer (logior #b11000000 (ldb (byte 5 6) ,char-code)))
(,writer (logior #b10000000 (ldb (byte 6 0) ,char-code))))
((< ,char-code 65536)
(,writer (logior #b11100000 (ldb (byte 4 12) ,char-code)))
(,writer (logior #b10000000 (ldb (byte 6 6) ,char-code)))
(,writer (logior #b10000000 (ldb (byte 6 0) ,char-code))))
(t
(,writer (logior #b11110000 (ldb (byte 3 18) ,char-code)))
(,writer (logior #b10000000 (ldb (byte 6 12) ,char-code)))
(,writer (logior #b10000000 (ldb (byte 6 6) ,char-code)))
(,writer (logior #b10000000 (ldb (byte 6 0) ,char-code))))))))
(defun string-to-utf-8-bytes (string &key null-terminate)
"Convert a string into an array of unsigned bytes containing its
utf-8 representation."
(declare (type string string)
#.*optimize*)
(let ((buffer (make-array (+ (the fixnum (utf-8-byte-length string))
(if null-terminate 1 0))
:element-type '(unsigned-byte 8)))
(position 0)
(string (coerce string 'simple-string)))
(declare (type (array (unsigned-byte 8)) buffer)
(type fixnum position))
(macrolet ((add-byte (byte)
`(progn (setf (aref buffer position) ,byte)
(incf position))))
(loop :for char :across string
:do (as-utf-8-bytes char add-byte)))
(when null-terminate
(setf (elt buffer (1- (length buffer))) 0))
buffer))
(defun write-utf-8-bytes (string output &key null-terminate)
"Write a string to a byte-stream, encoding it as utf-8."
(declare (type string string)
(type stream output)
#.*optimize*)
(macrolet ((byte-out (byte)
`(write-byte ,byte output)))
(let ((string (coerce string 'simple-string)))
(loop :for char :across string
:do (as-utf-8-bytes char byte-out))))
(when null-terminate
(write-byte 0 output)))
(define-condition utf-8-decoding-error (simple-error)
((message :initarg :message)
(byte :initarg :byte :initform nil))
(:report (lambda (err stream)
(format stream (slot-value err 'message)
(slot-value err 'byte)))))
(declaim (inline utf-8-group-size))
(defun utf-8-group-size (byte)
"Determine the amount of bytes that are part of the character
starting with a given byte."
(declare (type fixnum byte)
#.*optimize*)
(cond ((zerop (logand byte #b10000000)) 1)
((= (logand byte #b11100000) #b11000000) 2)
((= (logand byte #b11110000) #b11100000) 3)
((= (logand byte #b11111000) #b11110000) 4)
(t (error 'utf-8-decoding-error :byte byte
:message "Invalid byte at start of character: 0x~X"))))
(defun utf-8-string-length (bytes &key (start 0) (end (length bytes)))
"Calculate the length of the string encoded by the given bytes."
(declare (type (simple-array (unsigned-byte 8) (*)) bytes)
(type fixnum start end)
#.*optimize*)
(loop :with i :of-type fixnum = start
:with string-length = 0
:while (< i end)
:do (progn
(incf (the fixnum string-length) 1)
(incf i (utf-8-group-size (elt bytes i))))
:finally (return string-length)))
(defun get-utf-8-character (bytes group-size &optional (start 0))
"Given an array of bytes and the amount of bytes to use,
extract the character starting at the given start position."
(declare (type (simple-array (unsigned-byte 8) (*)) bytes)
(type fixnum group-size start)
#.*optimize*)
(labels ((next-byte ()
(prog1 (elt bytes start)
(incf start)))
(six-bits (byte)
(unless (= (logand byte #b11000000) #b10000000)
(error 'utf-8-decoding-error :byte byte
:message "Invalid byte 0x~X inside a character."))
(ldb (byte 6 0) byte)))
(case group-size
(1 (next-byte))
(2 (logior (ash (ldb (byte 5 0) (next-byte)) 6)
(six-bits (next-byte))))
(3 (logior (ash (ldb (byte 4 0) (next-byte)) 12)
(ash (six-bits (next-byte)) 6)
(six-bits (next-byte))))
(4 (logior (ash (ldb (byte 3 0) (next-byte)) 18)
(ash (six-bits (next-byte)) 12)
(ash (six-bits (next-byte)) 6)
(six-bits (next-byte)))))))
(defun utf-8-bytes-to-string (bytes-in &key (start 0) (end (length bytes-in)))
"Convert a byte array containing utf-8 encoded characters into
the string it encodes."
(declare (type vector bytes-in)
(type fixnum start end)
#.*optimize*)
(loop :with bytes = (coerce bytes-in '(simple-array (unsigned-byte 8) (*)))
:with buffer = (make-string (utf-8-string-length bytes :start start :end end) :element-type 'character)
:with array-position :of-type fixnum = start
:with string-position :of-type fixnum = 0
:while (< array-position end)
:do (let* ((char (elt bytes array-position))
(current-group (utf-8-group-size char)))
(when (> (+ current-group array-position) end)
(error 'utf-8-decoding-error
:message "Unfinished character at end of byte array."))
(setf (char buffer string-position)
(code-char (get-utf-8-character bytes current-group
array-position)))
(incf string-position 1)
(incf array-position current-group))
:finally (return buffer)))
(defun read-utf-8-string (input &key null-terminated stop-at-eof
(char-length -1) (byte-length -1))
"Read utf-8 encoded data from a byte stream and construct a
string with the characters found. When null-terminated is given
it will stop reading at a null character, stop-at-eof tells it to
stop at the end of file without raising an error, and the
char-length and byte-length parameters can be used to specify the
max amount of characters or bytes to read."
(declare (type stream input)
(type fixnum byte-length char-length)
#.*optimize*)
(let ((buffer (make-array 4 :element-type '(unsigned-byte 8)))
(bytes-read 0)
(string (make-array 64 :element-type 'character
:adjustable t :fill-pointer 0)))
(declare (type fixnum bytes-read))
(loop
(when (or (and (/= -1 byte-length) (>= bytes-read byte-length))
(and (/= -1 char-length) (= char-length (length string))))
(return))
(let ((next-char (read-byte input (not stop-at-eof) :eof)))
(when (or (eq next-char :eof)
(and null-terminated (eq next-char 0)))
(return))
(let ((current-group (utf-8-group-size next-char)))
(incf bytes-read current-group)
(cond ((= current-group 1)
(vector-push-extend (code-char next-char) string))
(t
(setf (elt buffer 0) next-char)
(loop :for i :from 1 :below current-group
:for next-char = (read-byte input nil :eof)
:do (when (eq next-char :eof)
(error 'utf-8-decoding-error
:message "Unfinished character at end of input."))
:do (setf (elt buffer i) next-char))
(vector-push-extend (code-char (get-utf-8-character
buffer current-group))
string))))))
string))
postmodern-20151031-git/doc/ 0000775 0000000 0000000 00000000000 12600736344 0015475 5 ustar 00root root 0000000 0000000 postmodern-20151031-git/doc/cl-postgres.html 0000664 0000000 0000000 00000071000 12600736344 0020623 0 ustar 00root root 0000000 0000000
CL-postgres reference manual
CL-postgres reference manual
The CL-postgres module implements a rather low-level interface
for communicating with a PostgreSQL database server. It is
part of the Postmodern library, but can
be used separately.
Objects of this type represent database
connections.
function
open-database (database user password host &optional (port 5432) (use-ssl :no))
→ database-connection
Create and open a connection for the specified
server, database, and user. use-ssl may be
:no, :yes, or :try, where
:try means 'if the server supports it'. When it is
anything but :no, you must have the CL+SSL
package loaded to initiate the connection.
On SBCL and Clozure CL, the value
:unix may be passed for host, in order
to connect using a Unix domain socket instead of a TCP socket.
function
close-database (database-connection)
Close a database connection. It is advisable to
call this on connections when you are done with them. Otherwise
the open socket will stick around until it is garbage collected,
and no one will tell the database server that we are done
with it.
function
reopen-database (database-connection)
Re-establish a database connection for a
previously closed connection object. (Calling this on a connection
that is still open is harmless.)
function
database-open-p (database-connection)
→ boolean
This method provides access to a hash table that
is associated with the current database connection. When the
connection is closed and re-opened this hash table is reset. The
most obvious use for this is for storing information about the
prepared statements that have been parsed for this connection.
This method returns a mapping (string to string)
containing all the configuration
parameters for the connection.
variable
*unix-socket-dir*
On SBCL, when using the :unix keyword
as host argument when creating a connection, this variable
determines the directory in which CL-Postgres will look for the
socket file.
When using SSL (see open-database), these can
be used to provide client key and certificate files. They can be
either NIL, for no file, or a pathname.
function
wait-for-notification (database-connection)
This function blocks until a notification is
received on the connection. The PostgreSQL LISTEN
command must be used to enable listening for notifications.
function
exec-query (database-connection query &optional (row-reader 'ignore-row-reader))
→ result
Sends the given query to the given connection, and
interprets the results (if there are any) with the given row-reader. If the database returns
information about the amount of rows affected, this is returned as
a second value.
function
prepare-query (database-connection name query)
Parse and plan the given query, and store it under
the given name. Note that prepared statements are per-connection,
so they can only be executed through the same connection that
prepared them.
function
exec-prepared (database-connection name parameters &optional (row-reader 'ignore-row-reader))
→ result
Execute the prepared statement by the given name.
Parameters should be given as a list. Each value in this list
should be of a type that to-sql-string has been
specialised on. (Byte arrays will be passed in their binary form,
without being put through to-sql-string.) The result
of the executing the statement, if any, is interpreted by the
given row reader, and returned. Again,
the number or affected rows is optionally returned as a second
value.
function
unprepare-query (database-connection name)
Close the prepared statement by the given name.
This will free resources and allow the name to be associated with
a new prepared query.
Convert a Lisp value to its textual
unescaped SQL representation. Returns a second value
indicating whether this value should be escaped if it is to be put
directly into a query.
You can define to-sql-string methods
for your own datatypes if you want to be able to pass them to exec-prepared. When a
non-NIL second value is returned, this may be
T to indicate that the first value should simply be
escaped as a string, or a second string providing a type prefix
for the value. (This is used by S-SQL.)
variable
*silently-truncate-rationals*
When a rational number is passed into a query (as
per to-sql-string), but
it can not be expressed within 38 decimal digits (for example
1/3), it will be truncated, and lose some precision.
Set this variable to nil to suppress that behaviour
and raise an error instead.
variable
*query-log*
When debugging, it can be helpful to inspect the
queries that are being sent to the database. Set this variable to
an output stream value (*standard-output*, for
example) to have CL-postgres log every query it makes.
variable
*query-callback*
When profiling or debugging,
the *query-log* may not
give enough information, or reparsing its output may not be
feasible. This variable may be set to a designator of function
taking two arguments. This function will be then called after
every query, and receive query string and internal time units
(as in (CL:GET-INTERNAL-REAL-TIME)) spent in query
as its arguments.
Default value of this variable
is 'LOG-QUERY, which takes
care of *QUERY-LOG*
processing. If you provide custom query callback and wish to
keep *QUERY-LOG*
functionality, you will have to
call LOG-QUERY from your
callback function
CL-postgres knows how to convert commonly used PostgreSQL data
types to Lisp values. This table shows the mapping:
PostgreSQL
Lisp
smallint
integer
integer
integer
bigint
integer
numeric
ratio
real
float
double precision
double-float
boolean
boolean
varchar
string
text
string
bytea
(vector (unsigned-byte 8))
The mapping from PostgreSQL types (identified by OID numbers)
to the functions that interpret them is kept in so-called SQL
readtables. All types for which no reader is defined will be
returned as string values containing their PostgreSQL
representation.
variable
*sql-readtable*
This variable is used to choose the current
readtable. For simple use, you will not have to touch this, but it
is possible that code within a Lisp image requires different
readers in different situations, in which case you can create
separate read tables.
function
copy-sql-readtable (table)
→ readtable
Copies a given readtable.
function
default-sql-readtable ()
→ readtable
Returns the default readtable, containing only the
readers defined by CL-postgres itself.
function
set-sql-reader (oid function &key table binary-p)
Define a new reader for a given type.
table defaults to *sql-readtable*. The
reader function should take a single argument, a string, and
transform that into some kind of equivalent Lisp value. When
binary-p is true, the reader function is supposed to
directly read the binary representation of the value. In most
cases this is not recommended, but if you want to use it: provide
a function that takes a binary input stream and an integer (the
size of the value, in bytes), and reads the value from that
stream. Note that reading less or more bytes than the given size
will horribly break your connection.
function
set-sql-datetime-readers (&key date timestamp timestamp-with-timezone time interval table)
Since there is no widely recognised standard way
of representing dates and times in Common Lisp, and reading these
from string representation is clunky and slow, this function
provides a way to easily plug in binary readers for the
date, time, timestamp, and
interval types. It should be given functions with the
following signatures:
:date (days)
Where days is the amount of days since January
1st, 2000.
:timestamp (useconds)
Timestamps have a microsecond resolution. Again, the zero
point is the start of the year 2000, UTC.
:timestamp-with-timezone
Like :timestamp, but for values of the
'timestamp with time zone' type (which PostgreSQL internally
stores exactly the same as regular timestamps).
:time (useconds)
Refers to a time of day, counting from midnight.
:interval (months days useconds)
An interval is represented as several separate components.
The reason that days and microseconds are separated is that you
might want to take leap seconds into account.
Row readers
Row readers are a way to read and group the results of queries.
Roughly, they are functions that perform the iteration over the
rows and cells in the result, and do something with the
returned values.
macro
row-reader ((fields) &body body)
→ function
Creates a row-reader, using the given name for the
variable. Inside the body this variable refers to a vector of
field descriptions. On top of that, two local functions are bound,
next-row and next-field. The first will
start reading the next row in the result, and returns a boolean
indicating whether there is another row. The second will read and
return one field, and should be passed the corresponding field
description from the fields argument as a parameter.
A row reader should take care to iterate over all
the rows in a result, and within each row iterate over all the
fields. This means it should contain an outer loop that calls
next-row, and every time next-row
returns T it should iterate over the fields vector
and call next-field for every field.
The definition of list-row-reader should
give you an idea what a row reader looks like:
Obviously, row readers should not do
things with the database connection like, say, close it or start a
new query, since it still reading out the results from the current
query.
macro
def-row-reader (name (fields) &body body)
The defun-like variant of row-reader: creates a row
reader and gives it a top-level function name.
method
field-name (field)
→ string
This can be used to get information about the
fields read by a row reader. Given a field description, it returns
the name the database associated with this column.
method
field-type (field)
→ oid
This extracts the PostgreSQL OID
associated with this column. You can, if you really want to, query
the pg_types table to find out more about the types denoted by
OIDs.
function
list-row-reader (socket fields)
→ list
A row reader that builds a list of lists from the
query results.
function
alist-row-reader (socket fields)
→ alist
A row reader that returns a list of alists, which
associate column names with values.
function
ignore-row-reader (socket fields)
A row reader that completely ignores the result of
a query.
When loading large amounts of data into PostgreSQL, it can be done
significantly faster using the bulk copying feature. The drawback to
this approach is that you don't find out about data integrity errors
until the entire batch is completed but sometimes the speed is worth it
function
open-db-writer (db table &optional columns)
Opens a table stream into which rows can be
written one at a time
using db-write-row. db is either
a connection object or a list
of arguments that could be passed to open-database.
table is the name of an existing table into which this writer
will write rows. If you don't have data for all columns, use
columns to indicate those that you do.
function
close-db-writer (writer &key abort)
Closes a bulk writer opened
by open-db-writer. Will close the associated database
connection when it was created for this copier,
or abort is true.
function
db-write-row (writer row-data)
Writes row-data into the table and columns
referenced by the writer. row-data is a list of Lisp objects,
one for each column included when opening the writer. Arrays (the elements
of which must all be the same type) will be serialized into their PostgreSQL
representation before being written into the DB.
Opening or querying a database may raise errors. CL-postgres
will wrap the errors that the server returns in a lisp condition,
and raise conditions of the same type when it detects some problem
itself. Socket errors are let through as they are.
condition
database-error
The type of database-related conditions. For
errors that you may want to catch by type, the
cl-postgres-error package defines a bucket of
subtypes used for specific errors. See the
cl-postgres/package.lisp file for a list.
The condition that caused this error, or
NIL when it was not caused by another condition.
function
database-error-constraint-name (database-error)
→ string
For integrity-violation errors, returns the name
of the constraint that was violated (or nil if no
constraint was found.)
condition
database-connection-error
Subtype of database-error. An error
of this type (or one of its subclasses) is signaled when a query
is attempted with a connection object that is no longer connected,
or a database connection becomes invalid during a query. Always
provides a :reconnect restart, which will cause the
library to make an attempt to restore the connection and re-try
the query.
The following shows an example use of this
feature, a way to ensure that the first connection error causes a
reconnect attempt, while others pass through as normal. A
variation on this theme could continue trying to reconnect, with
successively longer pauses.
The condition that is signalled when a
notification message is received from the PostgreSQL server.
This is a WARNING condition which is caught by
the WAIT-FOR-NOTIFICATION function that implements
synchronous waiting for notifications.
Postmodern is a Common Lisp library for interacting with PostgreSQL databases.
Features are:
Efficient communication with the database server without
need for foreign libraries.
Support for UTF-8 on Unicode-aware Lisp implementations
A syntax for mixing SQL and Lisp code
Convenient support for prepared statements and stored
procedures
A metaclass for simple database-access objects
The biggest differences between this library and CLSQL/CommonSQL are that
Postmodern has no intention of being portable across different SQL
implementations (it embraces non-standard PostgreSQL features), and
approaches extensions like lispy SQL and database access objects
in a quite different way. This library was written because the
CLSQL approach did not really work for me, your mileage may
vary.
02-02-2011:Version
1.17: Another modest maintenance release.
Fixes day-of-week
in simple-date. Makes
the :plistquery
format actually work.
Adds sql-escape
as an exported symbol for client code that needs to escape stuff.
Adds support for multi-dimensional arrays. Adds
the *ignore-unknown-columns*
configuration variable.
02-04-2010:Version
1.16: Introduces a save-dao/transaction,
because the old semantics were broken (originally inside of
transactions, after fixing that outside of them). Add support for
passing vectors as argument to prepared queries, and reading them
from query results. Add :on-update and
:on-delete arguments to !foreign. Add
:plist and :plists query result formats.
Guarantee that deftable definitions
are executed in the order they were defined in. Moves the ieee-floats
and trivial-utf-8
dependencies into the repository, so they don't have to separately
fetched.
02-04-2010: We are moving from common-lisp.net to
marijnhaverbeke.nl, and from darcs to git. New project home: http://marijnhaverbeke.nl/postmodern.
01-03-2009:Version
1.15: Almost a year since the last release. Postmodern is
still alive—it is just so perfect it hardly needs updates
anymore. In this release: Stop depending on the usocket library in
Allegro CL and SBCL, just use the built-in socket bindings
instead. Allow connecting over a Unix socket in SBCL. Support
natural joins in :select. Add :if-exists
argument to :drop-... operators, add support for
:add-column form to :alter-table. Add
:between-symmetric operator. Introduce "ghost slot"
hack to DAO system to support fetching OIDs. Extend
doquery to also handle parameterised queries.
28-08-2008:Version
1.13: A few small fixes and optimisations, and there is once
again a deftable ―
though it has a different role than it used to have.
30-04-2008:Version
1.12: Restores the save-dao function
(though you should still be careful with it), adds supportforSSL
connections, makes some error messages clearer, adds some S-SQL operators, and fixes a few bugs.
19-03-2008:Version
1.10: Note that this release is not entirely
backwards-compatible. It introduces a new, more flexible
approach to DAO objects, a more
pluggable handling of
custom data types, and a bunch of small clean-ups, optimizations,
and enhancements. See the migration guide for details.
Dependencies
The library depends on usocket (except on SBCL and
ACL, where the built-in socket library is used), md5, closer-mop,
bordeaux-threads
if you want thread-safe connection pools, and CL+SSL when
SSL connections are needed.
Postmodern itself is split into four different packages, some
of which can be used independently. Simple-date is a very basic
implementation of date and time objects, used to support storing
and retrieving time-related SQL types. CL-postgres is the low-level library
used for interfacing with a PostgreSQL server over a socket. S-SQL is used to compile s-expressions to
strings of SQL code, escaping any Lisp values inside, and doing as
much as possible of the work at compile time. Finally, Postmodern itself is the library that
tries to put all these things together into a convenient
programming interface.
License
Postmodern is released under a zlib-style license. Which
approximately means you can use the code in whatever way you like,
except for passing it off as your own or releasing a modified
version without indication that it is not the original.
The postmodern-devel can be used for questions, discussion,
bug-reports, patches, or anything else relating to this library.
To subscribe, send a message
to postmodern-devel+subscribe@common-lisp.net.
Or mail the author/maintainer
directly: Marijn
Haverbeke.
Quickstart
This quickstart is intended to give you a feel of the way
coding with Postmodern works. Further details about the workings
of the library can be found in the reference
manual.
Assuming you have already installed it, first load and use the
system:
If you have a PostgreSQL server running on localhost, with a
database called 'testdb' on it, which is accessible for user
'foucault' with password 'surveiller', you can connect like
this:
Which will establish a connection to be used by all code,
except for that wrapped in a with-connection
form, which takes the same arguments but only establishes the
connection locally.
In many contexts, query strings and lists starting with
keywords can be used interchangeably. The lists will be compiled
to SQL. The S-SQL manual describes the
syntax used by these expressions. Lisp values occurring in them are
automatically escaped. In the above query, only constant values
are used, but it is possible to transparently use run-time values
as well:
(defun database-powered-addition (a b)
(query (:select (:+ a b)) :single))
(database-powered-addition 1030 204)
;; => 1234
That last argument, :single, indicates that we
want the result not as a list of lists (for the result rows), but
as a single value, since we know that we are only selecting one
value. Some other options are :rows,
:row, :column, :alists, and
:none. Their precise effect is documented in the reference manual.
You do not have to pull in the whole result of a query at once,
you can also iterate over it with the doquery macro:
(doquery (:select 'x 'y :from 'some-imaginary-table) (x y)
(format t "On this row, x = ~A and y = ~A.~%" x y))
The above defines a class that can be used to handle records in
a table with three columns: name, inhabitants, and sovereign. In
simple cases, the information above is enough to define the table
as well:
(dao-table-definition 'country)
;; => "CREATE TABLE country (
;; name TEXT NOT NULL,
;; inhabitants INTEGER NOT NULL,
;; sovereign TEXT,
;; PRIMARY KEY (name))"
(execute (dao-table-definition 'country))
This defines our table in the database. execute works like query, but
does not expect any results back.
Next, to demonstrate a bit more of the S-SQL syntax, here is
the query the utility function list-tables
uses to get a list of the tables in a database:
(sql (:select 'relname :from 'pg-catalog.pg-class
:inner-join 'pg-catalog.pg-namespace :on (:= 'relnamespace 'pg-namespace.oid)
:where (:and (:= 'relkind "r")
(:not-in 'nspname (:set "pg_catalog" "pg_toast"))
(:pg-catalog.pg-table-is-visible 'pg-class.oid))))
;; => "(SELECT relname FROM pg_catalog.pg_class
;; INNER JOIN pg_catalog.pg_namespace ON (relnamespace = pg_namespace.oid)
;; WHERE ((relkind = 'r') and (nspname NOT IN ('pg_catalog', 'pg_toast'))
;; and pg_catalog.pg_table_is_visible(pg_class.oid)))"
sql is a macro that
will simply compile a query, it can be useful for seeing how your
queries are expanded or if you want to do something unexpected
with them.
As you can see, lists starting with keywords are used to
express SQL commands and operators (lists starting with something
else will be evaluated and then inserted into the query). Quoted
symbols name columns or tables (keywords can also be used but
might introduce ambiguities). The syntax supports subqueries,
multiple joins, stored procedures, etc. See the S-SQL reference manual for a complete
treatment.
Finally, here is an example of the use of prepared
statements:
The defprepared
macro creates a function that takes the same amount of arguments
as there are $X placeholders in the given query. The
query will only be parsed and planned once (per database
connection), which can be faster, especially for complex
queries.
(disconnect-toplevel)
Reference
The reference manuals for the different components of
Postmodern are kept in separate files. For using the library in
the most straightforward way, you only really need to read the Postmodern reference and glance over
the S-SQL reference. The simple-date reference explains the
time-related data types included in Postmodern, and the CL-postgres reference might be useful
if you just want a low-level library for talking to a PostgreSQL
server.
Simple-date has no concept of
time zones. This means that using it is rather error-prone, and if
you really need your time-keeping to be reliable and/or universal
you should either not use the types it provides or think really
hard about the way you handle time zones.
Recently, a lot of work has been done on local-time,
which solves the same problem as simple-date, but does understand
time zones. The 1.0
repository currently has code for integration with
CL-postgres, though this might not be stable yet.
Portability
The Lisp code in Postmodern is theoretically portable across
implementations, and seems to work on all major ones. I am not
actively testing against new releases or obscure implementations,
but if you run into problems you are welcome to contact me through
the mailing
list, and we can try to solve them. Implementations that do
not have meta-object protocol support will not have DAOs, but all
other parts of the library should work (all widely used
implementations do support this).
The library will definitely not work for PostgreSQL versions
older than 7.4 (it uses a client/server protocol that was
introduced in that version). On versions prior to 8.1, retrieving
date and time objects is broken, because their binary
representation was changed. Part of the functionality of insert-dao
(automatic defaulting of unbound slots) only works in PostgreSQL
8.2 and up.
Things that should be implemented
It would be a nice feature if Postmodern could help you with
defining your database schemas and, more importantly, updating
your databases when your code changes. It would theoretically not
be hard to build a function that compares a schema on the Lisp
side with the state of the database, and helps you to
interactively update your database. PostgreSQL has a quite
complete introspection system. Unfortunately it would be a lot of
work to implement this, since databases can contain so many
different types of entities (tables, views, indices, procedures,
constraints, sequences, etc.) which are all created, changed, and
dropped in different ways.
A number of backwards-incompatible changes are introduced in
this version of the library ― there are a few small
cleanups, and the database-access object system has been
completely overhauled.
with-connection
The old with-connection form has been replaced by
what used to be called with-connection*.
This means that if you had code like this...
... since the whole list is now evaluated. Similarly, if you
were using with-connection*, you should remove the
asterisk.
Integrating custom data types
CL-postgres now exports ways
to manipulate the way it reads values from query results. The
old s-sql:sql-ize generic has been moved to
cl-posgres:to-sql-string,
and can be used to control the way values are written out when
passed as arguments to prepared statements or inserted in S-SQL query forms.
simple-date is no
longer depended on by CL-postgres and S-SQL, but uses the above
interface to integrate itself. Load it after loading
CL-postgres, and suitable readers and writers for its types will
be registered. Integrating other date/time libraries is
trivial.
Errors and reconnecting
In previous versions, only the
database-connection-lost conditions offered a
:reconnect restart. There are now various conditions
offering this restart, all subtypes of database-connection-error,
and the library tries its very best to wrap all hard-to-prevent
errors with such a restart (socket errors, database shutdowns).
The goal is that you can use this feature to cleanly and simply
add functionality for recovering from connectivity problems and
server restarts. If you still have issues here, please discuss
them on the mailing list (universal error recovery is rather hard
to test).
There is now also a large set of condition types exported from
the cl-postgres-error package, which can make writing
handler-case forms around database code a lot more
pleasant. See cl-postgres/error.lisp for the list (or
just cause the error you are interested in to be raised, and look
at its type).
The DAO system
This is where upgrading might be somewhat painful. The old
deftable macro has been dropped completely, in favour
of the dao-class
metaclass. The focus of this part of the library has shifted from
defining tables to defining access objects. You
can still generate simple CREATE TABLE statements using the dao-table-definition
function, but this is intended to just be a shortcut. Table
definition is now the responsibility of the library user, not the
library.
So why this regression in functionality? It turned out that
coupling access objects and table definitions like this was not
such a good idea. You might want to create access objects for
views, or for tables with all kinds of complicated constraints.
Adding support for this to deftable would have turned
it into an even bigger behemoth than it already was, and not
fundamentally solve the problem.
So now we have a nice, clean DAO interface, and no
schema-definition interface at all (create-template
and friends were also dropped). The most notable change is
probably that the :auto-id option is gone. This was
very convenient but horribly 'magical'. If you had something like
this:
Or you could explicitly create the id sequence and give the
id field a :col-default of
(:nextval "product_ids"), to have more control over
the id generation.
The above example should give you a basic idea of the new
interface: DAO classes are now created by regular class
definitions. Instead of :type options, column slots
should get :column or :col-type options.
The semantics of creating and inserting DAOs have been slightly
adjusted: There is no magic happening when you create a DAO
instance (it used to fetch id values), except when you give
make-instance a :fetch-defaults keyword
argument, in which case it will query the database for the rows'
default values, and put them in the instance. Usually, it is
cleaner to not use this, since it generates extra queries and does
not work for stuff like serial fields anyway, where no
proper :col-default can be given. When an object is
inserted into the database with insert-dao, some
slots may be unbound. These will then, both in the database and in
the object, be assigned values based on the column defaults. For
example, if you have the above product class:
(defvar *p* (make-instance 'product :name "brick" :weight 2))
;; The id slot is unbound
(insert-dao *p*)
(print (product-id *p*))
;; Here it will have received a new id value
Note that this works even for serial types, since
the defaults are fetched by giving the INSERT statement a
RETURNING clause, so the association between default values and
columns is handled by the database, not the DAO class.
query, execute, and any other function
that would logically need to communicate with the database will
raise a condition of the type database-error
when something goes wrong. As a special case, errors that break
the connection (socket errors, database shutdowns) will be raised
as subtypes of database-connection-error,
providing a :reconnect restart to re-try the
operation that encountered to the error.
Objects of this type represent database connections.
function
connect (database user password host &key (port 5432) pooled-p use-ssl)
→ database-connection
Create a new database connection for the given
user and the database. Port will default
to 5432, which is where most PostgreSQL servers are running. If
pooled-p is T, a connection will be taken
from a pool of connections of this type, if one is available there,
and when the connection is disconnected it will be put back into this
pool instead. use-ssl can be :no,
:yes, or :try, as in open-database,
and defaults to the value of *default-use-ssl*.
variable
*default-use-ssl*
The default for connect's use-ssl
argument. This starts at :no. If you set it to
anything else, be sure to also load the CL+SSL
library.
method
disconnect (database-connection)
Disconnects a normal database connection, or moves
a pooled connection into the pool.
function
connected-p (database-connection)
→ boolean
Returns a boolean indicating whether the given
connection is still connected to the server.
method
reconnect (database-connection)
Reconnect a disconnected database connection. This
is not allowed for pooled connections ― after they are
disconnected they might be in use by some other process, and
should no longer be used.
variable
*database*
Special variable holding the current database.
Most functions and macros operating on a database assume this
binds to a connected database.
macro
with-connection (spec &body body)
Evaluates the body with *database* bound to a
connection as specified by spec, which should be list
that connect can be applied
to.
macro
call-with-connection (spec thunk)
The functional backend to with-connection. Binds *database* to a new connection
as specified by spec, which should be a list that connect can be applied to, and
runs the zero-argument function given as second argument in the
new environment. When the function returns or throws, the new
connection is disconnected.
function
connect-toplevel (database user password host &key (port 5432))
Bind the *database* to a new
connection. Use this if you only need one connection, or if you
want a connection for debugging from the REPL.
Disconnect and remove all connections from the
connection pools.
variable
*max-pool-size*
Set the maximum amount of connections kept in a
single connection pool, where a pool consists of all the
stored connections with the exact same connect arguments. Defaults
to NIL, which means there is no maximum.
Querying
macro
query (query &rest args/format)
→ result
Execute the given query, which can be
either a string or an S-SQL form (list starting
with a keyword). If the query contains placeholders
($1, $2, etc) their values can be given
as extra arguments. If one of these arguments is a keyword
occurring in the table below, it will not be used as a query
argument, but will determine the format in which the results
are returned instead. Any of the following formats can be used, with
the default being :rows:
:none
Ignore the result values.
:lists, :rows
Return a
list of lists, each list containing the values for a
row.
:list, :row
Return a
single row as a list.
:alists
Return a list of alists which map column
names to values, with the names represented as
keywords.
:alist
Return a single row as an alist.
:str-alists
Like
:alists, but use the original column
names.
:str-alist
Return a single row as an alist, with
strings for names.
:plists
Return a list of plists which map column
names to values,with the names represented as keywords.
:plist
Return a single row as a plist.
:column
Return a single column as a list.
:single
Return a single value.
:single!
Like :single,
but raise an error when the number of selected rows is not equal
to 1.
(:dao type)
Return a list of DAOs of the given type. The names of the fields returned by the query must match slots in the DAO class the same way as with query-dao.
(:dao type :single)
Return a single DAO of the given type.
If the database returns information about the
amount rows that were affected, such as with updating or deleting
queries, this is returned as a second value.
macro
execute (query &rest args)
Like query
called with format :none. Returns the amount of
affected rows as its first returned value. (Also returns this
amount as the second returned value, but use of this is
deprecated.)
macro
doquery (query (&rest names) &body body)
Execute the given query (a string or a list
starting with a keyword), iterating over the rows in the result.
The body will be executed with the values in the row bound to the
symbols given in names. To iterate over a
parameterised query, one can specify a list whose car is the
query, and whose cdr contains the arguments. For example:
macro
prepare (query &optional (format :rows))
→ function
Creates a function that can be used as the
interface to a prepared statement. The given query
(either a string or an S-SQL form) may contain
placeholders, which look like $1, $2,
etc. The resulting function takes one argument for every
placeholder in the query, executes the prepared query,
and returns the result in the format specified. (Allowed
formats are the same as for query.)
For queries that have to be run very often,
especially when they are complex, it may help performance since the
server only has to plan them once. See the
PostgreSQL manual for details.
In some cases, the server will complain about not
being able to deduce the type of the arguments in a statement. In
that case you should add type declarations (either with the PostgreSQL's
CAST SQL-conforming syntax or historical ::
syntax, or with S-SQL's :type
construct) to help it out.
Like defprepared,
but allows to specify names of the function arguments as well as arguments
supplied to the query.
(defprepared-with-names user-messages (user &key (limit 10))
("select * from messages
where user_id = $1
order by date desc
limit $2" (user-id user) limit)
:plists)
Execute the given body within a database
transaction, committing it when the body exits normally, and
aborting otherwise. An optional name can be given to the
transaction, which can be used to force a commit or abort before
the body unwinds.
function
commit-transaction (transaction)
Commit the given transaction.
function
abort-transaction (transaction)
Roll back the given transaction.
macro
with-savepoint (name &body body)
Can only be used within a transaction. Establishes
a savepoint with the given name at the start of
body, and binds the same name to a handle
for that savepoint. At the end of body, the savepoint
is released, unless a condition is thrown, in which case it is rolled
back.
function
release-savepoint (savepoint)
Release the given savepoint.
function
rollback-savepoint (savepoint)
Roll back the given savepoint.
function
commit-hooks (transaction-or-savepoint),
setf (commit-hooks transaction-or-savepoint)
An accessor for the transaction or savepoint's list
of commit hooks, each of which should be a function with no required
arguments. These functions will be executed when a transaction is
committed or a savepoint released.
function
abort-hooks (transaction-or-savepoint),
setf (abort-hooks transaction-or-savepoint)
An accessor for the transaction or savepoint's list
of abort hooks, each of which should be a function with no required
arguments. These functions will be executed when a transaction is
aborted or a savepoint rolled back (whether via a non-local transfer
of control or explicitly by either abort-transaction or rollback-savepoint).
Executes body within
a with-transaction
form if no transaction is currently in progress, otherwise simulates
a nested transaction by executing it within a with-savepoint
form. The transaction or savepoint is bound to name if one is
supplied.
function
abort-logical-transaction (transaction-or-savepoint)
Roll back the given logical transaction, regardless of
whether it is an actual transaction or a savepoint.
function
commit-logical-transaction (transaction-or-savepoint)
Commit the given logical transaction, regardless of
whether it is an actual transaction or a savepoint.
variable
*current-logical-transaction*
This is bound to the
current transaction-handle
or savepoint-handle instance representing the
innermost open logical transaction.
macro
ensure-transaction (&body body)
Ensures that body is executed within
a transaction, but does not begin a new transaction if one is
already in progress.
Sets the current schema to namespace and
executes the body. Before executing body the
PostgreSQL's session variable search_path is set to
the given namespace. After executing body the
search_path variable is restored to the original value.
If the keyword :strict is set to T then
the namespace is only the scheme on the search path upon
the body execution. Otherwise the namespace is
just first schema on the search path upon the the body
execution. If :if-not-exist is NIL,
an error is signaled. If :drop-after is T
the namespace is dropped from the database after the
body execution.
function
sequence-next (sequence)
→ integer
Get the next value from a sequence.
The sequence identifier can be either a string or a symbol, in the latter
case it will be converted to a string according to S-SQL rules.
function
coalesce (&rest arguments)
→ value
Returns the first non-NIL, non-NULL
(as in :null) argument, or NIL if none
are present. Useful for providing a fall-back value for the result
of a query, or, when given only one argument, for transforming
:nulls to NIL.
Inspecting the database
function
list-tables (&optional strings-p)
→ list
Returns a list of the tables in the current
database. When strings-p is T, the
names will be given as strings, otherwise as keywords.
function
table-exists-p (name)
→ boolean
Tests whether a table with the given name
exists. The name can be either a string or a symbol.
function
table-description (name &optional schema-name)
→ list
Returns a list of the fields in the named table.
Each field is represented by a list of three elements: the field
name, the type, and a boolean indicating whether the field may be
NULL. Optionally, schema-name can be specified to
restrict the result to fields from the named schema. Without it,
all fields in the table are returned, regardless of their schema.
function
list-sequences (&optional strings-p)
→ list
Returns a list of the sequences in the current
database. When strings-p is T, the names
will be given as strings, otherwise as keywords.
function
sequence-exists-p (name)
→ boolean
Tests whether a sequence with the given name
exists. The name can be either a string or a symbol.
function
list-views (&optional strings-p)
→ list
Returns list of the user defined views in the current
database. When strings-p is T, the names will
be returned as strings, otherwise as keywords.
function
view-exists-p (name)
→ boolean
Tests whether a view with the given name
exists. The name can be either a string or a symbol.
function
list-schemata ()
→ list
Returns list of the user defined schemata (as strings)
and the quantity of existing schemata.
function
schema-exist-p (schema)
→ boolean
Tests the existence of a given schema.
Returns T if the schema exists or NIL
otherwise.
Database access objects
Postmodern contains a simple system for defining CLOS classes
that represent rows in the database. This is not intended as a
full-fledged object-relational magic system ― while serious
ORM systems have their place, they are notoriously hard to get
right, and are outside of the scope of a humble SQL library like
this.
metaclass
dao-class
At the heart of Postmodern's DAO system is the
dao-class metaclass. It allows you to define classes
for your database-access objects as regular CLOS classes. Some of
the slots in these classes will refer to columns in the database.
To specify that a slot refers to a column, give it a
:col-type option containing
an S-SQL type expression (useful if you
want to be able to derive a table definition from the class
definition), or simply a :column option with
value T. Such slots can also take
a :col-default option, used to provide a
database-side default value as an S-SQL expression. You can use
the :col-name initarg (whose unevaluated value will
be passed to to-sql-name) to specify the slot's column's
name.
DAO class definitions support two extra class
options: :table-name to give the name of the table
that the class refers to (defaults to the class name), and
:keys to provide a set of primary keys for the table.
When no primary keys are defined, operations such as update-dao and get-dao will not work.
The (or db-null integer) form is used
to indicate a column can have NULL values.
When inheriting from DAO classes, a subclass' set
of columns also contains all the columns of its superclasses. The
primary key for such a class is the union of its own keys and all
the keys from its superclasses. Classes inheriting from DAO
classes should probably always use the dao-class
metaclass themselves.
When a DAO is created with
make-instance, the :fetch-defaults keyword
argument can be passed, which, when T, will cause a query
to fetch the default values for all slots that refers to columns with
defaults and were not bound through initargs. In some cases, such as
serial columns, which have an implicit default, this will
not work. You can work around this by creating your own sequence, e.g.
"my_sequence", and defining a
(:nextval "my_sequence") default.
Finally, DAO class slots can have an option
:ghost t to specify them as ghost slots. These are
selected when retrieving instances, but not written when updating
or inserting, or even included in the table definition. The only
known use for this to date is for creating the table with
(oids=true), and specify a slot like this:
(oid :col-type integer :ghost t :accessor get-oid)
method
dao-keys (class)
→ list
Returns list of slot names that are the primary key of DAO
class.
method
dao-keys (dao)
→ list
Returns list of values that are the primary key of dao.
method
dao-exists-p (dao)
→ boolean
Test whether a row with the same primary key as
the given dao exists in the database. Will also return
NIL when any of the key slots in the object are
unbound.
method
make-dao (type &rest args &key &allow-other-keys)
→ dao
Combines make-instance with
insert-dao. Return the
created dao.
Create an :around-method for make-dao. The body is executed in
a lexical environment where dao-name is bound
to a freshly created and inserted DAO. The representation of the DAO in the
database is then updated to reflect changes that body might
have introduced. Useful for processing values of slots with the type
serial, which are unknown before insert-dao.
method
get-dao (type &rest keys)
→ dao
Select the DAO object from the row that has the
given primary key values, or NIL if no such row
exists. Objects created by this function will have
initialize-instance called on them (after loading in
the values from the database) without any arguments ― even
:default-initargs are skipped. The same goes for select-dao and query-dao.
macro
select-dao (type &optional (test t) &rest sort)
→ list
Select DAO objects for the rows in the associated
table for which the given test (either an S-SQL expression or a string) holds. When
sorting arguments are given, which can also be S-SQL forms or
strings, these are used to sort the result. (Note that, if you
want to sort, you have to pass the test
argument.)
Like select-dao,
but iterates over the results rather than returning them. For each matching
DAO, body is evaluated with type-var bound to the
DAO instance.
(do-select-dao (('user user) (:> 'score 10000) 'name)
(pushnew user high-scorers))
function
query-dao (type query &rest args)
→ list
Execute the given query (which can be either
a string or an S-SQL expression) and return
the result as DAOs of the given type. If the query
contains placeholders ($1, $2, etc) their values can be given as extra
arguments. The names of the fields returned by the query must
either match slots in the DAO class, or be bound through with-column-writers.
function
do-query-dao (((type type-var) query &rest args) &body body)
→ list
Like query-dao, but
iterates over the results rather than returning them. For each matching DAO,
body is evaluated with type-var bound to the
instance.
Normally,
when get-dao,
select-dao,
or query-dao finds a column
in the database that's not in the DAO class, it will raise an
error. Setting this variable to a non-NIL will cause it to
simply ignore the unknown column.
method
insert-dao (dao)
→ dao
Insert the given dao into the database.
Column slots of the object which are unbound implies the database defaults.
Hence, if these columns has no defaults defined in the database, the
the insertion of the dao will be failed.
(This feature only works on PostgreSQL 8.2 and up.)
method
update-dao (dao)
→ dao
Update the representation of the given dao
in the database to the values in the object. This is not defined for
tables that do not have any non-primary-key columns. Raises an
error when no row matching the dao exists.
function
save-dao (dao)
→ boolean
Tries to insert the given dao using insert-dao. If this raises a
unique key violation error, it tries to update it by using update-dao instead. Be aware
that there is a possible race condition here ― if some
other process deletes the row at just the right moment, the update
fails as well. Returns a boolean telling you whether a new row was
inserted.
This function is unsafe to use inside of a
transaction ― when a row with the given keys already
exists, the transaction will be aborted. Use save-dao/transaction
instead in such a situation.
Acts exactly like save-dao, except that it
protects its attempt to insert the object with a rollback point,
so that a failure will not abort the transaction.
Like save-dao
or save-dao/transaction
but using a different method that doesn't involve a database
exception. This is safe to use both in and outside a transaction,
though it's advisable to always do it in a transaction to prevent a
race condition. The way it works is:
If the object contains unbound slots, we
call insert-dao directly, thus
the behavior is like save-dao.
Otherwise we try to update a record with the same primary key. If
the PostgreSQL returns a non-zero number of rows updated it
treated as the record is already exists in the database, and
we stop here.
If the PostgreSQL returns a zero number of rows updated, it
treated as the record does not exist and we call
insert-dao.
The race condition might occur at step 3 if there's no
transaction: if UPDATE returns zero number of rows updated and
another thread inserts the record at that moment, the insertion
implied by step 3 will fail.
Note, that triggers and rules may affect the number of inserted or
updated rows returned by PostgreSQL, so zero or non-zero number of
affected rows may not actually indicate the existence of
record in the database.
This method returns two values: the DAO object and a boolean
(T if the object was inserted, NIL if
it was updated).
method
delete-dao (dao)
Delete the given dao from the database.
function
dao-table-name (class)
→ string
Get the name of the table associated with
the given DAO class (or symbol naming such a class).
function
dao-table-definition (class)
→ string
Given a DAO class, or the name of one,
this will produce an SQL query string with a definition of the table.
This is just the bare simple definition, so if you need any extra
indices or or constraints, you'll have to write your own queries
to add them.
Provides control over the way get-dao, select-dao, and query-dao read values from the
database. This is not commonly needed, but can be used to reduce
the amount of queries a system makes. writers should
be a list of alternating column names (strings or symbols) and
writers, where writers are either symbols referring to a slot in
the objects, or functions taking two arguments ― an
instance and a value ― which can be used to somehow store
the value in the new instance. When any DAO-fetching function is
called in the body, and columns matching the given
names are encountered in the result, the writers are used instead
of the default behaviour (try and store the value in the slot that
matches the column name).
An example of using this is to add some non-column
slots to a DAO class, and use query-dao within a
with-column-writers form to pull in extra information
about the objects, and immediately store it in the new
instances.
Table definition and creation
It can be useful to have the SQL statements needed to build an
application's tables available from the source code, to do things like
automatically deploying a database. The following macro and
functions allow you to group sets of SQL statements under symbols,
with some shortcuts for common elements in table definitions.
macro
deftable (name &body definition)
Define a table. name can be either a symbol
or a (symbol string) list. In the first case, the table
name is derived from the symbol's name by S-SQL's rules. In the second case, the
name is given explicitly. The body of definitions can contain
anything that evaluates to a string, as well as S-SQL expressions. The
variables *table-name* and
*table-symbol* are bound to
the relevant values in the body. Note that the evaluation of the
definition is ordered, so you'll generally want to create your
table first and then define indices on it.
Add a foreign key to the table being defined.
target-table is the referenced table.
columns is a list of column names or single name in
this table, and, if the columns have different names in
the referenced table, target-columns must be
another list of column names or single column name of the
target-table, or :primary-key to denote
the column(s) of the target-table's primary key
as referenced column(s).
The on-delete and
on-update arguments can be used to specify ON DELETE
and ON UPDATE actions, as per the keywords allowed in create-table. In
addition, the deferrable and initially-deferred
arguments can be used to indicate whether constraint checking can be
deferred until the current transaction completed, and whether this should
be done by default. Note that none of these are really &key
arguments, but rather are picked out of a &rest arg at
runtime, so that they can be specified even when
target-columns is not given.
function
!unique (target-fields &key deferrable initially-deferred)
Constrains one or more columns to only contain
unique (combinations of) values, with deferrable and
initially-deferred defined as in !foreign
function
create-table (symbol)
Creates the table identified by
symbol by executing all forms in
its definition.
function
create-all-tables ()
Creates all defined tables.
function
create-package-tables (package)
Creates all tables identified by symbols
interned in the given package.
variables
*table-name*, *table-symbol*
These variables are bound to the relevant name and
symbol while the forms of a table definition are evaluated. Can be
used to define shorthands like the ones below.
Schemata
Schema allow you to separate tables into differnet name spaces. In
different schemata two tables with the same name are allowed to
exists. The tables can be referred by fully qualified names or
with the macro with-schema. You could
also set the search path
with set-search-path. For listing
end checking there are also the
functions list-schemata
and schema-exist-p. The following
functions allow you to create, drop schemata and to set the search
path.
function
create-schema (schema)
Creates a new schema. Raises an error if the schema is already exists.
function
drop-schema (schema)
Removes a schema. Raises an error if the schema is not empty.
function
get-search-path ()
Retrieve the current search path.
function
set-search-path (path)
Sets the search path to the path. This function is used
by with-schema.
This is the reference manual for the S-SQL component of the postmodern library.
S-SQL provides a lispy syntax for SQL queries, and knows how to
convert various lisp types to their textual SQL representation. It
takes care to do as much of the work as possible at compile-time,
so that at runtime a string concatenation is all that is needed to
produce the final SQL query.
Convert the given form (a list starting with a
keyword) to an SQL query string at compile time, according to the
rules described here.
function
sql-compile (form)
→ string
This is the run-time variant of the sql macro. It converts the given list
to an SQL query, with the same rules except that symbols in this
list do not have to be quoted to be interpreted as
identifiers.
function
sql-template (form)
In cases where you do need to build the query at
run time, yet you do not want to re-compile it all the time, this
function can be used to compile it once and store the result. It
takes an S-SQL form, which may contain $$ placeholder
symbols, and returns a function that takes one argument for every
$$. When called, this returned function produces an
SQL string in which the placeholders have been replaced by the
values of the arguments.
function
enable-s-sql-syntax (&optional (char #\Q))
Modifies the current readtable to add a #Q syntax
that is read as (sql ...). The character to use can
be overridden by passing an argument.
function
sql-escape-string (string)
→ string
Escapes
a string for inclusion in a PostgreSQL query.
method
sql-escape (value)
→ string
A generalisation of sql-escape-string.
Looks at the type of the value passed, and properly writes it out
it for inclusion in an SQL query. Symbols will be converted to SQL
names.
variable
*standard-sql-strings*
Used to configure whether S-SQL will use standard
SQL strings (just replace #\' with ''), or backslash-style
escaping. Setting this to NIL is always safe, but
when the server is configured to allow standard strings
(compile-time parameter 'standard_conforming_strings'
is 'on', which will become the default in future
versions of PostgreSQL), the noise in queries can be reduced by
setting this to T.
variable
*escape-sql-names-p*
Determines whether double quotes are added around
column, table, and function names in queries. May be
T, in which case every name is escaped,
NIL, in which case none is, or :auto,
which causes only reserved
words to be escaped.. The default value is :auto.
Be careful when binding this with let and such
― since a lot of SQL compilation tends to happen at
compile-time, the result might not be what you expect.
function
sql-type-name (type)
→ string
Create the SQL equivalent of the given Lisp type,
if one is known. See types.
function
to-sql-name (name &optional (escape-p *escape-sql-names-p*))
→ string
Convert a symbol or string to a name that can be
used as an SQL identifier by converting all non-alphanumeric
characters to underscores. Also lowercases the name to make
queries look a bit less hideous. When a second argument is given,
this overrides the current value of *escape-sql-names-p*.
function
from-sql-name (string)
→ keyword
Convert a string that represents an SQL identifier
to a keyword by uppercasing it and converting the underscores to
dashes.
macro
register-sql-operators (arity &rest names)
Define simple SQL operators. Arity is one of
:unary (like 'not'),
:unary-postfix (the operator comes after the
operand), :n-ary (like '+': the operator
falls away when there is only one operand), :2+-ary
(like '=', which is meaningless for one operand), or
:n-or-unary (like '-', where the
operator is kept in the unary case). After the arity may follow
any number of operators, either just a keyword, in which case the
downcased symbol name is used as the SQL operator, or a
two-element list containing a keyword and a name string.
SQL Types
S-SQL knows the SQL equivalents to a number of Lisp types, and
defines some extra types that can be used to denote other SQL
types. The following table shows the correspondence:
This is a type of which only the keyword
:null is a member. It is used to represent NULL
values from the database.
SQL Syntax
An S-SQL form is converted to a query through the following rules:
Lists starting with a keyword are operators. They are
expanded as described below if they are known, otherwise they
are expanded in the standard way: operator(arguments,
...)
Quoted symbols or keywords are interpreted as names of
columns or tables, and converted to strings with to-sql-name.
Anything else is evaluated and the resulting Lisp value is
converted to its textual SQL representation (or an error is
raised when there is no rule for converting objects of this
type). Self-quoting atoms may be converted to strings at
compile-time.
These are expanded as infix operators. When
meaningful, they allow more than two arguments. :-
can also be used as a unary operator to negate a value. Note that
the arguments to :union, :union-all,
:intersect, and :except should be
queries (:select forms).
Note that you'll have to escape pipe characters to
enter them as keywords. S-SQL handles the empty keyword symbol
(written :||) specially, and treats it
like :\|\|, so that it can be written without
escapes. With :\|, this doesn't work.
sql-op:~, :not (arg)
Unary operators for bitwise and logical
negation.
sql-op:~, :~*, :!~, :!~* (string pattern)
Regular expression matching operators. The
exclamation mark means 'does not match', the asterisk makes the
match case-insensitive.
sql-op:like, :ilike (string pattern)
Simple SQL string matching operators
(:ilike is case-insensitive).
sql-op:@@
Fast Text Search match operator.
sql-op:desc (column)
Used to invert the meaning of an operator in an :order-by clause.
sql-op:nulls-first, :nulls-last (column)
Used to determine where :null values
appear in an :order-by
clause.
sql-op:as (form name &rest fields)
Assigns a name to a column or table in a :select form. When fields are
given, they are added after the name, in parentheses. For example,
(:as 'table1 't1 'foo 'bar) becomes table1 AS
t1(foo, bar). When you need to specify types for the
fields, you can do something like (:as 'table2 't2 ('foo
integer)). Note that names are quoted, types are not (when
using sql-compile or
sql-template, you can
leave out the quotes entirely).
sql-op:exists (query)
The EXISTS operator. Takes a query as an argument,
and returns true or false depending on whether that query returns
any rows.
sql-op:is-null (arg)
Test whether a value is null.
sql-op:not-null (arg)
Test whether a value is not null.
sql-op:in (value set)
Test whether a value is in a set of values.
sql-op:not-in (value set)
Inverse of the above.
sql-op:set (&rest elements)
Denote a set of values. This one has two
interfaces. When the elements are known at compile-time, they can
be given as multiple arguments to the operator. When they are not,
a single argument that evaluates to a list should be used.
sql-op:[] (form start &optional end)
Dereference an array value. If end is
provided, extract a slice of the array.
sql-op:extract (unit form)
Extract
a field from a date/time value. For example, (:extract
:month (:now)).
sql-op:case (&rest clauses)
A conditional expression. Clauses should take the
form (test value). If test is :else,
an ELSE clause will be generated.
sql-op:between (n start end)
Test whether a value lies between two other
values.
sql-op:between-symmetric (n start end)
Works
like :between, except that the
start value is not required to be less than the end value.
sql-op:dot (&rest names)
Can be used to combine multiple names into a name
of the form A.B to refer to a column in a table, or a table in a
schema. Note that you can also just use a symbol with a dot in
it.
sql-op:type (form type)
Add a type declaration to a value, as in in
"4.3::real". The second argument is not evaluated normally, but
put through sql-type-name to get a type
identifier.
sql-op:raw (string)
Insert a string as-is into the query. This can be
useful for doing things that the syntax does not support, or to
re-use parts of a query across multiple queries:
Creates a select query. The arguments are split on
the keywords found among them. The group of arguments immediately
after :select is interpreted as the expressions that
should be selected. After this, an optional :distinct
may follow, which will cause the query to only select distinct
rows, or alternatively :distinct-on followed by a
group of row names. Next comes the optional keyword
:from, followed by at least one table name and then
any number of join statements. Join statements start with one of
:left-join, :right-join,
:inner-join, :outer-join or
:cross-join, then a table name or subquery, then the
keyword :on or :using, if applicable,
and then a form. A join can be preceded by :natural
(leaving off the
:on clause) to use a natural join. After the joins an
optional :where followed by a single form may occur.
And finally :group-by and :having can
optionally be specified. The first takes any number of arguments,
and the second only one. An example:
In S-SQL limit is not part of the select operator,
but an extra operator that is applied to a query (this works out
better when limiting the union or intersection of multiple
queries, same for sorting). It limits the number of results to the
amount given as the second argument, and optionally offsets the
result by the amount given as the third argument.
sql-op:order-by (query &rest exprs)
Order the results of a query by the given
expressions. See :desc for when
you want to invert an ordering.
sql-op:over (form
&rest args)
Over, partition-by and window are so-called window
functions. A window function performs a calculation across a set
of table rows that are somehow related to the current row.
Locks the selected rows against concurrent updates. This will prevent the rows
from being modified or deleted by other transactions until the current transaction ends. The :of
keyword should be followed by one or more table names. If provided, PostgreSQL will lock
these tables instead of the ones detected in the select statement. The :nowait keyword should be
provided by itself (with no argument attached to it), after all the :of arguments . If :nowait
is provided, PostgreSQL will throw an error if a table cannot be locked immediately, instead of
pausing until it's possible.
Create a stored procedure. The argument and return
types are interpreted as type names and not evaluated. Stability
should be one of :immutable, :stable, or
:volatile (see the
PostgreSQL documentation). For example, a function that gets foobars by
id:
Insert a row into a table. When the second
argument is :set, the other arguments should be
alternating field names and values, otherwise it should be a :select form that will produce the
values to be inserted. Example:
It is possible to add :returning,
followed by a list of field names or expressions, at the end of
the :insert-into form. This will cause the query to
return the values of these expressions as a single row.
sql-op:update (table &rest rest)
Update values in a table. After the table name
there should follow the keyword :set and any number
of alternating field names and values, like
for :insert-into. Next comes
the optional keyword :from, followed by at least one table name
and then any number of join statements, like for
:select. After the joins,
an optional :where keyword followed by the condition,
and :returning keyword followed by a list of field
names or expressions indicating values to be returned as query
result.
sql-op:delete-from (table &rest rest)
Delete rows from the named table. Can be given a
:where argument followed by a condition, and a
:returning argument, followed by one or more
expressions that should be returned for every deleted row.
Create a new table. After the table name a list of
column definitions follows, which are lists that start with a
name, followed by one or more of the following keyword
arguments:
:type
This one is required. It specifies the type of the column.
Use a type like (or db-null integer) to specify a
column that may have NULL values.
:default
Provides a default value for the field.
:unique
If this argument is non-nil, the values of the column must
be unique.
:primary-key
When non-nil, the column is a primary key of the table.
:check
Adds a constraint to this column. The value provided for
this argument must be an S-SQL expression that returns a boolean
value. It can refer to other columns in the table if
needed.
:references
Adds a foreign key constraint to this table. The argument
provided must be a list of the form (target &optional
on-delete on-update). When target is a symbol, it names
the table to whose primary key this constraint refers. When it
is a list, its first element is the table, and its second
element the column within that table that the key refers to.
on-delete and on-update can be used to
specify the actions that must be taken when the row that this
key refers to is deleted or changed. Allowed values are
:restrict, :set-null,
:set-default, :cascade, and
:no-action.
After the list of
columns, zero or more extra options (table constraints) can be
specified. These are lists starting with one of the following
keywords:
:check
Adds a constraint to the table. Takes a single S-SQL
expression that produces a boolean as its argument.
:primary-key
Specifies a primary key for the table. The arguments to this
option are the names of the columns that this key consists
of.
:unique
Adds a unique constraint to a group of columns. Again, the
arguments are a list of symbols that indicate the relevant
columns.
:foreign-key
Create a foreign key. The arguments should have the form
(columns target &optional on-delete on-update),
where columns is a list of columns that are used by
this key, while the rest of the arguments have the same meaning
as they have in the :references option for
columns.
Every list can start with :constraint
name to create a specifically named constraint.
Note that, unlike most other operators,
:create-table expects most of its arguments to be
unquoted symbols. The exception to this is the value of
:check constraints: These must be normal S-SQL
expressions, which means that any column names they contain should
be quoted. When programmatically generating table definitions,
sql-compile is usually
more practical than the sql
macro.
Alters named table. Currently changing a column's data
type is not supported. The meaning of args depends on
action:
:add-column
Adds column to table.
args should be a column in the same form as for
:create-table.
:drop-column
Drops a column from the
table.
:add-constraint
Adds a named constraint
to the table.
:drop-constraint
Drops constraint. First
of args should name a constraint to be dropped;
second, optional argument specifies behaviour regarding
objects dependent on the constraint and it may
equal :cascade or :restrict.
:add
Adds an unnamed constraint to
table. args should be a constraint in the same
form as for :create-table.
(This is for backwards-compatibility, you should use named constraints.)
Drops the named table. You may optionally pass
:if-exists before the name to suppress the error
message.
sql-op:create-index (name &rest args)
Create an index on a table. After the name of the
index the keyword :on should follow, with the table
name after it. Then the keyword :fields, followed by
one or more column names. Optionally, a :where clause
with a condition can be added at the end to make a partial
index.
sql-op:create-unique-index (name
&rest args)
Works like :create-index, except that
the index created is unique.
sql-op:drop-index (name)
Drop an index. Takes an :if-exists
argument like :drop-table.
Create a sequence with the given name. The rest of
the arguments control the way the sequence selects values.
sql-op:drop-sequence (name)
Drop a sequence. You may pass
:if-exists as an extra first argument.
sql-op:create-view (name query)
Create a view from an S-SQL-style query.
sql-op:drop-view (name)
Drop a view. Takes optional
:if-exists argument.
sql-op:set-constraints (state &rest
constraints)
Configure whether deferrable constraints should be
checked when a statement is executed, or when the transaction
containing that statement is completed. The provided state must be
either :immediate, indicating the former, or
:deferred, indicating the latter. The constraints
must be either the names of the constraints to be configured, or
unspecified, indicating that all deferrable constraints should be
thus configured.
sql-op:listen (channel)
Tell the server to listen for notification events
on channel channel, a string, on the current
connection.
sql-op:unlisten (channel)
Stop listening for events on channel.
sql-op:notify (channel &optional payload)
Signal a notification event on
channel channel, a string. The
optional payload string can be used to send
additional event information to the listeners.
Simple-date provides types (CLOS classes) for dates,
timestamps, and intervals similar to the ones SQL databases use,
in order to be able to store and read these to and from a database
in a straighforward way. A few obvious operations are defined on
these types.
The most glaring defect of this library is its ignorance of
time zones. It pretends the whole world lives in UTC. Use with
care.
When this libary is loaded after CL-postgres, it will register suitable
SQL readers and writers for the associated database types.
Represents a date, with no time-of-day information.
function
encode-date (year month day)
→ date
Creates a date object.
function
decode-date (date)
→ (values year month day)
Extract the elements from a date object.
function
day-of-week (date)
→ integer
Determine the day of the week that the given date
falls on. Value ranges from 0 to 6, with 0 being Sunday and 6
being Saturday.
Timestamp type
class
timestamp
Represents an absolute timestamp, with a
millisecond precision.
function
encode-timestamp (year month day &optional (hour 0) (minute 0) (second 0) (millisecond 0))
→ timestamp
Create a timestamp. No negative values or values
outside of an arguments normal range (i.e. 60 for minutes, 1000
for milliseconds) should be passed.
function
decode-timestamp (timestamp)
→ (values year month day hour minute second millisecond)
Decode a timestamp into its components.
function
timestamp-to-universal-time (timestamp)
→ universal-time
Convert a timestamp to the corresponding
universal-time, rounding to seconds. Note that this will treat the
timestamp as if it were in UTC.
function
universal-time-to-timestamp (universal-time)
→ timestamp
Create a timestamp from a universal time. Again,
the resulting timestamp should be treated as if it were in
UTC.
Interval type
class
interval
An interval represents a period of time. It
contains both an absolute part in milliseconds (days, weeks,
minutes, etc are always the same length), and a relative part for
months and years ― the amount of time that a month or year
represents is not always the same.
Create an interval. Arguments may be negative and
of any size.
function
decode-interval (interval)
→ (values year month day hour minute second millisecond)
Decompose an interval into parts. Note that these
may be different from the parameters that created it ― an
interval of 3600 seconds is the same as one of 1 hour.
Operations
To prevent a proliferation of different function names, generic
functions are used for operations on time values. The semantics of
these differ for the type of the operands.
method
time-add (a b)
→ value
Adds two time-related objects. Adding an interval
to a date or timestamp will return a new date or timestamp,
increased by the value of the interval. Adding two intervals
returns a new interval with the sum of the two arguments. Integers
can be used in place of intervals, and will be interpreted as an
amount of milliseconds.
method
time-subtract (a b)
→ value
Subtracts time-related objects from each other.
Subtracting two dates or timestamps results in an interval that
represents the difference between them. Similarly, subtracting two
intervals also gives their difference.
method
time= (a b)
→ boolean
Compare two time-related values, returns a boolean
indicating whether they denote the same time or period.
method
time< (a b)
→ boolean
Compare two time-related values, returns a boolean
indicating whether the first is less than the second.
method
time> (a b)
→ boolean
Compare two time-related values, returns a boolean
indicating whether the first is greater than the second.