r9519: add prepared statements for postgresql

[clsql.git] / sql / generic-postgresql.lisp

diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp
index 55d3a9082b8c6984781a58ed84cd3aef8662c979..b85da75fb073ea28016095ff97cd1bf1d2a47c97 100644 (file)
--- a/sql/generic-postgresql.lisp
+++ b/sql/generic-postgresql.lisp
@@ -213,8 +213,92 @@
            (sql-escape (string-downcase table)))
    database :auto nil))
 
-
-;; Capabilities
+;;; Prepared statements
+
+(defvar *next-prepared-id-num* 0)
+(defun next-prepared-id ()
+  (let ((num (incf *next-prepared-id-num*)))
+    (format nil "CLSQL_PS_~D" num)))
+
+(defclass postgresql-stmt ()
+  ((database :initarg :database :reader database)
+   (id :initarg :id :reader id)
+   (bindings :initarg :bindings :reader bindings)
+   (field-names :initarg :field-names :accessor stmt-field-names)
+   (result-types :initarg :result-types :reader result-types)))
+
+(defun clsql-type->postgresql-type (type)
+  (case type
+    (:string "VARCHAR")
+    ((:int :integer) "INT4")
+    (:short "INT2")
+    ((:number :numeric :float) "NUMERIC")
+    (:bigint "INT8")))
+
+(defun prepared-sql-to-postgresql-sql (sql)
+  ;; FIXME: Convert #\? to "$n". Don't convert within strings
+  (declare (simple-string sql))
+  (with-output-to-string (out)
+    (do ((len (length sql))
+        (param 0)
+        (in-str nil)
+        (pos 0 (1+ pos)))
+       ((= len pos))
+      (declare (fixnum len param pos))
+      (let ((c (schar sql pos)))
+       (declare (character c))
+       (cond
+        ((or (char= c #\") (char= c #\'))
+         (setq in-str (not in-str))
+         (write-char c out))
+        ((and (char= c #\?) (not in-str))
+         (write-char #\$ out) 
+         (write-string (write-to-string (incf param)) out))
+        (t
+         (write-char c out)))))))
+
+(defmethod database-prepare (sql-stmt types (database generic-postgresql-database) result-types field-names)
+  (let ((id (next-prepared-id)))
+    (database-execute-command
+     (format nil "PREPARE ~A (~{~A~^,~}) AS ~A"
+            id
+            (mapcar #'clsql-type->postgresql-type types)
+            (prepared-sql-to-postgresql-sql sql-stmt))
+     database)
+    (make-instance 'postgresql-stmt
+                  :id id
+                  :database database
+                  :result-types result-types
+                  :field-names field-names
+                  :bindings (make-list (length types)))))
+
+(defmethod database-bind-parameter ((stmt postgresql-stmt) position value)
+  (setf (nth (1- position) (bindings stmt)) value)) 
+
+(defun binding-to-param (binding)
+  (typecase binding
+    (string
+     (concatenate 'string "'" (sql-escape-quotes binding) "'"))
+    (t
+     binding)))
+
+(defmethod database-run-prepared ((stmt postgresql-stmt))
+  (with-slots (database id bindings field-names result-types) stmt
+    (let ((query (format nil "EXECUTE ~A (~{~A~^,~})"
+                        id (mapcar #'binding-to-param bindings))))
+      (cond
+       ((and field-names (not (consp field-names)))
+       (multiple-value-bind (res names)
+           (database-query query database result-types field-names)
+         (setf field-names names)
+         (values res names)))
+       (field-names
+       (values (nth-value 0 (database-query query database result-types nil))
+               field-names))
+       (t
+       (database-query query database result-types field-names))))))
+
+;;; Capabilities
 
 (defmethod db-type-has-fancy-math? ((db-type (eql :postgresql)))
   t)
@@ -222,3 +306,9 @@
 (defmethod db-type-default-case ((db-type (eql :postgresql)))
   :lower)
 
+(defmethod db-type-has-prepared-stmt? ((db-type (eql :postgresql)))
+  t)
+
+(defmethod db-type-has-prepared-stmt? ((db-type (eql :postgresql-socket)))
+  t)
+