X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=db-postgresql-socket3%2Fsql.lisp;h=e2515005cb5cda828bd910484cb89d7d94e8dba2;hb=1e8d22b3fdace44a45b6b0702da5587e136e2398;hp=edebf0b456dfa4a4bad15c72db142da306d0f8b6;hpb=126812fb21eeb397865ebd1f4cfaf13ca5b350f3;p=clsql.git diff --git a/db-postgresql-socket3/sql.lisp b/db-postgresql-socket3/sql.lisp index edebf0b..e251500 100644 --- a/db-postgresql-socket3/sql.lisp +++ b/db-postgresql-socket3/sql.lisp @@ -20,12 +20,29 @@ (in-package #:cl-user) (defpackage :clsql-postgresql-socket3 - (:use #:common-lisp #:clsql-sys #:postgresql-socket) - (:export #:postgresql-socket-database) - (:documentation "This is the CLSQL socket interface to PostgreSQL.")) + (:use #:common-lisp #:clsql-sys #:postgresql-socket3) + (:export #:postgresql-socket3-database) + (:documentation "This is the CLSQL socket interface (protocol version 3) to PostgreSQL.")) (in-package #:clsql-postgresql-socket3) +(defvar *sqlreader* (cl-postgres:copy-sql-readtable)) +(let ((dt-fn (lambda (useconds-since-2000) + (let ((sec (truncate + (/ useconds-since-2000 + 1000000))) + (usec (mod useconds-since-2000 + 1000000))) + (clsql:make-time :year 2000 :second sec :usec usec))))) + (cl-postgres:set-sql-datetime-readers + :table *sqlreader* + :date (lambda (days-since-2000) + (clsql:make-date :year 2000 :day (+ 1 days-since-2000))) + :timestamp dt-fn + :timestamp-with-timezone dt-fn)) + + + ;; interface foreign library loading routines (clsql-sys:database-type-load-foreign :postgresql-socket3) @@ -41,11 +58,11 @@ (ecase *backend-warning-behavior* (:warn (warn 'sql-database-warning :database database - :message (postgresql-condition-message condition))) + :message (cl-postgres:database-error-message condition))) (:error (error 'sql-database-error :database database :message (format nil "Warning upgraded to error: ~A" - (postgresql-condition-message condition)))) + (cl-postgres:database-error-message condition)))) ((:ignore nil) ;; do nothing ))) @@ -55,7 +72,7 @@ :database database :expression expression :error-id (type-of condition) - :message (postgresql-condition-message condition))) + :message (cl-postgres:database-error-message condition))) (defmacro with-postgresql-handlers ((database &optional expression) @@ -67,7 +84,7 @@ (handler-bind ((postgresql-warning (lambda (c) (convert-to-clsql-warning ,database-var c))) - (postgresql-error + (cl-postgres:database-error (lambda (c) (convert-to-clsql-error ,database-var ,expression-var c)))) @@ -103,13 +120,14 @@ "/" db "/" user))) (defmethod database-connect (connection-spec - (database-type (eql :postgresql-socket))) + (database-type (eql :postgresql-socket3))) (check-connection-spec connection-spec database-type (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional (port +postgresql-server-default-port+) (options "") (tty "")) connection-spec + (declare (ignore options tty)) (handler-case (handler-bind ((warning (lambda (c) @@ -117,20 +135,14 @@ :format-control "~A" :format-arguments (list (princ-to-string c)))))) - (cl-postgres:open-database - :database db - :user user - :password password - :host host - :port port - )) + (cl-postgres:open-database db user password host port)) (cl-postgres:database-error (c) ;; Connect failed (error 'sql-connection-error :database-type database-type :connection-spec connection-spec :error-id (type-of c) - :message (postgresql-condition-message c))) + :message (cl-postgres:database-error-message c))) (:no-error (connection) ;; Success, make instance (make-instance 'postgresql-socket3-database @@ -143,70 +155,126 @@ (cl-postgres:close-database (database-connection database)) t) +(defmethod clsql-sys::release-to-conn-pool :before ((conn postgresql-socket3-database)) + ;; This resets the connection to "New" state + (database-execute-command "DISCARD ALL;" conn)) + (defvar *include-field-names* nil) -(cl-postgres:def-row-reader clsql-default-row-reader (fields) - (values (loop :while (next-row) - :collect (loop :for field :across fields - :collect (next-field field))) - (when *include-field-names* - (loop :for field :across fields - :collect (field-name field))))) + +;; THE FOLLOWING MACRO EXPANDS TO THE FUNCTION BELOW IT, +;; BUT TO GET null CONVENTIONS CORRECT I NEEDED TO TWEAK THE EXPANSION +;; +;; (cl-postgres:def-row-reader clsql-default-row-reader (fields) +;; (values (loop :while (cl-postgres:next-row) +;; :collect (loop :for field :across fields +;; :collect (cl-postgres:next-field field))) +;; (when *include-field-names* +;; (loop :for field :across fields +;; :collect (cl-postgres:field-name field))))) + + + +(defun clsql-default-row-reader (stream fields) + (declare (type stream stream) + (type (simple-array cl-postgres::field-description) fields)) + (flet ((cl-postgres:next-row () + (cl-postgres::look-for-row stream)) + (cl-postgres:next-field (cl-postgres::field) + (declare (type cl-postgres::field-description cl-postgres::field)) + (let ((cl-postgres::size (cl-postgres::read-int4 stream))) + (declare (type (signed-byte 32) cl-postgres::size)) + (if (eq cl-postgres::size -1) + nil + (funcall (cl-postgres::field-interpreter cl-postgres::field) + stream cl-postgres::size))))) + (let ((results (loop :while (cl-postgres:next-row) + :collect (loop :for field :across fields + :collect (cl-postgres:next-field field)))) + (col-names (when *include-field-names* + (loop :for field :across fields + :collect (cl-postgres:field-name field))))) + ;;multiple return values were not working here + (list results col-names)))) (defmethod database-query ((expression string) (database postgresql-socket3-database) result-types field-names) - (let ((connection (database-connection database))) + (let ((connection (database-connection database)) + (cl-postgres:*sql-readtable* *sqlreader*)) (with-postgresql-handlers (database expression) (let ((*include-field-names* field-names)) - (cl-postgres:exec-query connection expression #'clsql-default-row-reader)) + (apply #'values (cl-postgres:exec-query connection expression #'clsql-default-row-reader))) ))) +(defmethod query ((obj command-object) &key (database *default-database*) + (result-types :auto) (flatp nil) (field-names t)) + (clsql-sys::record-sql-command (expression obj) database) + (multiple-value-bind (rows names) + (database-query obj database result-types field-names) + (let ((result (if (and flatp (= 1 (length (car rows)))) + (mapcar #'car rows) + rows))) + (clsql-sys::record-sql-result result database) + (if field-names + (values result names) + result)))) + +(defmethod database-query ((obj command-object) (database postgresql-socket3-database) result-types field-names) + (let ((connection (database-connection database)) + (cl-postgres:*sql-readtable* *sqlreader*)) + (with-postgresql-handlers (database obj) + (let ((*include-field-names* field-names)) + (unless (has-been-prepared obj) + (cl-postgres:prepare-query connection (prepared-name obj) (expression obj)) + (setf (has-been-prepared obj) T)) + (apply #'values (cl-postgres:exec-prepared + connection + (prepared-name obj) + (parameters obj) + #'clsql-default-row-reader)))))) + (defmethod database-execute-command ((expression string) (database postgresql-socket3-database)) (let ((connection (database-connection database))) (with-postgresql-handlers (database expression) - (exec-query connection expression)))) + ;; return row count? + (second (multiple-value-list (cl-postgres:exec-query connection expression)))))) -;;;; Cursoring interface +(defmethod execute-command ((obj command-object) + &key (database *default-database*)) + (clsql-sys::record-sql-command (expression obj) database) + (let ((res (database-execute-command obj database))) + (clsql-sys::record-sql-result res database) + ;; return row count? + res)) -(defclass cursor () - ((next-row :accessor next-row :initarg :next-row :initform nil) - (fields :accessor fields :initarg :fields :initform nil) - (next-field :accessor next-field :initarg :next-field :initform nil) - (done :accessor done :initarg :done :initform nil))) +(defmethod database-execute-command + ((obj command-object) (database postgresql-socket3-database)) + (let ((connection (database-connection database))) + (with-postgresql-handlers (database obj) + (unless (has-been-prepared obj) + (cl-postgres:prepare-query connection (prepared-name obj) (expression obj)) + (setf (has-been-prepared obj) T)) + (second (multiple-value-list (cl-postgres:exec-prepared connection (prepared-name obj) (parameters obj))))))) -(defvar *cursor* ()) +;;;; Cursoring interface -(cl-postgres:def-row-reader clsql-cursored-row-reader (fields) - (setf *cursor* - (make-instance 'cursor :next-row #'next-row :fields fields :next-field #'next-field))) (defmethod database-query-result-set ((expression string) (database postgresql-socket3-database) &key full-set result-types) + (declare (ignore result-types)) (declare (ignore full-set)) - (let ((connection (database-connection database)) - *cursor*) - (with-postgresql-handlers (database expression) - (cl-postgres:exec-query connection expression 'clsql-cursored-row-reader) - (values *cursor* (length (fields *cursor*)))))) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")) (defmethod database-dump-result-set (result-set - (database postgresql-socket-database)) - (unless (done result-set) - (loop :while (funcall (next-row result-set)))) + (database postgresql-socket3-database)) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader") T) (defmethod database-store-next-row (result-set - (database postgresql-socket-database) + (database postgresql-socket3-database) list) - (when (and (not (done result-set)) - (setf (done result-set) (funcall (next-row result-set)))) - - (let* ((data (loop :for field :across (fields result-set) - :collect (funcall (next-field result-set) field)))) - ;; Maybe? - (setf (car list) (car data) - (cdr list) (cdr data))))) + (error "Cursoring interface is not supported for postgresql-socket3-database try cl-postgres:exec-query with a custom row-reader")) ;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -214,6 +282,7 @@ (defmethod database-create (connection-spec (type (eql :postgresql-socket3))) (destructuring-bind (host name user password &optional port options tty) connection-spec + (declare (ignore port options tty)) (let ((database (database-connect (list host "postgres" user password) type))) (setf (slot-value database 'clsql-sys::state) :open) @@ -222,7 +291,8 @@ (database-disconnect database))))) (defmethod database-destroy (connection-spec (type (eql :postgresql-socket3))) - (destructuring-bind (host name user password &optional port optional tty) connection-spec + (destructuring-bind (host name user password &optional port options tty) connection-spec + (declare (ignore port options tty)) (let ((database (database-connect (list host "postgres" user password) type))) (setf (slot-value database 'clsql-sys::state) :open) @@ -253,3 +323,14 @@ (when (clsql-sys:database-type-library-loaded :postgresql-socket3) (clsql-sys:initialize-database-type :database-type :postgresql-socket3)) + + +;; Type munging functions + +(defmethod read-sql-value (val (type (eql 'boolean)) (database postgresql-socket3-database) db-type) + (declare (ignore database db-type)) + val) + +(defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database postgresql-socket3-database) db-type) + (declare (ignore database db-type)) + val) \ No newline at end of file