Merge pull request #287 from sabracrolleton/master

Portability Fixes

README.md

@@ -625,7 +625,11 @@ the same sample data looks like:
 
 The Lisp code in Postmodern is theoretically portable across implementations,
 and seems to work on all major ones as well as some minor ones such as Genera.
-It is regularly tested on ccl, sbcl, ecl and cmucl. ABCL currently has issues with utf-8 and :null.
+It is regularly tested on ccl, sbcl, ecl, abcl and cmucl.
+
+ABCL version 1.8.0 broke the dao class inheritance. See [https://abcl.org/trac/ticket/479](https://abcl.org/trac/ticket/479). Everything other than dao-classes works.
+
+Clisp currently has issues with executing a file of sql statements (Postmodern's execute-file function).
 
 Please let us know if it does not work on the implementation that you normally use. 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).
 

cl-postgres.asd

@@ -7,16 +7,16 @@
 ;; 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)
+  #+(or sb-unicode unicode ics openmcl-unicode-strings abcl) t
+  #-(or sb-unicode unicode ics openmcl-unicode-strings abcl) nil)
 (defparameter *string-file* (if *unicode* "strings-utf-8" "strings-ascii"))
 
 (defsystem "cl-postgres"
   :description "Low-level client library for PostgreSQL"
   :author "Marijn Haverbeke <marijnh@gmail.com>"
   :maintainer "Sabra Crolleton <sabra.crolleton@gmail.com>"
   :license "zlib"
-  :version "1.33.1"
+  :version "1.33.2"
   :depends-on ("md5" "split-sequence" "ironclad" "cl-base64" "uax-15"
                      (:feature (:or :sbcl :allegro :ccl :clisp :genera
                                 :armedbear :cmucl :lispworks)

cl-postgres/data-types.lisp

@@ -189,7 +189,8 @@ when it is not will result in Postgresql throwing type mismatch errors."
     (int2 cl-postgres-oid:+int2+)
     (int4 cl-postgres-oid:+int4+)
     (int8 cl-postgres-oid:+int8+)
-    (single-float cl-postgres-oid:+float4+)
+    #-clisp (single-float cl-postgres-oid:+float4+)
+    #+clisp (float cl-postgres-oid:+float4+)
     (double-float cl-postgres-oid:+float8+)
     (boolean cl-postgres-oid:+bool+)
     (t 0)))

cl-postgres/interpret.lisp

@@ -122,10 +122,11 @@ interpreted as an array of the given type."
                   (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)
+              (progn
+                `(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)
@@ -157,14 +158,14 @@ interpreted as an array of the given type."
 
 (defun read-row-value (stream size)
   (declare (type stream stream)
-           (type integer size)
-           (ignore size))
+           (type integer size))
   (let ((num-fields (read-uint4 stream)))
     (loop for i below num-fields
           collect (let ((oid (read-uint4 stream))
                         (size (read-int4 stream)))
                     (declare (type (signed-byte 32) size))
-                    (if (eq size -1)
+                    (if #-abcl (eq size -1)
+                        #+abcl (eql size -1)
                         :null
                         (funcall (interpreter-reader (get-type-interpreter oid))
                                  stream size))))))
@@ -213,8 +214,7 @@ executing body so that row values will be returned as t."
 
 (defun read-binary-array-value (stream size)
   (declare (type stream stream)
-           (type integer size)
-           (ignore size))
+           (type integer size))
   (let ((num-dims (read-uint4 stream))
         (has-null (read-uint4 stream))
         (element-type (read-uint4 stream)))
@@ -236,7 +236,8 @@ executing body so that row values will be returned as t."
                  do (let ((size (read-int4 stream)))
                       (declare (type (signed-byte 32) size))
                       (setf (row-major-aref results i)
-                            (if (eq size -1)
+                            (if #-abcl (eq size -1)
+                                #+abcl (eql size -1)
                                 :null
                                 (funcall
                                  (interpreter-reader
@@ -486,10 +487,13 @@ e.g.
                             (return (interpret (subseq value start pos))))
                           (incf pos))))))
                (interpret (word)
-                 (if (string= word "NULL") :null (funcall transform 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))))
+                                  :collect (length x))
+                        '(0))))
           (make-array dim :initial-contents arr))))))
 
 ;; Working with tables.

cl-postgres/protocol.lisp

@@ -44,6 +44,7 @@ from the socket."
         (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))
@@ -85,8 +86,8 @@ from the socket."
                                  (error 'protocol-error
                                         :message
                                         (format nil
-                                                "Unexpected message received: ~A"
-                                                (code-char ,char-name))))))))))
+                                                "Unexpected message received: ~A ~a"
+                                                (code-char ,char-name) ,char-name)))))))))
            (,iter-name))))))
 
 
@@ -392,32 +393,32 @@ copy-in/copy-out states \(which are not supported)."
            #.*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)))))
+      ;; 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
@@ -603,7 +604,8 @@ and apply the given row-reader to the result."
                                (declare (type field-description field))
                                (let ((size (read-int4 ,socket)))
                                  (declare (type (signed-byte 32) size))
-                                 (if (eq size -1)
+                                 (if #-abcl (eq size -1)
+                                     #+abcl (eql size -1)
                                      :null
                                      (funcall (field-interpreter field)
                                               ,socket size)))))

cl-postgres/public.lisp

@@ -238,11 +238,13 @@ if it isn't."
                       (cond
                         ((equal (connection-host conn) :unix)
                          (assert-unix)
-                         (unix-socket-connect (unix-socket-path *unix-socket-dir* (connection-port conn))))
+                         (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))))
+                         (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)
@@ -499,5 +501,6 @@ Postgresql is expecting the parameters to be in text format." error))))))
 (def-row-reader ignore-row-reader (fields)
   (loop :while (next-row)
         :do (loop :for field :across fields
-                  :do (next-field field)))
+                  :do
+                     (next-field field)))
   (values))

cl-postgres/sql-string.lisp

@@ -151,7 +151,9 @@ that PostgreSQL understands when sent through its socket connection. May return
 a string or a (vector (unsigned-byte 8)).")
   (:method ((arg integer))
     (int-to-vector arg))
-  (:method ((arg single-float))
+  #-clisp (:method ((arg single-float))
+            (int32-to-vector (cl-postgres-ieee-floats:encode-float32 arg)))
+  #+clisp (:method ((arg float))
     (int32-to-vector (cl-postgres-ieee-floats:encode-float32 arg)))
   #-clisp   (:method ((arg double-float)) ;; CLISP doesn't allow methods on double-float
               (int64-to-vector (cl-postgres-ieee-floats:encode-float64 arg)))

cl-postgres/tests/test-binary-parameters.lisp

@@ -529,22 +529,6 @@ unless it would have been valid as a text parameter."
                                           (vector-to-hex-string random-bytes)
                                           "\")"))))))))))
 
-(test binary-write-row-array-bytea
-  (with-binary-test-connection
-    (exec-query connection "create temporary table test (a bytea)")
-    (let ((*random-byte-count* 16))
-      (unwind-protect
-           (let ((random-bytes (make-array *random-byte-count*
-                                           :element-type '(unsigned-byte 8)
-                                           :initial-element 0)))
-             (loop for i below *random-byte-count*
-                   do (setf (aref random-bytes i)
-                            (random #x100)))
-             (prepare-query connection "bytea-insert" "insert into test values ($1)")
-             (exec-prepared connection "bytea-insert" (list random-bytes))
-             (is (equalp (exec-query connection "select row(ARRAY[a]) from test;" 'list-row-reader)
-                         `(((#(,random-bytes)))))))))))
-
 (test binary-write-row-array-bytea
   (with-binary-test-connection
     (with-binary-row-values

cl-postgres/tests/test-data-types.lisp

@@ -64,8 +64,10 @@
                                                   123456789123456987654 'b #\d 12.2
                                                   nil t))
              '(0 21 23 20 0 0 0 700 16 16)))
-  (is (equal (cl-postgres::parameter-list-types '(12413212.98324d0))
-             '(701))))
+  #-clisp (is (equal (cl-postgres::parameter-list-types '(12413212.98324d0))
+                     '(701)))
+  #+clisp (is (equal (cl-postgres::parameter-list-types '(12413212.98324d0))
+                     '(700))))
 
 (test parameter-lists-match-oid-types
   (is (cl-postgres::parameter-lists-match-oid-types-p '(12413212.98324d0) '(124212.98324d0)))
@@ -75,9 +77,15 @@
                                                            '(3)))))
 
 (test param-to-oid
-  (is (equal (loop for x in '(integer int2 int4 int8 boolean t nil float
+  #-clisp (is (equal (loop for x in '(integer int2 int4 int8 boolean t nil float
                               double-float "jeff" 2 2000 12345678909 1.0 2.7d0 "12a")
                    collect (list x (param-to-oid x)))
              '((INTEGER 0) (INT2 0) (INT4 0) (INT8 0) (BOOLEAN 0) (T 16) (NIL 16) (FLOAT 0)
                (DOUBLE-FLOAT 0) ("jeff" 0) (2 21) (2000 21) (12345678909 20) (1.0 700)
-               (2.7d0 701) ("12a" 0)))))
+               (2.7d0 701) ("12a" 0))))
+  #+clisp (is (equal (loop for x in '(integer int2 int4 int8 boolean t nil float
+                              double-float "jeff" 2 2000 12345678909 1.0 2.7d0 "12a")
+                   collect (list x (param-to-oid x)))
+             '((INTEGER 0) (INT2 0) (INT4 0) (INT8 0) (BOOLEAN 0) (T 16) (NIL 16) (FLOAT 0)
+               (DOUBLE-FLOAT 0) ("jeff" 0) (2 21) (2000 21) (12345678909 20) (1.0 700)
+               (2.7d0 700) ("12a" 0)))))

