Commit 1f0cfc2eec5d79879f3e03a43a9ef5a9a90a3a8b - cl-postmodern

Import Upstream version 20161031 Sébastien Villemot 3 years ago

14 changed file(s) with 935 addition(s) and 104 deletion(s). Raw diff Collapse all Expand all

+196

-37

cl-postgres/interpret.lisp less more

6	6
7	7	(defparameter sql-readtable (make-hash-table)
8	8	"The exported special var holding the current read table, a hash
9		mapping OIDs to (binary-p . interpreter-function) pairs.")
	9	mapping OIDs to instances of the type-interpreter class that contain
	10	functions for retreiving values from the database in text, and
	11	possible binary, form.")
10	12
11	13	(defun interpret-as-text (stream size)
12	14	"This interpreter is used for types that we have no specific

14	16	unknown types are passed in text form.)"
15	17	(enc-read-string stream :byte-length size))
16	18
17		(let ((default-interpreter (cons nil #'interpret-as-text)))
18		(defun type-interpreter (oid)
19		"Returns a pair representing the interpretation rules for this
20		type. The car is a boolean indicating whether the type should be
21		fetched as binary, and the cdr is a function that will read the value
22		from the socket and build a Lisp value from it."
	19	(defclass type-interpreter ()
	20	((oid :initarg :oid :accessor type-interpreter-oid)
	21	(use-binary :initarg :use-binary :accessor type-interpreter-use-binary)
	22	(binary-reader :initarg :binary-reader :accessor type-interpreter-binary-reader)
	23	(text-reader :initarg :text-reader :accessor type-interpreter-text-reader))
	24	(:documentation "Information about type interpreter for types coming
	25	back from the database. use-binary is either T for binary, nil for
	26	text, or a function of no arguments to be called to determine if
	27	binary or text should be used. The idea is that there will always be
	28	a text reader, there may be a binary reader, and there may be times
	29	when one wants to use the text reader."))
	30
	31	(defun interpreter-binary-p (interp)
	32	"If the interpreter's use-binary field is a function, call it and
	33	return the value, otherwise, return T or nil as appropriate."
	34	(let ((val (type-interpreter-use-binary interp)))
	35	(typecase val
	36	(function (funcall val))
	37	(t val))))
	38
	39	(defun interpreter-reader (interp)
	40	"Determine if we went the text or binary reader for this type
	41	interpreter and return the appropriate reader."
	42	(if (interpreter-binary-p interp)
	43	(type-interpreter-binary-reader interp)
	44	(type-interpreter-text-reader interp)))
	45
	46	(let ((default-interpreter (make-instance 'type-interpreter
	47	:oid :default
	48	:use-binary nil
	49	:text-reader #'interpret-as-text)))
	50	(defun get-type-interpreter (oid)
	51	"Returns a type-interpreter containing interpretation rules for
	52	this type."
23	53	(gethash oid sql-readtable default-interpreter)))
24	54
25	55	(defun set-sql-reader (oid function &key (table sql-readtable) binary-p)
26	56	"Add an sql reader to a readtable. When the reader is not binary, it
27	57	is wrapped by a function that will read the string from the socket."
28	58	(setf (gethash oid table)
29		(if binary-p
30		(cons t function)
31		(cons nil (lambda (stream size)
32		(funcall function
33		(enc-read-string stream :byte-length size))))))
	59	(make-instance 'type-interpreter
	60	:oid oid
	61	:use-binary binary-p
	62	:binary-reader
	63	(when binary-p function)
	64	:text-reader
	65	(if binary-p
	66	'interpret-as-text
	67	(lambda (stream size)
	68	(funcall function
	69	(enc-read-string stream :byte-length size))))))
34	70	table)
35	71
36	72	(defmacro binary-reader (fields &body value)

91	127	(define-interpreter 1042 "bpchar" string)
92	128	(define-interpreter 1043 "varchar" string)
93	129
	130	(defun read-row-value (stream size)
	131	(declare (type stream stream)
	132	(type integer size)
	133	(ignore size))
	134	(let ((num-fields (read-uint4 stream)))
	135	(loop for i below num-fields
	136	collect (let ((oid (read-uint4 stream))
	137	(size (read-int4 stream)))
	138	(declare (type (signed-byte 32) size))
	139	(if (eq size -1)
	140	:null
	141	(funcall (interpreter-reader (get-type-interpreter oid)) stream size))))))
	142
	143	;; "row" types
	144	(defparameter read-row-values-as-binary nil
	145	"Controls whether row values (as in select row(1, 'foo') ) should be
	146	received from the database in text or binary form. The default value
	147	is nil, specifying that the results be sent back as text. Set this
	148	to t to cause the results to be read as binary.")
	149
	150	(set-sql-reader 2249 #'read-row-value :binary-p (lambda () read-row-values-as-binary))
	151
	152	(defmacro with-binary-row-values (&body body)
	153	"Helper macro to locally set read-row-values-as-binary to t while
	154	executing body so that row values will be returned as binary."
	155	`(let ((read-row-values-as-binary t))
	156	,@body))
	157
	158	(defmacro with-text-row-values (&body body)
	159	"Helper macro to locally set read-row-values-as-binary to nil while
	160	executing body so that row values will be returned as t."
	161	`(let ((read-row-values-as-binary nil))
	162	,@body))
	163
	164	(defun read-binary-bits (stream size)
	165	(declare (type stream stream)
	166	(type integer size))
	167	(let ((byte-count (- size 4))
	168	(bit-count (read-uint4 stream)))
	169	(let ((bit-bytes (read-bytes stream byte-count))
	170	(bit-array (make-array (list bit-count) :element-type 'bit)))
	171	(loop for i below bit-count
	172	do (let ((cur-byte (ash i -3))
	173	(cur-bit (ldb (byte 3 0) i)))
	174	(setf (aref bit-array i)
	175	(ldb (byte 1 (logxor cur-bit 7)) (aref bit-bytes cur-byte)))))
	176	bit-array)))
	177
	178	(set-sql-reader 1560 #'read-binary-bits :binary-p t)
	179	(set-sql-reader 1562 #'read-binary-bits :binary-p t)
	180
	181	(defun read-binary-array-value (stream size)
	182	(declare (type stream stream)
	183	(type integer size)
	184	(ignore size))
	185	(let ((num-dims (read-uint4 stream))
	186	(has-null (read-uint4 stream))
	187	(element-type (read-uint4 stream)))
	188	(cond
	189	((zerop num-dims)
	190	;; Should we return nil or a (make-array nil) when num-dims is
	191	;; 0? Returning nil for now.
	192	nil)
	193	(t
	194	(let* ((array-dims
	195	(loop for i below num-dims
	196	collect (let ((dim (read-uint4 stream))
	197	(lb (read-uint4 stream)))
	198	(declare (ignore lb))
	199	dim)))
	200	(num-items (reduce #'* array-dims)))
	201	(let ((results (make-array array-dims)))
	202	(loop for i below num-items
	203	do (let ((size (read-int4 stream)))
	204	(declare (type (signed-byte 32) size))
	205	(setf (row-major-aref results i)
	206	(if (eq size -1)
	207	:null
	208	(funcall (interpreter-reader (get-type-interpreter element-type)) stream size)))))
	209	results))))))
	210
	211	(dolist (oid '(
	212	1000 ;; boolean array
	213	1001 ;; bytea array
	214	1002 ;; char array
	215	1003 ;; name (internal PG type) array
	216	1005 ;; int2 array
	217	1007 ;; integer array
	218	1009 ;; text array
	219	1014 ;; bpchar array
	220	1015 ;; varchar array
	221	1016 ;; int8 array
	222	1017 ;; point array
	223	1018 ;; lseg array
	224	1020 ;; box array
	225	1021 ;; float4 array
	226	1022 ;; float8 array
	227	1028 ;; oid array
	228	1115 ;; timestamp array
	229	1182 ;; date array
	230	1187 ;; interval array
	231	1561 ;; bit array
	232	1563 ;; varbit array
	233	1231 ;; numeric array
	234	))
	235	(set-sql-reader oid #'read-binary-array-value :binary-p t))
	236
	237	;; 2287 record array
	238	;;
	239	;; NOTE: need to treat this separately because if we want the record
	240	;; (row types) to come back as text, we have to read the array value
	241	;; as text.
	242	(set-sql-reader 2287 #'read-binary-array-value :binary-p (lambda () read-row-values-as-binary))
	243
	244	(define-interpreter 600 "point" ((point-x-bits uint 8)
	245	(point-y-bits uint 8))
	246	(list (cl-postgres-ieee-floats:decode-float64 point-x-bits)
	247	(cl-postgres-ieee-floats:decode-float64 point-y-bits)))
	248
	249	(define-interpreter 601 "lseg" ((point-x1-bits uint 8)
	250	(point-y1-bits uint 8)
	251	(point-x2-bits uint 8)
	252	(point-y2-bits uint 8))
	253	(list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
	254	(cl-postgres-ieee-floats:decode-float64 point-y1-bits))
	255	(list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
	256	(cl-postgres-ieee-floats:decode-float64 point-y2-bits))))
	257
	258	(define-interpreter 603 "box" ((point-x1-bits uint 8)
	259	(point-y1-bits uint 8)
	260	(point-x2-bits uint 8)
	261	(point-y2-bits uint 8))
	262	(list (list (cl-postgres-ieee-floats:decode-float64 point-x1-bits)
	263	(cl-postgres-ieee-floats:decode-float64 point-y1-bits))
	264	(list (cl-postgres-ieee-floats:decode-float64 point-x2-bits)
	265	(cl-postgres-ieee-floats:decode-float64 point-y2-bits))))
	266
94	267	(define-interpreter 700 "float4" ((bits uint 4))
95	268	(cl-postgres-ieee-floats:decode-float32 bits))
96	269	(define-interpreter 701 "float8" ((bits uint 8))

164	337	(+ +start-of-2000+ (* days-since-2000 +seconds-in-day+)))
165	338	:timestamp (lambda (useconds-since-2000)
166	339	(+ +start-of-2000+ (floor useconds-since-2000 1000000)))
	340	:timestamp-with-timezone (lambda (useconds-since-2000)
	341	(+ +start-of-2000+ (floor useconds-since-2000 1000000)))
167	342	:interval (lambda (months days useconds)
168	343	(multiple-value-bind (sec us) (floor useconds 1000000)
169		`((:months ,months) (:days ,days) (:seconds ,sec) (:useconds ,us)))))
	344	`((:months ,months) (:days ,days) (:seconds ,sec) (:useconds ,us))))
	345	:time (lambda (usecs)
	346	(multiple-value-bind (seconds usecs)
	347	(floor usecs 1000000)
	348	(multiple-value-bind (minutes seconds)
	349	(floor seconds 60)
	350	(multiple-value-bind (hours minutes)
	351	(floor minutes 60)
	352	`((:hours ,hours) (:minutes ,minutes) (:seconds ,seconds) (:microseconds ,usecs)))))))
170	353
171	354	;; Readers for a few of the array types
172	355

202	385	(dim (if arr (loop :for x := arr :then (car x) :while (consp x) :collect (length x)) '(0))))
203	386	(make-array dim :initial-contents arr))))))
204	387
205		;; Integral array types
206		(let ((read-integral (read-array-value #'parse-integer)))
207		(dolist (oid '(1561 1005 1007 1016 1028))
208		(set-sql-reader oid read-integral)))
209
210		;; String array types
211		(let ((read-strings (read-array-value #'identity)))
212		(dolist (oid '(1014 1002 1009 1015))
213		(set-sql-reader oid read-strings)))
214
215		;; Floating point arrays
216		(set-sql-reader 1231 (read-array-value 'read-from-string))
217		(set-sql-reader 1021 (read-array-value (lambda (x) (float (read-from-string x)))))
218		;; Bit of a hack, really. CL needs a proper float parser.
219		(flet ((read-as-double (str)
220		(loop :for ch :across str :for i :from 0 :do
221		(when (char= ch #\e) (setf (char str i) #\d)))
222		(coerce (read-from-string str) 'double-float)))
223		(set-sql-reader 1022 (read-array-value #'read-as-double)))
224
225		;; Boolean arrays
226		(flet ((read-as-bool (str) (equal str "t")))
227		(set-sql-reader 1000 (read-array-value #'read-as-bool)))
228
229	388	;; Working with tables.
230	389
231	390	(defun copy-sql-readtable (&optional (table sql-readtable))

-0

cl-postgres/package.lisp less more

44	44	#:set-sql-datetime-readers
45	45	#:serialize-for-postgres
46	46	#:to-sql-string
	47	#:read-row-values-as-binary
	48	#:with-binary-row-values
	49	#:with-text-row-values
47	50	#:silently-truncate-rationals
48	51	#:query-callback
49	52	#:query-log

+10

-6

cl-postgres/protocol.lisp less more

233	233	((name :initarg :name :accessor field-name)
234	234	(type-id :initarg :type-id :accessor field-type)
235	235	(interpreter :initarg :interpreter :accessor field-interpreter)
236		(receive-binary-p :initarg :receive-binary-p :accessor field-binary-p))
	236	(receive-binary-p :initarg :receive-binary-p :reader field-binary-p))
237	237	(:documentation "Description of a field in a query result."))
238	238
239	239	(defun read-field-descriptions (socket)

253	253	(size (read-uint2 socket))
254	254	(type-modifier (read-uint4 socket))
255	255	(format (read-uint2 socket))
256		(interpreter (type-interpreter type-id)))
	256	(interpreter (get-type-interpreter type-id)))
257	257	(declare (ignore table-oid column size type-modifier format)
258	258	(type string name)
259	259	(type (unsigned-byte 32) type-id))
260	260	(setf (elt descriptions i)
261		(make-instance 'field-description :name name :type-id type-id
262		:interpreter (cdr interpreter)
263		:receive-binary-p (car interpreter)))))
	261	(if (interpreter-binary-p interpreter)
	262	(make-instance 'field-description :name name :type-id type-id
	263	:interpreter (type-interpreter-binary-reader interpreter)
	264	:receive-binary-p t)
	265	(make-instance 'field-description :name name :type-id type-id
	266	:interpreter (type-interpreter-text-reader interpreter)
	267	:receive-binary-p nil)))))
264	268	descriptions))
265	269
266	270	(defun terminate-connection (socket)

445	449	(message-case socket
446	450	;; RowDescription
447	451	(#\T (setf row-description (read-field-descriptions socket)))
448		;; NoData
	452	;; NoData
449	453	(#\n))
450	454	(unless (= (length parameters) n-parameters)
451	455	(error 'database-error

+20

-3

cl-postgres/public.lisp less more

79	79	:remote-filename path)))
80	80
81	81	#+sbcl
	82	(defun get-host-address (host)
	83	"Returns valid IPv4 or IPv6 address for the host."
	84	;; get all IPv4 and IPv6 addresses as a list
	85	(let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
	86	;; remove protocols for which we don't have an address
	87	(addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
	88	;; Return the first one or nil,
	89	;; but actually, it shouln't return nil, because
	90	;; get-host-by-name should signal NAME-SERVICE-ERROR condition
	91	;; if there isn't any address for the host.
	92	(first addresses)))
	93
	94
	95	#+sbcl
82	96	(defun inet-socket-connect (host port)
83		(let ((sock (make-instance 'sb-bsd-sockets:inet-socket
	97	(let* ((host-ent (get-host-address host))
	98	(sock (make-instance (ecase (sb-bsd-sockets:host-ent-address-type host-ent)
	99	(2 'sb-bsd-sockets:inet-socket)
	100	(10 'sb-bsd-sockets:inet6-socket))
84	101	:type :stream :protocol :tcp))
85		(host (sb-bsd-sockets:host-ent-address (sb-bsd-sockets:get-host-by-name host))))
86		(sb-bsd-sockets:socket-connect sock host port)
	102	(address (sb-bsd-sockets:host-ent-address host-ent)))
	103	(sb-bsd-sockets:socket-connect sock address port)
87	104	(sb-bsd-sockets:socket-make-stream
88	105	sock :input t :output t :buffering :full :element-type '(unsigned-byte 8))))
89	106

+77

-0

cl-postgres/simple-date-tests.lisp less more

	0
	1	(defpackage :cl-postgres-simple-date-tests
	2	(:use :common-lisp :fiveam :cl-postgres :cl-postgres-error :simple-date)
	3	(:export #:prompt-connection #:test-connection))
	4
	5	(in-package :cl-postgres-simple-date-tests)
	6
	7	(defparameter test-connection '("test" "test" "" "localhost"))
	8
	9	(defun prompt-connection (&optional (list test-connection))
	10	(flet ((ask (name pos)
	11	(format query-io "~a (enter to keep '~a'): " name (nth pos list))
	12	(finish-output query-io)
	13	(let ((answer (read-line query-io)))
	14	(unless (string= answer "") (setf (nth pos list) answer)))))
	15	(format query-io "~%To run this test, you must configure a database connection.~%")
	16	(ask "Database name" 0)
	17	(ask "User" 1)
	18	(ask "Password" 2)
	19	(ask "Hostname" 3)))
	20
	21	(defmacro with-simple-date-readtable (&body body)
	22	`(let ((sql-readtable (simple-date-cl-postgres-glue:simple-date-sql-readtable)))
	23	,@body))
	24
	25	(defmacro with-test-connection (&body body)
	26	`(let ((connection (apply 'open-database test-connection)))
	27	(with-simple-date-readtable
	28	(unwind-protect (progn ,@body)
	29	(close-database connection)))))
	30
	31	(def-suite :cl-postgres-simple-date)
	32	(in-suite :cl-postgres-simple-date)
	33
	34	(test row-timestamp-without-time-zone-binary
	35	(with-test-connection
	36	(with-binary-row-values
	37	(is (time= (caaar (exec-query connection "select row('2010-04-05 14:42:21.500'::timestamp without time zone)"
	38	'list-row-reader))
	39	(encode-timestamp 2010 4 5 14 42 21 500))))))
	40
	41	(test row-timestamp-with-time-zone-binary
	42	(with-test-connection
	43	(exec-query connection "set time zone 'GMT'")
	44	(with-binary-row-values
	45	(destructuring-bind (gmt pdt)
	46	(caar
	47	(exec-query
	48	connection
	49	(concatenate 'string
	50	"select row('2010-04-05 14:42:21.500'::timestamp with time zone at time zone 'GMT', "
	51	" '2010-04-05 14:42:21.500'::timestamp with time zone at time zone 'PST')")
	52	'list-row-reader))
	53	(is (time= gmt (encode-timestamp 2010 4 5 14 42 21 500)))
	54	(is (time= pdt (encode-timestamp 2010 4 5 6 42 21 500)))))))
	55
	56	(test row-timestamp-without-time-zone-array-binary
	57	(with-test-connection
	58	(with-binary-row-values
	59	(is (time= (elt (caaar (exec-query connection "select row(ARRAY['2010-04-05 14:42:21.500'::timestamp without time zone])"
	60	'list-row-reader)) 0)
	61	(encode-timestamp 2010 4 5 14 42 21 500))))))
	62
	63	(test row-time-binary
	64	(with-test-connection
	65	(with-binary-row-values
	66	(is (time= (caaar (exec-query connection "select row('05:00'::time)"
	67	'list-row-reader))
	68	(encode-time-of-day 5 0))))))
	69
	70	(test row-timestamp-binary
	71	(with-test-connection
	72	(with-binary-row-values
	73	(is (time= (caaar (exec-query connection "select row('2010-04-05 14:42:21.500'::timestamp)"
	74	'list-row-reader))
	75	(encode-timestamp 2010 4 5 14 42 21 500))))))
	76

+503

-10

cl-postgres/tests.lisp less more

0	0	(defpackage :cl-postgres-tests
1		(:use :common-lisp :Eos :simple-date :cl-postgres :cl-postgres-error)
2		(:export #:prompt-connection))
	1	(:use :common-lisp :fiveam :cl-postgres :cl-postgres-error)
	2	(:export #:prompt-connection #:test-connection #:with-test-connection))
3	3
4	4	(in-package :cl-postgres-tests)
5	5

19	19
20	20	;; Adjust the above to some db/user/pass/host/[port] combination that
21	21	;; refers to a valid postgresql database, then after loading the file,
22		;; run the tests with (Eos:run! :cl-postgres)
	22	;; run the tests with (fiveam:run! :cl-postgres)
23	23
24	24	(def-suite :cl-postgres)
25	25	(in-suite :cl-postgres)

28	28	`(let ((connection (apply 'open-database test-connection)))
29	29	(unwind-protect (progn ,@body)
30	30	(close-database connection))))
	31
	32	(defmacro with-default-readtable (&body body)
	33	`(let ((sql-readtable (default-sql-readtable)))
	34	,@body))
31	35
32	36	(test connect-sanity
33	37	(with-test-connection

53	57	(is (eq nil (nth-value 1 (to-sql-string 10)))))
54	58
55	59	(test date-query
56		(with-test-connection
57		(destructuring-bind ((a b c))
58		(exec-query connection "select '1980-02-01'::date, '2010-04-05 14:42:21.500'::timestamp, '2 years -4 days'::interval"
59		'list-row-reader)
60		(is (time= a (encode-date 1980 2 1)))
61		(is (time= b (encode-timestamp 2010 4 5 14 42 21 500)))
62		(is (time= c (encode-interval :year 2 :day -4))))))
	60	(with-default-readtable
	61	(with-test-connection
	62	(destructuring-bind ((a b c))
	63	(exec-query connection "select '1980-02-01'::date, '2010-04-05 14:42:21.500'::timestamp, '2 years -4 days'::interval"
	64	'list-row-reader)
	65	(is (= a 2527200000))
	66	(is (= b 3479467341))
	67	(is (equal c '((:MONTHS 24) (:DAYS -4) (:SECONDS 0) (:USECONDS 0))))))))
63	68
64	69	(test alist-row-reader
65	70	(with-test-connection

126	131	(is (equal (exec-query connection "select (30,40)" 'list-row-reader)
127	132	'(("(30,40)"))))))
128	133
	134	(test sql-reader-binary
	135	(with-test-connection
	136	(with-binary-row-values
	137	(let ((sql-readtable (copy-sql-readtable)))
	138	(set-sql-reader 2249 (lambda (text)
	139	(with-input-from-string (standard-input text)
	140	(read-char) ;; opening paren
	141	(let ((x (read)))
	142	(read-char) ;; comma
	143	(cons x (read))))))
	144	(is (equal (exec-query connection "select (10,20)" 'list-row-reader)
	145	'(((10 . 20))))))
	146	(is (equal (exec-query connection "select (30,40)" 'list-row-reader)
	147	'(((30 40))))))))
	148
129	149	(test bulk-writer
130	150	(with-test-connection
131	151	(exec-query connection "create table test (a int, b text, c date, d timestamp, e int[])")

144	164	(close-db-writer stream))
145	165	(print (exec-query connection "select * from test"))
146	166	(exec-query connection "drop table test")))
	167
	168	(test row-boolean-array
	169	(with-test-connection
	170	(is (equalp (exec-query connection "select row(ARRAY[TRUE, FALSE, TRUE])" 'list-row-reader)
	171	'(("(\"{t,f,t}\")"))))))
	172
	173	(test row-boolean-array-binary
	174	(with-test-connection
	175	(with-binary-row-values
	176	(is (equalp (exec-query connection "select row(ARRAY[TRUE, FALSE, TRUE])" 'list-row-reader)
	177	'(((#(T NIL T)))))))))
	178
	179	(test cast-to-bits
	180	(with-test-connection
	181	(is (equalp (exec-query connection "select cast(255 as bit(8)), cast(-44 as bit(128))" 'list-row-reader)
	182	'((#*11111111
	183	#*11111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111010100))))
	184	(is (equalp (exec-query connection "select row(cast(32 as bit(12)))" 'list-row-reader)
	185	'(("(000000100000)"))))
	186	(is (equalp (exec-query connection "select ARRAY[cast(32 as bit(16))]" 'list-row-reader)
	187	'((#(#*0000000000100000)))))
	188	(is (equalp (exec-query connection "select row(ARRAY[cast(32 as bit(16))])" 'list-row-reader)
	189	'(("({0000000000100000})"))))))
	190
	191	(test cast-to-bits-binary
	192	(with-test-connection
	193	(with-binary-row-values
	194	(is (equalp (exec-query connection "select cast(255 as bit(8)), cast(-44 as bit(128))" 'list-row-reader)
	195	'((#*11111111
	196	#*11111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111010100))))
	197	(is (equalp (exec-query connection "select row(cast(32 as bit(12)))" 'list-row-reader)
	198	'(((#*000000100000)))))
	199	(is (equalp (exec-query connection "select ARRAY[cast(32 as bit(16))]" 'list-row-reader)
	200	'((#(#*0000000000100000)))))
	201	(is (equalp (exec-query connection "select row(ARRAY[cast(32 as bit(16))])" 'list-row-reader)
	202	'(((#(#*0000000000100000)))))))))
	203
	204	(test cast-to-varbits
	205	(with-test-connection
	206	(is (equalp (exec-query connection "select 255::bit(8)::varbit(8), 44::bit(128)::varbit(128)" 'list-row-reader)
	207	'((#*11111111
	208	#*00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000101100))))
	209	(is (equalp (exec-query connection "select row(32::bit(12)::varbit(12))" 'list-row-reader)
	210	'(("(000000100000)"))))
	211	(is (equalp (exec-query connection "select ARRAY[32::bit(16)::varbit(16)]" 'list-row-reader)
	212	'((#(#*0000000000100000)))))
	213	(is (equalp (exec-query connection "select row(ARRAY[32::bit(16)::varbit(16)])" 'list-row-reader)
	214	'(("({0000000000100000})"))))))
	215
	216	(test cast-to-varbits-binary
	217	(with-test-connection
	218	(with-binary-row-values
	219	(is (equalp (exec-query connection "select 255::bit(8)::varbit(8), 44::bit(128)::varbit(128)" 'list-row-reader)
	220	'((#*11111111
	221	#*00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000101100))))
	222	(is (equalp (exec-query connection "select row(32::bit(12)::varbit(12))" 'list-row-reader)
	223	'(((#*000000100000)))))
	224	(is (equalp (exec-query connection "select ARRAY[32::bit(16)::varbit(16)]" 'list-row-reader)
	225	'((#(#*0000000000100000)))))
	226	(is (equalp (exec-query connection "select row(ARRAY[32::bit(16)::varbit(16)])" 'list-row-reader)
	227	'(((#(#*0000000000100000)))))))))
	228
	229
	230
	231	(test row-integer-array
	232	(with-test-connection
	233	(is (equalp (exec-query connection "select row(ARRAY[1,2,4,8])" 'list-row-reader)
	234	'(("(\"{1,2,4,8}\")"))))))
	235
	236	(test row-integer-array-binary
	237	(with-test-connection
	238	(with-binary-row-values
	239	(is (equalp (exec-query connection "select row(ARRAY[1,2,4,8])" 'list-row-reader)
	240	'(((#(1 2 4 8)))))))))
	241
	242	(test row-string-array
	243	(with-test-connection
	244	(is (equalp (exec-query connection "select row(ARRAY['foo', 'bar', 'baz'])" 'list-row-reader)
	245	'(("(\"{foo,bar,baz}\")"))))))
	246
	247	(test row-string-array-binary
	248	(with-test-connection
	249	(with-binary-row-values
	250	(is (equalp (exec-query connection "select row(ARRAY['foo', 'bar', 'baz'])" 'list-row-reader)
	251	'(((#("foo" "bar" "baz")))))))))
	252
	253	(test row-bpchar-array
	254	(with-test-connection
	255	(is (equalp (exec-query connection "select row(ARRAY[cast('foo' as bpchar)])" 'list-row-reader)
	256	'(("({foo})"))))))
	257
	258	(test row-bpchar-array-binary
	259	(with-test-connection
	260	(with-binary-row-values
	261	(is (equalp (exec-query connection "select row(ARRAY[cast('foo' as bpchar)])" 'list-row-reader)
	262	'(((#("foo")))))))))
	263
	264	(test row-varchar-array
	265	(with-test-connection
	266	(is (equalp (exec-query connection "select row(ARRAY['foo'::varchar])" 'list-row-reader)
	267	'(("({foo})"))))))
	268
	269	(test row-varchar-array-binary
	270	(with-test-connection
	271	(with-binary-row-values
	272	(is (equalp (exec-query connection "select row(ARRAY['foo'::varchar])" 'list-row-reader)
	273	'(((#("foo")))))))))
	274
	275	(test row-oid-array
	276	(with-test-connection
	277	(is (equalp (exec-query connection "select row(ARRAY[1234::oid, 5678::oid])" 'list-row-reader)
	278	'(("(\"{1234,5678}\")"))))))
	279
	280	(test row-oid-array-binary
	281	(with-test-connection
	282	(with-binary-row-values
	283	(is (equalp (exec-query connection "select row(ARRAY[1234::oid, 5678::oid])" 'list-row-reader)
	284	'(((#(1234 5678)))))))))
	285
	286	(test row-int2-array
	287	(with-test-connection
	288	(is (equalp (exec-query connection "select row(ARRAY[1234::int2])" 'list-row-reader)
	289	'(("({1234})"))))))
	290
	291	(test row-int2-array-binary
	292	(with-test-connection
	293	(with-binary-row-values
	294	(is (equalp (exec-query connection "select row(ARRAY[1234::int2])" 'list-row-reader)
	295	'(((#(1234)))))))))
	296
	297	(test row-int8-array
	298	(with-test-connection
	299	(is (equalp (exec-query connection "select row(ARRAY[123456789012::int8])" 'list-row-reader)
	300	'(("({123456789012})"))))))
	301
	302	(test row-int8-array-binary
	303	(with-test-connection
	304	(with-binary-row-values
	305	(is (equalp (exec-query connection "select row(ARRAY[123456789012::int8])" 'list-row-reader)
	306	'(((#(123456789012)))))))))
	307
	308	(test row-float-array
	309	(with-test-connection
	310	(is (equalp (exec-query connection "select row(ARRAY[3.14::float])" 'list-row-reader)
	311	'(("({3.14})"))))))
	312
	313	(test row-float-array-binary
	314	(with-test-connection
	315	(with-binary-row-values
	316	(is (equalp (exec-query connection "select row(ARRAY[3.14::float])" 'list-row-reader)
	317	'(((#(3.14d0)))))))))
	318
	319	(test row-double-array
	320	(with-test-connection
	321	(is (equalp (exec-query connection "select row(ARRAY[cast(3.14 as double precision)])" 'list-row-reader)
	322	'(("({3.14})"))))))
	323
	324	(test row-double-array-binary
	325	(with-test-connection
	326	(with-binary-row-values
	327	(is (equalp (exec-query connection "select row(ARRAY[cast(3.14 as double precision)])" 'list-row-reader)
	328	'(((#(3.14d0)))))))))
	329
	330	(test row-date-array
	331	(with-default-readtable
	332	(with-test-connection
	333	(is (equalp (elt (exec-query connection "select row(ARRAY['1980-02-01'::date])" 'list-row-reader) 0)
	334	'("({1980-02-01})"))))))
	335
	336	(test row-date-array-binary
	337	(with-default-readtable
	338	(with-test-connection
	339	(with-binary-row-values
	340	(is (= (elt (caaar (exec-query connection "select row(ARRAY['1980-02-01'::date])" 'list-row-reader)) 0)
	341	2527200000))))))
	342
	343	(test row-timestamp
	344	(with-test-connection
	345	(is (equalp (exec-query connection "select row('2010-04-05 14:42:21.500'::timestamp)"
	346	'list-row-reader)
	347	'(("(\"2010-04-05 14:42:21.5\")"))))))
	348
	349	(test row-timestamp-without-time-zone
	350	(with-test-connection
	351	(is (equalp (exec-query connection "select row('2010-04-05 14:42:21.500'::timestamp without time zone)"
	352	'list-row-reader)
	353	'(("(\"2010-04-05 14:42:21.5\")"))))))
	354
	355	(test row-timestamp-with-time-zone
	356	(with-test-connection
	357	(exec-query connection "set time zone 'GMT'")
	358	(is (equalp (exec-query connection "select row('2010-04-05 14:42:21.500'::timestamp with time zone)"
	359	'list-row-reader)
	360	'(("(\"2010-04-05 14:42:21.5+00\")"))))))
	361
	362	(test row-timestamp-with-time-zone-binary
	363	(with-default-readtable
	364	(with-test-connection
	365	(exec-query connection "set time zone 'GMT'")
	366	(with-binary-row-values
	367	(destructuring-bind (gmt pdt)
	368	(caar
	369	(exec-query
	370	connection
	371	(concatenate 'string
	372	"select row('2010-04-05 14:42:21.500'::timestamp with time zone at time zone 'GMT', "
	373	" '2010-04-05 14:42:21.500'::timestamp with time zone at time zone 'PST')")
	374	'list-row-reader))
	375	(is (equalp (multiple-value-list gmt)
	376	'(3479467341)))
	377	(is (equalp (multiple-value-list pdt)
	378	'(3479438541))))))))
	379
	380	(test row-timestamp-array
	381	(with-default-readtable
	382	(with-test-connection
	383	(is (equalp (elt (exec-query connection "select row(ARRAY['2010-04-05 14:42:21.500'::timestamp])"
	384	'list-row-reader) 0)
	385	'("(\"{\"\"2010-04-05 14:42:21.5\"\"}\")"))))))
	386
	387	(test row-timestamp-array-binary
	388	(with-default-readtable
	389	(with-binary-row-values
	390	(with-test-connection
	391	(is (equalp (elt (exec-query connection "select row(ARRAY['2010-04-05 14:42:21.500'::timestamp])"
	392	'list-row-reader) 0)
	393	'((#(3479467341)))))))))
	394
	395	(test row-timestamp-without-time-zone-array
	396	(with-test-connection
	397	(is (equalp (elt (exec-query connection "select row(ARRAY['2010-04-05 14:42:21.500'::timestamp without time zone])"
	398	'list-row-reader) 0)
	399	'("(\"{\"\"2010-04-05 14:42:21.5\"\"}\")")))))
	400
	401	(test row-time
	402	(with-test-connection
	403	(is (equalp (exec-query connection "select row('05:00'::time)"
	404	'list-row-reader)
	405	'(("(05:00:00)"))))))
	406
	407	(test row-interval-array
	408	(with-default-readtable
	409	(with-test-connection
	410	(with-binary-row-values
	411	(is (equalp (elt (caaar (exec-query connection "select row(ARRAY['2 years -4 days'::interval])"
	412	'list-row-reader)) 0)
	413	'((:MONTHS 24) (:DAYS -4) (:SECONDS 0) (:USECONDS 0))))))))
	414
	415	(defparameter random-byte-count 8192)
	416
	417	(test write-bytea
	418	(with-test-connection
	419	(exec-query connection "create table test (a bytea)")
	420	(unwind-protect
	421	(let ((random-bytes (make-array random-byte-count :element-type '(unsigned-byte 8))))
	422	(loop for i below random-byte-count
	423	do (setf (aref random-bytes i)
	424	(random #x100)))
	425	(prepare-query connection "bytea-insert" "insert into test values ($1)")
	426	(exec-prepared connection "bytea-insert" (list random-bytes))
	427	(is (equalp (exec-query connection "select a from test;" 'list-row-reader)
	428	`((,random-bytes)))))
	429	(exec-query connection "drop table test"))))
	430
	431	(defun vector-to-hex-string (vec)
	432	(with-output-to-string (s)
	433	(map nil (lambda (x)
	434	(format s "~(~2,\'0x~)" x))
	435	vec)
	436	s))
	437
	438	(test write-row-bytea
	439	(with-test-connection
	440	(exec-query connection "create table test (a bytea)")
	441	(let ((random-byte-count 16))
	442	(unwind-protect
	443	(let ((random-bytes (make-array random-byte-count :element-type '(unsigned-byte 8))))
	444	(loop for i below random-byte-count
	445	do (setf (aref random-bytes i)
	446	(random #x100)))
	447	(prepare-query connection "bytea-insert" "insert into test values ($1)")
	448	(exec-prepared connection "bytea-insert" (list random-bytes))
	449	(is (equalp (exec-query connection "select row(a) from test;" 'list-row-reader)
	450	`((,(concatenate 'string
	451	"(\"\\\\x"
	452	(vector-to-hex-string random-bytes)
	453	"\")"))))))
	454	(exec-query connection "drop table test")))))
	455
	456	(test write-row-array-bytea
	457	(with-test-connection
	458	(exec-query connection "create table test (a bytea)")
	459	(let ((random-byte-count 16))
	460	(unwind-protect
	461	(let ((random-bytes (make-array random-byte-count :element-type '(unsigned-byte 8))))
	462	(loop for i below random-byte-count
	463	do (setf (aref random-bytes i)
	464	(random #x100)))
	465	(prepare-query connection "bytea-insert" "insert into test values ($1)")
	466	(exec-prepared connection "bytea-insert" (list random-bytes))
	467	(is (equalp (exec-query connection "select row(ARRAY[a]) from test;" 'list-row-reader)
	468	`(((#(,random-bytes)))))))
	469	(exec-query connection "drop table test")))))
	470
	471	(test write-row-array-bytea
	472	(with-test-connection
	473	(with-binary-row-values
	474	(exec-query connection "create table test (a bytea)")
	475	(unwind-protect
	476	(let ((random-bytes (make-array random-byte-count :element-type '(unsigned-byte 8))))
	477	(loop for i below random-byte-count
	478	do (setf (aref random-bytes i)
	479	(random #x100)))
	480	(prepare-query connection "bytea-insert" "insert into test values ($1)")
	481	(exec-prepared connection "bytea-insert" (list random-bytes))
	482	(is (equalp (exec-query connection "select row(ARRAY[a]) from test;" 'list-row-reader)
	483	`(((#(,random-bytes)))))))
	484	(exec-query connection "drop table test")))))
	485
	486	(test write-row-array-bytea-binary
	487	(with-test-connection
	488	(with-binary-row-values
	489	(exec-query connection "create table test (a bytea)")
	490	(unwind-protect
	491	(let ((random-bytes (make-array random-byte-count :element-type '(unsigned-byte 8))))
	492	(loop for i below random-byte-count
	493	do (setf (aref random-bytes i)
	494	(random #x100)))
	495	(prepare-query connection "bytea-insert" "insert into test values ($1)")
	496	(exec-prepared connection "bytea-insert" (list random-bytes))
	497	(is (equalp (exec-query connection "select row(ARRAY[a]) from test;" 'list-row-reader)
	498	`(((#(,random-bytes)))))))
	499	(exec-query connection "drop table test")))))
	500
	501	(test row-name-array
	502	(with-test-connection
	503	(is (equalp (exec-query connection "select row(ARRAY['foo'::name])" 'list-row-reader)
	504	'(("({foo})"))))))
	505
	506	(test row-name-array-binary
	507	(with-test-connection
	508	(with-binary-row-values
	509	(is (equalp (exec-query connection "select row(ARRAY['foo'::name])" 'list-row-reader)
	510	'(((#("foo")))))))))
	511
	512	(test point
	513	(with-test-connection
	514	(is (equalp (exec-query connection "select point(1,2)" 'list-row-reader)
	515	'(((1.0d0 2.0d0)))))))
	516
	517	(test row-point
	518	(with-test-connection
	519	(is (equalp (exec-query connection "select row(point(1,2))" 'list-row-reader)
	520	'(("(\"(1,2)\")"))))))
	521
	522	(test row-point-binary
	523	(with-test-connection
	524	(with-binary-row-values
	525	(is (equalp (exec-query connection "select row(point(1,2))" 'list-row-reader)
	526	'((((1.0d0 2.0d0)))))))))
	527
	528	(test row-point-array
	529	(with-test-connection
	530	(is (equalp (exec-query connection "select row(ARRAY[point(1,2)])" 'list-row-reader)
	531	'(("(\"{\"\"(1,2)\"\"}\")"))))))
	532
	533	(test row-point-array-binary
	534	(with-test-connection
	535	(with-binary-row-values
	536	(is (equalp (exec-query connection "select row(ARRAY[point(1,2)])" 'list-row-reader)
	537	'(((#((1.0d0 2.0d0))))))))))
	538
	539	(test lseg
	540	(with-test-connection
	541	(is (equalp (exec-query connection "select lseg(point(1,2),point(3,4))" 'list-row-reader)
	542	'((((1.0d0 2.0d0) (3.0d0 4.0d0))))))))
	543
	544	(test row-lseg
	545	(with-test-connection
	546	(is (equalp (exec-query connection "select row(lseg(point(1,2),point(3,4)))" 'list-row-reader)
	547	'(("(\"[(1,2),(3,4)]\")"))))))
	548
	549	(test row-lseg-binary
	550	(with-test-connection
	551	(with-binary-row-values
	552	(is (equalp (exec-query connection "select row(lseg(point(1,2),point(3,4)))" 'list-row-reader)
	553	'(((((1.0d0 2.0d0) (3.0d0 4.0d0))))))))))
	554
	555	(test row-lseg-array
	556	(with-test-connection
	557	(is (equalp (exec-query connection "select row(ARRAY[lseg(point(1,2),point(3,4))])" 'list-row-reader)
	558	'(("(\"{\"\"[(1,2),(3,4)]\"\"}\")"))))))
	559
	560	(test row-lseg-array-binary
	561	(with-test-connection
	562	(with-binary-row-values
	563	(is (equalp (exec-query connection "select row(ARRAY[lseg(point(1,2),point(3,4))])" 'list-row-reader)
	564	'(((#(((1.0d0 2.0d0) (3.0d0 4.0d0)))))))))))
	565
	566	(test box
	567	(with-test-connection
	568	(is (equalp (exec-query connection "select box(point(1,2),point(3,4))" 'list-row-reader)
	569	'((((3.0d0 4.0d0) (1.0d0 2.0d0))))))))
	570
	571	(test row-box
	572	(with-test-connection
	573	(is (equalp (exec-query connection "select row(box(point(1,2),point(3,4)))" 'list-row-reader)
	574	'(("(\"(3,4),(1,2)\")"))))))
	575
	576	(test row-box-binary
	577	(with-test-connection
	578	(with-binary-row-values
	579	(is (equalp (exec-query connection "select row(box(point(1,2),point(3,4)))" 'list-row-reader)
	580	'(((((3.0d0 4.0d0) (1.0d0 2.0d0))))))))))
	581
	582	(test row-box-array
	583	(with-test-connection
	584	(is (equalp (exec-query connection "select row(ARRAY[box(point(1,2),point(3,4))])" 'list-row-reader)
	585	'(("(\"{(3,4),(1,2)}\")"))))))
	586
	587	(test row-box-array-binary
	588	(with-test-connection
	589	(with-binary-row-values
	590	(is (equalp (exec-query connection "select row(ARRAY[box(point(1,2),point(3,4))])" 'list-row-reader)
	591	'(((#(((3.0d0 4.0d0) (1.0d0 2.0d0)))))))))))
	592
	593	(test row-array-nulls
	594	(with-test-connection
	595	(is (equalp (exec-query connection "select row((ARRAY[1,3,4])[5:99])" 'list-row-reader)
	596	'(("({})"))))))
	597
	598	(test row-array-nulls-binary
	599	(with-test-connection
	600	(cl-postgres::with-binary-row-values
	601	(is (equalp (exec-query connection "select row((ARRAY[1,3,4])[5:99])" 'list-row-reader)
	602	'(((NIL))))))))
	603
	604	(test row-array-nulls-binary-2
	605	(with-test-connection
	606	(cl-postgres::with-binary-row-values
	607	(is (equalp (exec-query connection "select row(ARRAY[NULL, NULL]);" 'list-row-reader)
	608	'(((#(:null :null)))))))))
	609
	610	(test row-array-table-nulls-binary
	611	(with-binary-row-values
	612	(with-test-connection
	613	(exec-query connection "create table test (a integer[])")
	614	(unwind-protect
	615	(progn
	616	(prepare-query connection "integer-array-insert" "insert into test values ($1)")
	617	(exec-prepared connection "integer-array-insert" (list "{{0,0},{0,0}}"))
	618	(exec-prepared connection "integer-array-insert" (list "{{1,1}}"))
	619	(exec-prepared connection "integer-array-insert" (list "{{2,2}, {2,2}}"))
	620	(exec-prepared connection "integer-array-insert" (list "{{3,3}}"))
	621	(exec-prepared connection "integer-array-insert" (list "{{4,4}}"))
	622	(is (equalp
	623	(exec-query
	624	connection
	625	"select row(a[2:45]) from test"
	626	'list-row-reader)
	627	'(((#2A((0 0)))) ((NIL)) ((#2A((2 2)))) ((NIL)) ((NIL))))))
	628	(exec-query connection "drop table test")))))
	629
	630	(test array-row-text
	631	(with-test-connection
	632	(is (equalp (exec-query connection "select array_agg(row(1,2,3));" 'list-row-reader)
	633	'(("{\"(1,2,3)\"}"))))))
	634
	635	(test array-row-binary
	636	(with-test-connection
	637	(cl-postgres::with-binary-row-values
	638	(is (equalp (exec-query connection "select array_agg(row(1,2,3));" 'list-row-reader)
	639	'((#((1 2 3)))))))))

+22

-12

cl-postgres.asd less more

26	26	(:file "interpret" :depends-on ("communicate" "ieee-floats"))
27	27	(:file "protocol" :depends-on ("interpret" "messages" "errors"))
28	28	(:file "public" :depends-on ("protocol"))
29		(:file "bulk-copy" :depends-on ("public"))))))
30
31		(defsystem :cl-postgres-tests
32		:depends-on (:cl-postgres :eos :simple-date)
33		:components
34		((:module :cl-postgres
35		:components ((:file "tests")))))
36
37		(defmethod perform ((op asdf:test-op) (system (eql (find-system :cl-postgres))))
38		(asdf:oos 'asdf:load-op :cl-postgres-tests)
39		(funcall (intern (string :prompt-connection) (string :cl-postgres-tests)))
40		(funcall (intern (string :run!) (string :Eos)) :cl-postgres))
	29	(:file "bulk-copy" :depends-on ("public")))))
	30	:in-order-to ((test-op (test-op :cl-postgres-tests)
	31	(test-op :cl-postgres-simple-date-tests))))
41	32
42	33	(defmethod perform :after ((op asdf:load-op) (system (eql (find-system :cl-postgres))))
43	34	(when (and (find-package :simple-date)
44	35	(not (find-symbol (symbol-name '#:+postgres-day-offset+) :simple-date)))
45	36	(asdf:oos 'asdf:load-op :simple-date-postgres-glue)))
	37
	38	(defsystem :cl-postgres-tests
	39	:depends-on (:cl-postgres :fiveam)
	40	:components
	41	((:module :cl-postgres
	42	:components ((:file "tests"))))
	43	:perform (test-op (o c)
	44	(uiop:symbol-call :cl-postgres-tests '#:prompt-connection)
	45	(uiop:symbol-call :fiveam '#:run! :cl-postgres)))
	46
	47	(defsystem :cl-postgres-simple-date-tests
	48	:depends-on (:cl-postgres :cl-postgres-tests :fiveam :simple-date)
	49	:components
	50	((:module :cl-postgres
	51	:components ((:file "simple-date-tests"))))
	52	:perform (test-op (o c)
	53	(uiop:symbol-call :cl-postgres-simple-date-tests '#:prompt-connection)
	54	(uiop:symbol-call :fiveam '#:run! :cl-postgres-simple-date)))
	55

-10

doc/index.html less more

228	228	href="http://marijnhaverbeke.nl/postmodern/postmodern-latest.tgz">http://marijnhaverbeke.nl/postmodern/postmodern-latest.tgz</a>
229	229	always contains a snapshot of the current repository head.</p>
230	230
231		<h2><a name="support"></a>Support and mailing lists</h2>
232
233		<p>The postmodern-devel can be used for questions, discussion,
234		bug-reports, patches, or anything else relating to this library.
235		To subscribe, send a message
236		to <a href="mailto:postmodern-devel+subscribe@common-lisp.net">postmodern-devel+subscribe@common-lisp.net</a>.
237		Or mail the author/maintainer
238		directly: <a href="mailto:marijnh@gmail.com">Marijn
239		Haverbeke</a>.</p>
240
241	231	<h2><a name="quickstart"></a>Quickstart</h2>
242	232
243	233	<p>This quickstart is intended to give you a feel of the way

-4

postmodern/tests.lisp less more

0	0	(defpackage :postmodern-tests
1		(:use :common-lisp :Eos :postmodern :simple-date))
	1	(:use :common-lisp :fiveam :postmodern :simple-date :cl-postgres-tests))
2	2
3	3	(in-package :postmodern-tests)
4
5		(defvar test-connection '("test" "test" "" "localhost"))
6	4
7	5	;; Adjust the above to some db/user/pass/host combination that refers
8	6	;; to a valid postgresql database in which no table named test_data
9	7	;; currently exists. Then after loading the file, run the tests with
10		;; (Eos:run! :postmodern)
	8	;; (fiveam:run! :postmodern)
11	9
12	10	(def-suite :postmodern)
13	11	(in-suite :postmodern)

-11

postmodern.asd less more

29	29	#+postmodern-use-mop
30	30	(:file "table" :depends-on ("util" "transaction"))
31	31	(:file "deftable" :depends-on
32		("query" #+postmodern-use-mop "table"))))))
	32	("query" #+postmodern-use-mop "table")))))
	33	:in-order-to ((test-op (test-op :postmodern-tests))))
33	34
34	35	(defsystem :postmodern-tests
35		:depends-on (:postmodern :eos :simple-date :simple-date-postgres-glue)
	36	:depends-on (:postmodern :fiveam :simple-date :simple-date-postgres-glue
	37	:cl-postgres-tests)
36	38	:components
37	39	((:module :postmodern
38		:components ((:file "tests")))))
39
40		(defmethod perform ((op asdf:test-op) (system (eql (find-system :postmodern))))
41		(asdf:oos 'asdf:load-op :postmodern)
42		(asdf:oos 'asdf:load-op :cl-postgres-tests)
43		(asdf:oos 'asdf:load-op :postmodern-tests)
44		(funcall (intern (string :prompt-connection) (string :cl-postgres-tests))
45		(eval (intern (string :test-connection) (string :postmodern-tests))))
46		(funcall (intern (string :run!) (string :Eos)) :postmodern))
	40	:components ((:file "tests"))))
	41	:perform (test-op (o c)
	42	(uiop:symbol-call :cl-postgres-tests '#:prompt-connection)
	43	(uiop:symbol-call :fiveam '#:run! :postmodern)))

+44

-2

simple-date/cl-postgres-glue.lisp less more

0		(in-package :simple-date)
	0
	1	(defpackage :simple-date-cl-postgres-glue
	2	(:use :common-lisp :simple-date)
	3	(:export simple-date-sql-readtable
	4	:simple-date-sql-readtable))
	5
	6	(in-package :simple-date-cl-postgres-glue)
	7
	8	(defparameter simple-date-sql-readtable
	9	(cl-postgres:copy-sql-readtable))
1	10
2	11	;; PostgreSQL days are measured from 01-01-2000, whereas simple-date
3	12	;; uses 01-03-2000.

16	25	:timestamp-with-timezone #'interpret-timestamp
17	26	:interval (lambda (months days usecs)
18	27	(make-instance 'interval :months months
19		:ms (floor (+ (* days +usecs-in-one-day+) usecs) 1000)))))
	28	:ms (floor (+ (* days +usecs-in-one-day+) usecs) 1000)))
	29	:time (lambda (usecs)
	30	(multiple-value-bind (seconds usecs)
	31	(floor usecs 1000000)
	32	(multiple-value-bind (minutes seconds)
	33	(floor seconds 60)
	34	(multiple-value-bind (hours minutes)
	35	(floor minutes 60)
	36	(make-instance 'time-of-day
	37	:hours hours
	38	:minutes minutes
	39	:seconds seconds
	40	:microseconds usecs)))))
	41	:table simple-date-sql-readtable))
20	42
21	43	(defmethod cl-postgres:to-sql-string ((arg date))
22	44	(multiple-value-bind (year month day) (decode-date arg)

39	61	(not-zero year) (not-zero month) (not-zero day)
40	62	(not-zero hour) (not-zero min) (not-zero sec) (not-zero ms))
41	63	"interval")))))
	64
	65	(defmethod cl-postgres:to-sql-string ((arg time-of-day))
	66	(with-accessors ((hours hours)
	67	(minutes minutes)
	68	(seconds seconds)
	69	(microseconds microseconds))
	70	arg
	71	(format nil "~2,'0d:~2,'0d:~2,'0d~@[.~6,'0d~]"
	72	hours minutes seconds (if (zerop microseconds) nil microseconds))))
	73
	74	;;
	75	;; install a copy of the readtable we just modified, leaving our
	76	;; readtable safe from further modification, for better or worse.
	77	(setf cl-postgres:sql-readtable
	78	(cl-postgres:copy-sql-readtable simple-date-sql-readtable))
	79
	80	(defun simple-date-sql-readtable ()
	81	"An sql-readtable that has the simple-date-cl-postgres-glue reader
	82	functions installed."
	83	simple-date-sql-readtable)

+42

-0

simple-date/simple-date.lisp less more

3	3	#:timestamp #:encode-timestamp #:decode-timestamp
4	4	#:timestamp-to-universal-time #:universal-time-to-timestamp
5	5	#:interval #:encode-interval #:decode-interval
	6	#:time-of-day #:hours #:minutes #:seconds #:microseconds
	7	#:encode-time-of-day #:decode-time-of-day
6	8	#:time-add #:time-subtract
7	9	#:time= #:time> #:time< #:time<= #:time>=))
8	10

167	169	0 being Sunday and 6 being Saturday."
168	170	(+ (mod (+ (days date) 3) 7)))
169	171
	172	(defclass time-of-day ()
	173	((hours :initarg :hours :accessor hours)
	174	(minutes :initarg :minutes :accessor minutes)
	175	(seconds :initarg :seconds :accessor seconds)
	176	(microseconds :initarg :microseconds :accessor microseconds))
	177	(:documentation "This class is used to represent time of day in
	178	hours, minutes, seconds and microseconds."))
	179
	180	(defmethod print-object ((time time-of-day) stream)
	181	(print-unreadable-object (time stream :type t)
	182	(with-accessors ((hours hours)
	183	(minutes minutes)
	184	(seconds seconds)
	185	(microseconds microseconds))
	186	time
	187	(format stream "~2,'0d:~2,'0d:~2,'0d~@[.~6,'0d~]"
	188	hours minutes seconds (if (zerop microseconds) nil microseconds)))))
	189
	190	(defun encode-time-of-day (hour minute &optional (second 0) (microsecond 0))
	191	"Create a timestamp object."
	192	(make-instance 'time-of-day
	193	:hours hour
	194	:minutes minute
	195	:seconds second
	196	:microseconds microsecond))
	197
	198	(defun decode-time-of-day (time)
	199	(with-accessors ((hours hours)
	200	(minutes minutes)
	201	(seconds seconds)
	202	(microseconds microseconds))
	203	time
	204	(values hours minutes seconds microseconds)))
	205
170	206	(defclass timestamp (date)
171	207	((millisecs :initarg :ms :accessor millisecs))
172	208	(:documentation "A timestamp specifies a time with a precision up to

336	372	(defmethod time= ((a interval) (b interval))
337	373	(and (= (millisecs a) (millisecs b))
338	374	(= (months a) (months b))))
	375
	376	(defmethod time= ((a time-of-day) (b time-of-day))
	377	(and (= (hours a) (hours b))
	378	(= (minutes a) (minutes b))
	379	(= (seconds a) (seconds b))
	380	(= (microseconds a) (microseconds b))))
339	381
340	382	(defgeneric time< (a b)
341	383	(:documentation "Compare two time-related values, returns a boolean

-2

simple-date/tests.lisp less more

0	0	(defpackage :simple-date-tests
1		(:use :common-lisp :Eos :simple-date))
	1	(:use :common-lisp :fiveam :simple-date))
2	2
3	3	(in-package :simple-date-tests)
4	4
5		;; After loading the file, run the tests with (Eos:run! :simple-date)
	5	;; After loading the file, run the tests with (fiveam:run! :simple-date)
6	6
7	7	(def-suite :simple-date)
8	8	(in-suite :simple-date)

-7

simple-date.asd less more

4	4	(defsystem :simple-date
5	5	:components
6	6	((:module :simple-date
7		:components ((:file "simple-date")))))
	7	:components ((:file "simple-date"))))
	8	:in-order-to ((test-op (test-op :simple-date-tests))))
8	9
9	10	(defsystem :simple-date-postgres-glue
10	11	:depends-on (:simple-date :cl-postgres)

14	15	((:file "cl-postgres-glue")))))
15	16
16	17	(defsystem :simple-date-tests
17		:depends-on (:eos :simple-date)
	18	:depends-on (:fiveam :simple-date)
18	19	:components
19	20	((:module :simple-date
20		:components ((:file "tests")))))
21
22		(defmethod perform ((op asdf:test-op) (system (eql (find-system :simple-date))))
23		(asdf:oos 'asdf:load-op :simple-date-tests)
24		(funcall (intern (string :run!) (string :Eos)) :simple-date))
	21	:components ((:file "tests"))))
	22	:perform (test-op (o c)
	23	(uiop:symbol-call :fiveam '#:run! :simple-date)))
25	24
26	25	(defmethod perform :after ((op asdf:load-op) (system (eql (find-system :simple-date))))
27	26	(when (and (find-package :cl-postgres)