From: Kevin M. Rosenberg Date: Sun, 23 May 2004 07:56:26 +0000 (+0000) Subject: r9447: * sql/*.lisp: Add db-type parameter to generic functions READ-SQL... X-Git-Tag: v3.8.6~400 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=7308bdf188da6424e615ca14096ef53cfb845a90 r9447: * sql/*.lisp: Add db-type parameter to generic functions READ-SQL-VALUE, DATABASE-GET-TYPE-SPECIFIER, and OUTPUT-SQL-VALUE-AS-TYPE. Update methods to use these. * sql/generic-postgresql.lisp, sql/generic-odbc.lisp: New files --- diff --git a/ChangeLog b/ChangeLog index c3143fc..c3df25c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 22 May 2004 Kevin Rosenberg * Version 2.10.21 released + * sql/*.lisp: Add db-type parameter to generic functions READ-SQL-VALUE, + DATABASE-GET-TYPE-SPECIFIER, and OUTPUT-SQL-VALUE-AS-TYPE. Update methods to use these. + * sql/generic-postgresql.lisp, sql/generic-odbc.lisp: New files * sql/classes.lisp: honor case of string tables when outputting queries * sql/objects.lisp: Add database type to default database-get-type-specifier method * sql/sql.lisp: Add database type to default database-abort-transaction method diff --git a/clsql.asd b/clsql.asd index e891452..bc128ac 100644 --- a/clsql.asd +++ b/clsql.asd @@ -65,6 +65,11 @@ oriented interface." :pathname "" :components ((:file "metaclasses") (:file "objects" :depends-on ("metaclasses"))) + :depends-on (:functional)) + (:module :generic + :pathname "" + :components ((:file "generic-postgresql") + (:file "generic-odbc")) :depends-on (:functional)))))) diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 060db96..4d83206 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -33,7 +33,7 @@ ;; AODBC interface -(defclass aodbc-database (database) +(defclass aodbc-database (generic-odbc-database) ((aodbc-conn :accessor database-aodbc-conn :initarg :aodbc-conn) (aodbc-db-type :accessor database-aodbc-db-type :initform :unknown))) diff --git a/db-mysql/mysql-objects.lisp b/db-mysql/mysql-objects.lisp index ae24cac..bbe5232 100644 --- a/db-mysql/mysql-objects.lisp +++ b/db-mysql/mysql-objects.lisp @@ -15,14 +15,19 @@ (in-package #:clsql-mysql) -(defmethod database-get-type-specifier ((type (eql 'wall-time)) args (database mysql-database)) - (declare (ignore args)) +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database + (db-type (eql :mysql))) + (declare (ignore args database)) "DATETIME") -(defmethod database-output-sql-as-type ((type (eql 'boolean)) val (database mysql-database)) +(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database + (db-type (eql :mysql))) + (declare (ignore database)) (if val 1 0)) -(defmethod read-sql-value (val (type (eql 'boolean)) (database mysql-database)) +(defmethod read-sql-value (val (type (eql 'boolean)) database + (db-type (eql :mysql))) + (declare (ignore database)) (etypecase val (string (if (string= "0" val) nil t)) (integer (if (zerop val) nil t)))) diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index 227c217..0ed1ebe 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -25,7 +25,7 @@ ;; ODBC interface -(defclass odbc-database (database) +(defclass odbc-database (generic-odbc-database) ((odbc-conn :accessor database-odbc-conn :initarg :odbc-conn) (odbc-db-type :accessor database-odbc-db-type))) diff --git a/db-oracle/oracle-objects.lisp b/db-oracle/oracle-objects.lisp index b4467ca..5f26515 100644 --- a/db-oracle/oracle-objects.lisp +++ b/db-oracle/oracle-objects.lisp @@ -17,81 +17,106 @@ (defparameter *oracle-default-varchar2-length* "512") -(defmethod database-get-type-specifier (type args (database oracle-database)) - (declare (ignore type args)) +(defmethod database-get-type-specifier (type args database (db-type (eql :oracle))) + (declare (ignore type args database)) (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")")) -(defmethod database-get-type-specifier ((type (eql 'integer)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'integer)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "NUMBER(~A,~A)" (or (first args) 38) (or (second args) 0)) "INTEGER")) -(defmethod database-get-type-specifier ((type (eql 'bigint)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'bigint)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "NUMBER(~A,~A)" (or (first args) 38) (or (second args) 0)) "NUMBER(38,0)")) -(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "VARCHAR2(~A)" (car args)) (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) -(defmethod database-get-type-specifier ((type (eql 'simple-string)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'simple-string)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "VARCHAR2(~A)" (car args)) (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) -(defmethod database-get-type-specifier ((type (eql 'string)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'string)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "VARCHAR2(~A)" (car args)) (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) -(defmethod database-get-type-specifier ((type (eql 'raw-string)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'raw-string)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "VARCHAR2(~A)" (car args)) (concatenate 'string "VARCHAR2(" *oracle-default-varchar2-length* ")"))) -(defmethod database-get-type-specifier ((type (eql 'float)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'float)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "NUMBER(~A,~A)" (or (first args) 38) (or (second args) 38)) "double precision")) -(defmethod database-get-type-specifier ((type (eql 'long-float)) args (database oracle-database)) +(defmethod database-get-type-specifier ((type (eql 'long-float)) args + database (db-type (eql :oracle))) + (declare (ignore database)) (if args (format nil "NUMBER(~A,~A)" (or (first args) 38) (or (second args) 38)) "double precision")) -(defmethod database-get-type-specifier ((type (eql 'boolean)) args (database oracle-database)) - (declare (ignore args)) +(defmethod database-get-type-specifier ((type (eql 'boolean)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) "CHAR(1)") -(defmethod read-sql-value (val type (database oracle-database)) +(defmethod read-sql-value (val type + database (db-type (eql :oracle))) ;;(format t "value is \"~A\" of type ~A~%" val (type-of val)) - (declare (ignore type)) + (declare (ignore type database)) (etypecase val (string (read-from-string val)) (symbol nil))) -(defmethod read-sql-value - (val (type (eql 'integer)) (database oracle-database)) +(defmethod read-sql-value (val (type (eql 'integer)) + database (db-type (eql :oracle))) + (declare (ignore database)) val) -(defmethod read-sql-value (val (type (eql 'float)) (database oracle-database)) +(defmethod read-sql-value (val (type (eql 'float)) + database (db-type (eql :oracle))) + (declare (ignore database)) val) -(defmethod read-sql-value (val (type (eql 'boolean)) (database oracle-database)) +(defmethod read-sql-value (val (type (eql 'boolean)) + database (db-type (eql :oracle))) + (declare (ignore database)) (when (char-equal #\t (schar val 0)) t)) -(defmethod database-get-type-specifier ((type (eql 'wall-time)) args (database oracle-database)) - (declare (ignore args)) +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) "DATE") -(defmethod database-get-type-specifier ((type (eql 'duration)) args (database oracle-database)) - (declare (ignore args)) +(defmethod database-get-type-specifier ((type (eql 'duration)) args + database (db-type (eql :oracle))) + (declare (ignore args database)) "NUMBER(38)") diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 0bfc01b..f4c1250 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -143,7 +143,7 @@ doesn't depend on UFFI." (eql :postgresql-socket))) t) -(defclass postgresql-socket-database (database) +(defclass postgresql-socket-database (generic-postgresql-database) ((connection :accessor database-connection :initarg :connection :type postgresql-connection))) @@ -323,148 +323,6 @@ doesn't depend on UFFI." (setf (postgresql-socket-result-set-done result-set) t) (wait-for-query-results (database-connection database))))))) -;;; Object listing - -(defun owner-clause (owner) - (cond - ((stringp owner) - (format - nil - " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" - owner)) - ((null owner) - (format nil " AND (NOT (relowner=1))")) - (t ""))) - -(defun database-list-objects-of-type (database type owner) - (mapcar #'car - (database-query - (format nil - "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" - type - (owner-clause owner)) - database nil nil))) - -(defmethod database-list-tables ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "r" owner)) - -(defmethod database-list-views ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "v" owner)) - -(defmethod database-list-indexes ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "i" owner)) - -(defmethod database-list-table-indexes (table - (database postgresql-socket-database) - &key (owner nil)) - (let ((indexrelids - (database-query - (format - nil - "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)" - (string-downcase table) - (owner-clause owner)) - database :auto nil)) - (result nil)) - (dolist (indexrelid indexrelids (nreverse result)) - (push - (caar (database-query - (format nil "select relname from pg_class where relfilenode='~A'" - (car indexrelid)) - database nil nil)) - result)))) - -(defmethod database-list-attributes ((table string) - (database postgresql-socket-database) - &key (owner nil)) - (let* ((owner-clause - (cond ((stringp owner) - (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner)) - ((null owner) " AND (not (relowner=1))") - (t ""))) - (result - (mapcar #'car - (database-query - (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A" - (string-downcase table) - owner-clause) - database nil nil)))) - (if result - (remove-if #'(lambda (it) (member it '("cmin" - "cmax" - "xmax" - "xmin" - "oid" - "ctid" - ;; kmr -- added tableoid - "tableoid") :test #'equal)) - result)))) - -(defmethod database-attribute-type (attribute (table string) - (database postgresql-socket-database) - &key (owner nil)) - (let ((row (car (database-query - (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A" - (string-downcase table) - (string-downcase attribute) - (owner-clause owner)) - database nil nil)))) - (when row - (values - (ensure-keyword (first row)) - (if (string= "-1" (second row)) - (- (parse-integer (third row) :junk-allowed t) 4) - (parse-integer (second row))) - nil - (if (string-equal "f" (fourth row)) - 1 - 0))))) - -(defmethod database-create-sequence (sequence-name - (database postgresql-socket-database)) - (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) - database)) - -(defmethod database-drop-sequence (sequence-name - (database postgresql-socket-database)) - (database-execute-command - (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) - -(defmethod database-list-sequences ((database postgresql-socket-database) - &key (owner nil)) - (database-list-objects-of-type database "S" owner)) - -(defmethod database-set-sequence-position (name (position integer) - (database postgresql-socket-database)) - (values - (parse-integer - (caar - (database-query - (format nil "SELECT SETVAL ('~A', ~A)" name position) - database nil nil))))) - -(defmethod database-sequence-next (sequence-name - (database postgresql-socket-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") - database nil nil))))) - -(defmethod database-sequence-last (sequence-name (database postgresql-socket-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") - database nil nil))))) - - (defmethod database-create (connection-spec (type (eql :postgresql-socket))) (destructuring-bind (host name user password) connection-spec (let ((database (database-connect (list host "template1" user password) @@ -487,32 +345,6 @@ doesn't depend on UFFI." :key #'car :test #'string-equal) t)) -(defmethod database-list (connection-spec (type (eql :postgresql-socket))) - (destructuring-bind (host name user password) connection-spec - (declare (ignore name)) - (let ((database (database-connect (list host "template1" user password) - type))) - (unwind-protect - (progn - (setf (slot-value database 'clsql-sys::state) :open) - (mapcar #'car (database-query "select datname from pg_database" - database :auto nil))) - (progn - (database-disconnect database) - (setf (slot-value database 'clsql-sys::state) :closed)))))) - -(defmethod database-describe-table ((database postgresql-socket-database) - table) - (database-query - (format nil "select a.attname, t.typname - from pg_class c, pg_attribute a, pg_type t - where c.relname = '~a' - and a.attnum > 0 - and a.attrelid = c.oid - and a.atttypid = t.oid" - (sql-escape (string-downcase table))) - database :auto nil)) - ;; Database capabilities @@ -525,5 +357,8 @@ doesn't depend on UFFI." (defmethod db-type-default-case ((db-type (eql :postgresql-socket))) :lower) +(defmethod db-underlying-type ((database postgresql-socket-database)) + :postgresql) + (when (clsql-sys:database-type-library-loaded :postgresql-socket) (clsql-sys:initialize-database-type :database-type :postgresql-socket)) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 447bd7e..bcfda5e 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -77,7 +77,7 @@ (uffi:def-type pgsql-result-def pgsql-result) -(defclass postgresql-database (database) +(defclass postgresql-database (generic-postgresql-database) ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr :type pgsql-conn-def) (lock @@ -373,144 +373,7 @@ ;;; Object listing -(defun owner-clause (owner) - (cond - ((stringp owner) - (format - nil - " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" - owner)) - ((null owner) - (format nil " AND (NOT (relowner=1))")) - (t ""))) - -(defun database-list-objects-of-type (database type owner) - (mapcar #'car - (database-query - (format nil - "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" - type - (owner-clause owner)) - database nil nil))) - -(defmethod database-list-tables ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "r" owner)) - -(defmethod database-list-views ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "v" owner)) - -(defmethod database-list-indexes ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "i" owner)) - - -(defmethod database-list-table-indexes (table (database postgresql-database) - &key (owner nil)) - (let ((indexrelids - (database-query - (format - nil - "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)" - (string-downcase table) - (owner-clause owner)) - database :auto nil)) - (result nil)) - (dolist (indexrelid indexrelids (nreverse result)) - (push - (caar (database-query - (format nil "select relname from pg_class where relfilenode='~A'" - (car indexrelid)) - database nil nil)) - result)))) - -(defmethod database-list-attributes ((table string) - (database postgresql-database) - &key (owner nil)) - (let* ((owner-clause - (cond ((stringp owner) - (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner)) - ((null owner) " AND (not (relowner=1))") - (t ""))) - (result - (mapcar #'car - (database-query - (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A" - (string-downcase table) - owner-clause) - database nil nil)))) - (if result - (remove-if #'(lambda (it) (member it '("cmin" - "cmax" - "xmax" - "xmin" - "oid" - "ctid" - ;; kmr -- added tableoid - "tableoid") :test #'equal)) - result)))) - -(defmethod database-attribute-type (attribute (table string) - (database postgresql-database) - &key (owner nil)) - (let ((row (car (database-query - (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A" - (string-downcase table) - (string-downcase attribute) - (owner-clause owner)) - database nil nil)))) - (when row - (values - (ensure-keyword (first row)) - (if (string= "-1" (second row)) - (- (parse-integer (third row) :junk-allowed t) 4) - (parse-integer (second row))) - nil - (if (string-equal "f" (fourth row)) - 1 - 0))))) - -(defmethod database-create-sequence (sequence-name - (database postgresql-database)) - (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) - database)) - -(defmethod database-drop-sequence (sequence-name - (database postgresql-database)) - (database-execute-command - (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) - -(defmethod database-list-sequences ((database postgresql-database) - &key (owner nil)) - (database-list-objects-of-type database "S" owner)) - -(defmethod database-set-sequence-position (name (position integer) - (database postgresql-database)) - (values - (parse-integer - (caar - (database-query - (format nil "SELECT SETVAL ('~A', ~A)" name position) - database nil nil))))) - -(defmethod database-sequence-next (sequence-name - (database postgresql-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") - database nil nil))))) - -(defmethod database-sequence-last (sequence-name (database postgresql-database)) - (values - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") - database nil nil))))) + (defmethod database-create (connection-spec (type (eql :postgresql))) (destructuring-bind (host name user password) connection-spec @@ -548,30 +411,6 @@ :key #'car :test #'string-equal) t)) -(defmethod database-list (connection-spec (type (eql :postgresql))) - (destructuring-bind (host name user password) connection-spec - (declare (ignore name)) - (let ((database (database-connect (list host "template1" user password) - type))) - (unwind-protect - (progn - (setf (slot-value database 'clsql-sys::state) :open) - (mapcar #'car (database-query "select datname from pg_database" - database nil nil))) - (progn - (database-disconnect database) - (setf (slot-value database 'clsql-sys::state) :closed)))))) - -(defmethod database-describe-table ((database postgresql-database) table) - (database-query - (format nil "select a.attname, t.typname - from pg_class c, pg_attribute a, pg_type t - where c.relname = '~a' - and a.attnum > 0 - and a.attrelid = c.oid - and a.atttypid = t.oid" - (sql-escape (string-downcase table))) - database :auto nil)) (defun %pg-database-connection (connection-spec) (check-connection-spec connection-spec :postgresql diff --git a/sql/classes.lisp b/sql/classes.lisp index bd87f78..3bde105 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -768,7 +768,8 @@ uninclusive, and the args from that keyword to the end." (write-char #\Space *sql-stream*) (write-string (if (stringp db-type) db-type ; override definition - (database-get-type-specifier (car type) (cdr type) database)) + (database-get-type-specifier (car type) (cdr type) database + (database-underlying-type database))) *sql-stream*) (let ((constraints (database-constraint-statement (if (and db-type (symbolp db-type)) diff --git a/sql/db-interface.lisp b/sql/db-interface.lisp index 7699841..3c2f746 100644 --- a/sql/db-interface.lisp +++ b/sql/db-interface.lisp @@ -172,11 +172,11 @@ if unable to destory.")) (:method ((database t)) (signal-no-database-error database))) -(defgeneric database-get-type-specifier (type args database) +(defgeneric database-get-type-specifier (type args database db-underlying-type) (:documentation "Return the type SQL type specifier as a string, for the given lisp type and parameters.") - (:method (type args (database t)) - (declare (ignore type args)) + (:method (type args database db-underlying-type) + (declare (ignore type args db-type)) (signal-no-database-error database))) (defgeneric database-list-tables (database &key owner) diff --git a/sql/generic-odbc.lisp b/sql/generic-odbc.lisp new file mode 100644 index 0000000..a5e8c68 --- /dev/null +++ b/sql/generic-odbc.lisp @@ -0,0 +1,25 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id$ +;;;; +;;;; Generic ODBC layer, used by db-odbc and db-aodbc backends +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(defclass generic-odbc-database (database) + () + (:documentation "Encapsulate same behavior across odbc and aodbc backends.")) + +(defmethod read-sql-value (val (type (eql 'boolean)) + (database generic-odbc-database) + (db-type (eql :postgresql))) + (if (string= "0" val) nil t)) + diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp new file mode 100644 index 0000000..af0ef61 --- /dev/null +++ b/sql/generic-postgresql.lisp @@ -0,0 +1,229 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id$ +;;;; +;;;; Generic postgresql layer, used by db-postgresql and db-postgresql-socket +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(defclass generic-postgresql-database (database) + () + (:documentation "Encapsulate same behavior across postgresql and postgresql-socket backends.")) + + + +;; Object functions + +(defmethod database-get-type-specifier (type args database + (db-type (eql :postgresql))) + (declare (ignore type args database)) + "VARCHAR") + +(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args database + (db-type (eql :postgresql))) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + "VARCHAR")) + +(defmethod database-get-type-specifier ((type (eql 'simple-string)) args database + (db-type (eql :postgresql))) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + "VARCHAR")) + +(defmethod database-get-type-specifier ((type (eql 'string)) args database + (db-type (eql :postgresql))) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + "VARCHAR")) + +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database + (db-type (eql :postgresql))) + (declare (ignore args database)) + "TIMESTAMP WITHOUT TIME ZONE") + + +;;; Backend functions + +(defun owner-clause (owner) + (cond + ((stringp owner) + (format + nil + " AND (relowner=(SELECT usesysid FROM pg_user WHERE (usename='~A')))" + owner)) + ((null owner) + (format nil " AND (NOT (relowner=1))")) + (t ""))) + +(defun database-list-objects-of-type (database type owner) + (mapcar #'car + (database-query + (format nil + "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" + type + (owner-clause owner)) + database nil nil))) + +(defmethod database-list-tables ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "r" owner)) + +(defmethod database-list-views ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "v" owner)) + +(defmethod database-list-indexes ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "i" owner)) + + +(defmethod database-list-table-indexes (table (database generic-postgresql-database) + &key (owner nil)) + (let ((indexrelids + (database-query + (format + nil + "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)" + (string-downcase table) + (owner-clause owner)) + database :auto nil)) + (result nil)) + (dolist (indexrelid indexrelids (nreverse result)) + (push + (caar (database-query + (format nil "select relname from pg_class where relfilenode='~A'" + (car indexrelid)) + database nil nil)) + result)))) + +(defmethod database-list-attributes ((table string) + (database generic-postgresql-database) + &key (owner nil)) + (let* ((owner-clause + (cond ((stringp owner) + (format nil " AND (relowner=(SELECT usesysid FROM pg_user WHERE usename='~A'))" owner)) + ((null owner) " AND (not (relowner=1))") + (t ""))) + (result + (mapcar #'car + (database-query + (format nil "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'~A" + (string-downcase table) + owner-clause) + database nil nil)))) + (if result + (remove-if #'(lambda (it) (member it '("cmin" + "cmax" + "xmax" + "xmin" + "oid" + "ctid" + ;; kmr -- added tableoid + "tableoid") :test #'equal)) + result)))) + +(defmethod database-attribute-type (attribute (table string) + (database generic-postgresql-database) + &key (owner nil)) + (let ((row (car (database-query + (format nil "SELECT pg_type.typname,pg_attribute.attlen,pg_attribute.atttypmod,pg_attribute.attnotnull FROM pg_type,pg_class,pg_attribute WHERE pg_class.oid=pg_attribute.attrelid AND pg_class.relname='~A' AND pg_attribute.attname='~A' AND pg_attribute.atttypid=pg_type.oid~A" + (string-downcase table) + (string-downcase attribute) + (owner-clause owner)) + database nil nil)))) + (when row + (values + (ensure-keyword (first row)) + (if (string= "-1" (second row)) + (- (parse-integer (third row) :junk-allowed t) 4) + (parse-integer (second row))) + nil + (if (string-equal "f" (fourth row)) + 1 + 0))))) + +(defmethod database-create-sequence (sequence-name + (database generic-postgresql-database)) + (database-execute-command + (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) + database)) + +(defmethod database-drop-sequence (sequence-name + (database generic-postgresql-database)) + (database-execute-command + (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database)) + +(defmethod database-list-sequences ((database generic-postgresql-database) + &key (owner nil)) + (database-list-objects-of-type database "S" owner)) + +(defmethod database-set-sequence-position (name (position integer) + (database generic-postgresql-database)) + (values + (parse-integer + (caar + (database-query + (format nil "SELECT SETVAL ('~A', ~A)" name position) + database nil nil))))) + +(defmethod database-sequence-next (sequence-name + (database generic-postgresql-database)) + (values + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") + database nil nil))))) + +(defmethod database-sequence-last (sequence-name (database generic-postgresql-database)) + (values + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT LAST_VALUE ('" sequence-name "')") + database nil nil))))) + +(defun postgresql-database-list (connection-spec type) + (destructuring-bind (host name user password) connection-spec + (declare (ignore name)) + (let ((database (database-connect (list host "template1" user password) + type))) + (unwind-protect + (progn + (setf (slot-value database 'clsql-sys::state) :open) + (mapcar #'car (database-query "select datname from pg_database" + database nil nil))) + (progn + (database-disconnect database) + (setf (slot-value database 'clsql-sys::state) :closed)))))) + +(defmethod database-list (connection-spec (type (eql :postgresql))) + (postgresql-database-list connection-spec type)) + +(defmethod database-list (connection-spec (type (eql :postgresql-socket))) + (postgresql-database-list connection-spec type)) + + +(defmethod database-describe-table ((database generic-postgresql-database) table) + (database-query + (format nil "select a.attname, t.typname + from pg_class c, pg_attribute a, pg_type t + where c.relname = '~a' + and a.attnum > 0 + and a.attrelid = c.oid + and a.atttypid = t.oid" + (sql-escape (string-downcase table))) + database :auto nil)) + diff --git a/sql/generics.lisp b/sql/generics.lisp index ac9f0bd..817547d 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -119,8 +119,8 @@ DATABASE-NULL-VALUE on the type of the slot.")) ) (defgeneric get-slot-values-from-view (obj slotdeflist values) ) -(defgeneric database-output-sql-as-type (type val database) +(defgeneric database-output-sql-as-type (type val database db-type) ) -(defgeneric read-sql-value (val type database) +(defgeneric read-sql-value (val type database db-type) ) diff --git a/sql/objects.lisp b/sql/objects.lisp index 2111b7a..3d031e2 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -291,8 +291,10 @@ strings." (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) (read-sql-value value (delistify slot-type) - (view-database instance)))) - ((null value) + (view-database instance) + (database-underlying-type + (view-database instance))))) + ((null value) (update-slot-with-null instance slot-name slotdef)) ((typep slot-reader 'string) (setf (slot-value instance slot-name) @@ -308,7 +310,8 @@ strings." (let ((slot-reader (view-class-slot-db-reader slotdef)) (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) - (read-sql-value value (delistify slot-type) database)) + (read-sql-value value (delistify slot-type) database + (database-underlying-type database))) ((null value) nil) ((typep slot-reader 'string) @@ -325,11 +328,11 @@ strings." (string (format nil dbwriter val)) (function (apply dbwriter (list val))) (t - (typecase dbtype - (cons - (database-output-sql-as-type (car dbtype) val database)) - (t - (database-output-sql-as-type dbtype val database))))))) + (database-output-sql-as-type + (typecase dbtype + (cons (car dbtype)) + (t dbtype)) + val database (database-underlying-type database)))))) (defun check-slot-type (slotdef val) (let* ((slot-type (specified-type slotdef)) @@ -499,16 +502,12 @@ strings." (error "No view-table for class ~A" classname)) (sql-expression :table (view-table class)))) -(defmethod database-get-type-specifier (type args (database database)) - (declare (ignore type args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)")) +(defmethod database-get-type-specifier (type args database db-type) + (declare (ignore type args database db-type)) + "VARCHAR(255)") -(defmethod database-get-type-specifier ((type (eql 'integer)) args database) - (declare (ignore database)) - ;;"INT8") +(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "INT(~A)" (car args)) "INT")) @@ -517,98 +516,89 @@ strings." "An integer larger than a 32-bit integer, this width may vary by SQL implementation." 'integer) -(defmethod database-get-type-specifier ((type (eql 'bigint)) args database) - (declare (ignore args database)) +(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type) + (declare (ignore args database db-type)) "BIGINT") (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args - database) + database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)"))) + "VARCHAR(255)")) (defmethod database-get-type-specifier ((type (eql 'simple-string)) args - database) + database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)"))) + "VARCHAR(255)")) -(defmethod database-get-type-specifier ((type (eql 'string)) args database) +(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (if (in (database-underlying-type database) - :postgresql :postgresql-socket) - "VARCHAR" - "VARCHAR(255)"))) + "VARCHAR(255)")) (deftype universal-time () "A positive integer as returned by GET-UNIVERSAL-TIME." '(integer 1 *)) -(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database) - (declare (ignore args database)) +(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type) + (declare (ignore args database db-type)) "BIGINT") -(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) - (declare (ignore args)) - (case (database-underlying-type database) - ((:postgresql :postgresql-socket) - "TIMESTAMP WITHOUT TIME ZONE") - (t "TIMESTAMP"))) +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type) + (declare (ignore args database db-type)) + "TIMESTAMP") -(defmethod database-get-type-specifier ((type (eql 'duration)) args database) - (declare (ignore database args)) +(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type) + (declare (ignore database args db-type)) "VARCHAR") -(defmethod database-get-type-specifier ((type (eql 'money)) args database) - (declare (ignore database args)) +(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type) + (declare (ignore database args db-type)) "INT8") (deftype raw-string (&optional len) "A string which is not trimmed when retrieved from the database" `(string ,len)) -(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) - (declare (ignore database)) +(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) "VARCHAR")) -(defmethod database-get-type-specifier ((type (eql 'float)) args database) - (declare (ignore database)) +(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "FLOAT(~A)" (car args)) "FLOAT")) -(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) - (declare (ignore database)) +(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type) + (declare (ignore database db-type)) (if args (format nil "FLOAT(~A)" (car args)) "FLOAT")) -(defmethod database-get-type-specifier ((type (eql 'boolean)) args database) - (declare (ignore args database)) +(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type) + (declare (ignore args database db-type)) "BOOL") -(defmethod database-output-sql-as-type (type val database) - (declare (ignore type database)) +(defmethod database-output-sql-as-type (type val database db-type) + (declare (ignore type database db-type)) val) -(defmethod database-output-sql-as-type ((type (eql 'list)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type) + (declare (ignore database db-type)) (progv '(*print-circle* *print-array*) '(t t) (let ((escaped (prin1-to-string val))) (substitute-char-string escaped #\Null " ")))) -(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type) + (declare (ignore database db-type)) (if (keywordp val) (symbol-name val) (if val @@ -618,91 +608,91 @@ strings." (symbol-name val)) ""))) -(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type) + (declare (ignore database db-type)) (if val (symbol-name val) "")) -(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type) + (declare (ignore database db-type)) (progv '(*print-circle* *print-array*) '(t t) (prin1-to-string val))) -(defmethod database-output-sql-as-type ((type (eql 'array)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type) + (declare (ignore database db-type)) (progv '(*print-circle* *print-array*) '(t t) (prin1-to-string val))) -(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type) + (declare (ignore database db-type)) (if val "t" "f")) -(defmethod database-output-sql-as-type ((type (eql 'string)) val database) - (declare (ignore database)) +(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type) + (declare (ignore database db-type)) val) (defmethod database-output-sql-as-type ((type (eql 'simple-string)) - val database) - (declare (ignore database)) + val database db-type) + (declare (ignore database db-type)) val) (defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) - val database) - (declare (ignore database)) + val database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val type database) - (declare (ignore type database)) +(defmethod read-sql-value (val type database db-type) + (declare (ignore type database db-type)) (read-from-string val)) -(defmethod read-sql-value (val (type (eql 'string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'simple-string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'simple-string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'raw-string)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'raw-string)) database db-type) + (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'keyword)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'keyword)) database db-type) + (declare (ignore database db-type)) (when (< 0 (length val)) (intern (symbol-name-default-case val) (find-package '#:keyword)))) -(defmethod read-sql-value (val (type (eql 'symbol)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'symbol)) database db-type) + (declare (ignore database db-type)) (when (< 0 (length val)) (unless (string= val (symbol-name-default-case "NIL")) (intern (symbol-name-default-case val) (symbol-package *update-context*))))) -(defmethod read-sql-value (val (type (eql 'integer)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'integer)) database db-type) + (declare (ignore database db-type)) (etypecase val (string (unless (string-equal "NIL" val) (parse-integer val))) (number val))) -(defmethod read-sql-value (val (type (eql 'bigint)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'bigint)) database db-type) + (declare (ignore database db-type)) (etypecase val (string (unless (string-equal "NIL" val) (parse-integer val))) (number val))) -(defmethod read-sql-value (val (type (eql 'float)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'float)) database db-type) + (declare (ignore database db-type)) ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) (etypecase val (string @@ -710,30 +700,25 @@ strings." (float val))) -(defmethod read-sql-value (val (type (eql 'boolean)) database) - (case (database-underlying-type database) - (:postgresql - (if (eq :odbc (database-type database)) - (if (string= "0" val) nil t) - (equal "t" val))) - (t - (equal "t" val)))) - -(defmethod read-sql-value (val (type (eql 'univeral-time)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'boolean)) database db-type) + (declare (ignore database db-type)) + (equal "t" val)) + +(defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type) + (declare (ignore database db-type)) (unless (eq 'NULL val) (etypecase val (string (parse-integer val)) (number val)))) -(defmethod read-sql-value (val (type (eql 'wall-time)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type) + (declare (ignore database db-type)) (unless (eq 'NULL val) (parse-timestring val))) -(defmethod read-sql-value (val (type (eql 'duration)) database) - (declare (ignore database)) +(defmethod read-sql-value (val (type (eql 'duration)) database db-type) + (declare (ignore database db-type)) (unless (or (eq 'NULL val) (equal "NIL" val)) (parse-timestring val))) diff --git a/sql/package.lisp b/sql/package.lisp index 20555d6..8b4475e 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -114,7 +114,6 @@ #:database-query-result-set #:database-dump-result-set #:database-store-next-row - #:database-get-type-specifier #:database-list-tables #:database-table-exists-p #:database-list-views @@ -145,6 +144,9 @@ #:db-type-default-case #:db-type-use-column-on-drop-index? #:database-underlying-type + #:database-get-type-specifier + #:read-sql-value + #:database-output-sql-as-type ;; Large objects #:database-create-large-object @@ -169,8 +171,7 @@ #:database-type #:database-state #:attribute-cache - - + ;; utils.lisp #:without-interrupts #:make-process-lock @@ -195,6 +196,10 @@ #:float-to-sql-string #:sql-escape-quotes #:in + + ;; Generic backends + #:generic-postgresql-database + #:generic-odbc-database . ;; Shared exports for re-export by CLSQL package. @@ -295,10 +300,6 @@ #:bigint ;;OODML #:*db-auto-sync* ; objects xx - #:read-sql-value ; objects x - #:database-output-sql-as-type ; objects x - #:database-get-type-specifier ; objects x - #:database-output-sql ; sql/class xx ;; conditions #:clsql-condition diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 543ab87..9af59da 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -574,11 +574,11 @@ (values (nreverse test-forms) (nreverse skip-tests)))) -(defun rapid-load (type) +(defun rapid-load (type &optional (position 0)) "Rapid load for interactive testing." (when *default-database* (disconnect :database *default-database*)) - (test-connect-to-database type (car (db-type-spec type (read-specs)))) + (test-connect-to-database type (nth position (db-type-spec type (read-specs)))) (test-initialise-database) *default-database*)