doc/index.org

@@ -856,9 +856,12 @@ function. E.g.
    :END:
 The Lisp code in Postmodern is theoretically portable across implementations,
 and seems to work on all major ones as well as some minor ones such as Genera.
-It is regularly tested on ccl, sbcl, ecl and cmucl.
+It is regularly tested on ccl, sbcl, ecl, abcl and cmucl.
 
-ABCL currently has issues with utf-8 and :null..
+ABCL version 1.8.0 broke the dao class inheritance. See [[https://abcl.org/trac/ticket/479]].
+Everything other than dao-classes works.
+
+Clisp currently has issues with executing a file of sql statements (Postmodern's execute-file function).
 
 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

postmodern.asd

@@ -20,7 +20,7 @@
   :maintainer "Sabra Crolleton <sabra.crolleton@gmail.com>"
   :homepage  "https://github.com/marijnh/Postmodern"
   :license "zlib"
-  :version "1.33.1"
+  :version "1.33.2"
   :depends-on ("alexandria"
                "cl-postgres"
                "s-sql"
@@ -67,7 +67,8 @@
                          (:file "test-return-types-timestamps" :depends-on ("test-package" "tests"))
                          (:file "test-transactions" :depends-on ("test-package" "tests"))
                          (:file "test-roles" :depends-on ("test-package" "tests"))
-                         (:file "test-dao" :depends-on ("test-package" "tests"))
+                         #-abcl (:file "test-dao" :depends-on ("test-package" "tests"))
+                         #+abcl (:file "abcl-test-dao" :depends-on ("test-package" "tests"))
                          (:file "test-execute-file" :depends-on ("test-package" "tests")))))
 
   :perform (test-op (o c)

postmodern/config.lisp

@@ -44,6 +44,7 @@ different than the query statement provided to ensure-prepared.")
 ;; Query Parameters
 (defparameter *result-styles*
   '((:none ignore-row-reader all-rows)
+    (:debug cl-postgres::debug-row-reader all-rows)
     (:lists list-row-reader all-rows)
     (:list list-row-reader single-row)
     (:rows list-row-reader all-rows)

postmodern/json-encoder.lisp

@@ -498,14 +498,16 @@ characters in string S to STREAM."
                  (format stream "\\~C~V,V,'0R" esc radix width code)))))
 
 (eval-when (:compile-toplevel)
-    (if (subtypep 'long-float 'single-float)
+  (if #-clisp (subtypep 'long-float 'single-float)
+      #+clisp (subtypep 'long-float 'float)
         ;; only one float type
         (pushnew :cl-json-only-one-float-type *features*)
         ;; else -- we check here only for the case where there are two
         ;; float types, single- and double- --- we don't consider the
         ;; "only single and short" case.  Could be added if necessary.
         (progn
-          (when (subtypep 'single-float 'short-float)
+          (when #-clisp (subtypep 'single-float 'short-float)
+                #+clisp (subtypep 'float 'short-float)
             (pushnew :cl-json-single-float-is-subsumed *features*))
           (when (subtypep 'long-float 'double-float)
             (pushnew :cl-json-double-float-is-subsumed *features*)))))
@@ -517,7 +519,8 @@ characters in string S to STREAM."
     (real (let ((*read-default-float-format*
                  (etypecase nr
                    (short-float 'short-float)
-                   (rational 'single-float)
+                   #-clisp (rational 'single-float)
+                   #+clisp (rational 'float)
                    #-(or cl-json-single-float-is-subsumed
                          cl-json-only-one-float-type)
                    (single-float 'single-float)