From 43ec897ec7d84892fa59cc9b7858ce23d64a8a1a Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 2 Apr 2004 20:45:48 +0000 Subject: [PATCH] r8811: add support for usql backend, integrate Marcus Pearce patches --- ChangeLog | 4 + base/classes.lisp | 7 +- base/conditions.lisp | 23 +++ base/db-interface.lisp | 23 ++- base/initialize.lisp | 4 +- base/package.lisp | 12 +- clsql-postgresql-socket.asd | 4 +- db-mysql/mysql-api.lisp | 6 +- db-mysql/mysql-usql.lisp | 66 ++++++-- .../postgresql-socket-usql.lisp | 160 ++++++++++++++++++ db-postgresql/postgresql-usql.lisp | 115 +++++++++---- db-sqlite/sqlite-sql.lisp | 5 +- db-sqlite/sqlite-usql.lisp | 95 ++++++++--- debian/changelog | 6 + 14 files changed, 452 insertions(+), 78 deletions(-) create mode 100644 db-postgresql-socket/postgresql-socket-usql.lisp diff --git a/ChangeLog b/ChangeLog index 554b73d..e9b659f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +02 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Integrate patch from Marcus Pearce + adding further support for providing backend for UncommonSQL + 10 Mar 2004 Kevin Rosenberg (kevin@rosenberg.net) * Integrate patch from Aurelio Bignoli for SQLite backend diff --git a/base/classes.lisp b/base/classes.lisp index 104c7b6..26655d8 100644 --- a/base/classes.lisp +++ b/base/classes.lisp @@ -24,8 +24,13 @@ (defclass database () ((name :initform nil :initarg :name :reader database-name) - (connection-spec :initform nil :initarg :connection-spec :reader connection-spec + (connection-spec :initform nil :initarg :connection-spec + :reader connection-spec :documentation "Require to use connection pool") + (command-recording-stream :accessor command-recording-stream :initform nil) + (result-recording-stream :accessor result-recording-stream :initform nil) + (view-classes :accessor database-view-classes :initform nil) + (schema :accessor database-schema :initform nil) (transaction-level :initform 0 :accessor transaction-level) (transaction :initform nil :accessor transaction) (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool)) diff --git a/base/conditions.lisp b/base/conditions.lisp index 228ed36..7fc7781 100644 --- a/base/conditions.lisp +++ b/base/conditions.lisp @@ -157,3 +157,26 @@ and signal an clsql-invalid-spec-error if they don't match." 'clsql-nodb-error :database database)) + +;; for USQL support + +(define-condition clsql-type-error (clsql-error clsql-condition) + ((slotname :initarg :slotname + :reader clsql-type-error-slotname) + (typespec :initarg :typespec + :reader clsql-type-error-typespec) + (value :initarg :value + :reader clsql-type-error-value)) + (:report (lambda (c stream) + (format stream + "Invalid value ~A in slot ~A, not of type ~A." + (clsql-type-error-value c) + (clsql-type-error-slotname c) + (clsql-type-error-typespec c))))) + +(define-condition clsql-sql-syntax-error (clsql-error) + ((reason :initarg :reason + :reader clsql-sql-syntax-error-reason)) + (:report (lambda (c stream) + (format stream "Invalid SQL syntax: ~A" + (clsql-sql-syntax-error-reason c))))) \ No newline at end of file diff --git a/base/db-interface.lisp b/base/db-interface.lisp index 8b60847..a27a958 100644 --- a/base/db-interface.lisp +++ b/base/db-interface.lisp @@ -134,6 +134,15 @@ returns nil when result-set is finished.")) (defgeneric database-sequence-next (name database) (:documentation "Increment a sequence in DATABASE.")) +(defgeneric database-list-sequences (database &key owner) + (:documentation "List all sequences in DATABASE.")) + +(defgeneric database-set-sequence-position (name position database) + (:documentation "Set the position of the sequence called NAME in DATABASE.")) + +(defgeneric database-sequence-last (name database) + (:documentation "Select the last value in sequence NAME in DATABASE.")) + (defgeneric database-start-transaction (database) (:documentation "Start a transaction in DATABASE.")) @@ -147,13 +156,19 @@ returns nil when result-set is finished.")) (:documentation "Return the type SQL type specifier as a string, for the given lisp type and parameters.")) -(defgeneric database-list-tables (database &key system-tables) +(defgeneric database-list-tables (database &key owner) (:documentation "List all tables in the given database")) + +(defgeneric database-list-views (database &key owner) + (:documentation "List all views in the DATABASE.")) -(defgeneric database-list-attributes (table database) +(defgeneric database-list-indexes (database &key owner) + (:documentation "List all indexes in the DATABASE.")) + +(defgeneric database-list-attributes (table database &key owner) (:documentation "List all attributes in TABLE.")) -(defgeneric database-attribute-type (attribute table database) +(defgeneric database-attribute-type (attribute table database &key owner) (:documentation "Return the type of ATTRIBUTE in TABLE.")) (defgeneric database-add-attribute (table attribute database) @@ -165,7 +180,7 @@ the given lisp type and parameters.")) (defgeneric oid (object) (:documentation "Return the unique ID of a database object.")) - + ;;; Large objects support (Marc Battyani) (defgeneric database-create-large-object (database) diff --git a/base/initialize.lisp b/base/initialize.lisp index ffa08b2..8e98d5e 100644 --- a/base/initialize.lisp +++ b/base/initialize.lisp @@ -45,9 +45,9 @@ to initialize-database-type.") "Initialize the given database-type, if it is not already initialized, as indicated by `*initialized-database-types*'." (if (member database-type *initialized-database-types*) - t + database-type (when (database-initialize-database-type database-type) (push database-type *initialized-database-types*) - t))) + database-type))) diff --git a/base/package.lisp b/base/package.lisp index 3211598..ea9f936 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -48,7 +48,13 @@ #:database-drop-sequence #:database-sequence-next #:sql-escape - + #:database-sequence-last + #:database-set-sequence-position + #:database-list-attributes + #:database-list-sequences + #:database-list-indexes + #:database-list-views + ;; Support for pooled connections #:database-type @@ -89,7 +95,9 @@ #:clsql-exists-error #:clsql-closed-error #:clsql-closed-error-database - + #:clsql-sql-syntax-error + #:clsql-type-error + #:*loaded-database-types* #:reload-database-types #:*default-database-type* diff --git a/clsql-postgresql-socket.asd b/clsql-postgresql-socket.asd index 3955adc..76825b8 100644 --- a/clsql-postgresql-socket.asd +++ b/clsql-postgresql-socket.asd @@ -37,5 +37,7 @@ (:file "postgresql-socket-api" :depends-on ("postgresql-socket-package")) (:file "postgresql-socket-sql" - :depends-on ("postgresql-socket-api"))))) + :depends-on ("postgresql-socket-api")) + (:file "postgresql-socket-usql" + :depends-on ("postgresql-socket-sql"))))) :depends-on (:clsql-base :uffi :md5)) diff --git a/db-mysql/mysql-api.lisp b/db-mysql/mysql-api.lisp index 480345d..7170fda 100644 --- a/db-mysql/mysql-api.lisp +++ b/db-mysql/mysql-api.lisp @@ -106,7 +106,7 @@ (:var-string 253) (:string 254))) -#+:mysql-client-v3 +#+mysql-client-v3 (uffi:def-struct mysql-field (name (* :char)) (table (* :char)) @@ -118,7 +118,7 @@ (decimals :unsigned-int)) ;; structure changed in mysql 4 client -#+:mysql-client-v4 +#+mysql-client-v4 (uffi:def-struct mysql-field (name (* :char)) (table (* :char)) @@ -260,7 +260,7 @@ ;; Need to comment this out for LW 4.2.6 ;; ? bug in LW version -;;(declaim (inline mysql-real-connect)) +#-lispworks (declaim (inline mysql-real-connect)) (uffi:def-function "mysql_real_connect" ((mysql (* mysql-mysql)) (host :cstring) diff --git a/db-mysql/mysql-usql.lisp b/db-mysql/mysql-usql.lisp index 06f574c..8b198e0 100644 --- a/db-mysql/mysql-usql.lisp +++ b/db-mysql/mysql-usql.lisp @@ -21,26 +21,46 @@ ;; Table and attribute introspection -(defmethod database-list-tables ((database mysql-database) - &key (system-tables nil)) - (declare (ignore system-tables)) - (mapcar #'car (database-query "show tables" database :auto))) +(defmethod database-list-tables ((database mysql-database) &key (owner nil)) + (declare (ignore owner)) + (remove-if #'(lambda (s) + (and (>= (length s) 10) + (string= (subseq s 0 10) "_usql_seq_"))) + (mapcar #'car (database-query "SHOW TABLES" database nil)))) +;; MySQL 4.1 does not support views +(defmethod database-list-views ((database mysql-database) + &key (owner nil)) + (declare (ignore owner database)) + nil) -(defmethod database-list-attributes ((table string) (database mysql-database)) +(defmethod database-list-indexes ((database mysql-database) + &key (owner nil)) + (let ((result '())) + (dolist (table (database-list-tables database :owner owner) result) + (mapc #'(lambda (index) (push (nth 2 index) result)) + (database-query + (format nil "SHOW INDEX FROM ~A" (string-upcase table)) + database nil))))) + +(defmethod database-list-attributes ((table string) (database mysql-database) + &key (owner nil)) + (declare (ignore owner)) (mapcar #'car (database-query (format nil "SHOW COLUMNS FROM ~A" table) database nil))) (defmethod database-attribute-type (attribute (table string) - (database mysql-database)) + (database mysql-database) + &key (owner nil)) + (declare (ignore owner)) (let ((result - (mapcar #'cadr - (database-query - (format nil - "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) - database nil)))) + (mapcar #'cadr + (database-query + (format nil + "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute) + database nil)))) (let* ((str (car result)) (end-str (position #\( str)) (substr (subseq str 0 end-str))) @@ -52,6 +72,11 @@ (defun %sequence-name-to-table (sequence-name) (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) +(defun %table-name-to-sequence-name (table-name) + (and (>= (length table-name) 10) + (string= (subseq table-name 0 10) "_usql_seq_") + (subseq table-name 10))) + (defmethod database-create-sequence (sequence-name (database mysql-database)) (let ((table-name (%sequence-name-to-table sequence-name))) @@ -70,6 +95,22 @@ (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name)) database)) +(defmethod database-list-sequences ((database mysql-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s))) + (database-query "SHOW TABLES LIKE '%usql_seq%'" + database nil))) + +(defmethod database-set-sequence-position (sequence-name + (position integer) + (database mysql-database)) + (database-execute-command + (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name) + position) + database) + (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) + (defmethod database-sequence-next (sequence-name (database mysql-database)) (database-execute-command (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name) @@ -77,6 +118,9 @@ database) (mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))) +(defmethod database-sequence-last (sequence-name (database mysql-database)) + (declare (ignore sequence-name database))) + ;; Misc USQL functions #| diff --git a/db-postgresql-socket/postgresql-socket-usql.lisp b/db-postgresql-socket/postgresql-socket-usql.lisp new file mode 100644 index 0000000..3c134e2 --- /dev/null +++ b/db-postgresql-socket/postgresql-socket-usql.lisp @@ -0,0 +1,160 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: postgresql-socket-usql.sql +;;;; Purpose: PostgreSQL interface for USQL routines +;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc +;;;; Date Started: Mar 2002 +;;;; +;;;; $Id: postgresql-socket-usql.lisp 7061 2003-09-07 06:34:45Z kevin $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and by onShore Development Inc. +;;;; +;;;; 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-postgresql-socket) + + +(defmethod database-list-objects-of-type ((database postgresql-socket-database) + type owner) + (let ((owner-clause + (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 "")))) + (mapcar #'car + (database-query + (format nil + "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" + type + owner-clause) + database 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-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)))) + (if result + (reverse + (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* ((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 pg_type.typname 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) + database nil)))) + (when result + (intern (string-upcase (car result)) :keyword)))) + +(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))))) + +(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))))) + +(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))))) + + +;; Functions depending upon high-level USQL classes/functions + +#| +(defmethod database-output-sql ((expr clsql-sys::sql-typecast-exp) + (database postgresql-socket-database)) + (with-slots (clsql-sys::modifier clsql-sys::components) + expr + (if clsql-sys::modifier + (progn + (clsql-sys::output-sql clsql-sys::components database) + (write-char #\: clsql-sys::*sql-stream*) + (write-char #\: clsql-sys::*sql-stream*) + (write-string (symbol-name clsql-sys::modifier) + clsql-sys::*sql-stream*))))) + +(defmethod database-output-sql-as-type ((type (eql 'integer)) val + (database postgresql-socket-database)) + (when val ;; typecast it so it uses the indexes + (make-instance 'clsql-sys::sql-typecast-exp + :modifier 'int8 + :components val))) +|# diff --git a/db-postgresql/postgresql-usql.lisp b/db-postgresql/postgresql-usql.lisp index b42438b..ef85e7d 100644 --- a/db-postgresql/postgresql-usql.lisp +++ b/db-postgresql/postgresql-usql.lisp @@ -19,27 +19,50 @@ (in-package #:clsql-postgresql) -(defmethod database-list-tables ((database postgresql-database) - &key (system-tables nil)) - (let ((res (mapcar #'car (database-query - "SELECT tablename FROM pg_tables" - database nil)))) - (if (not system-tables) - (remove-if #'(lambda (table) - (equal (subseq table 0 3) - "pg_")) res) - res))) - - +(defmethod database-list-objects-of-type ((database postgresql-database) + type owner) + (let ((owner-clause + (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 "")))) + (mapcar #'car + (database-query + (format nil + "SELECT relname FROM pg_class WHERE (relkind = '~A')~A" + type + owner-clause) + database 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-attributes ((table string) - (database postgresql-database)) - (let* ((result + (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'" table) - database nil)))) + (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)))) (if result (reverse (remove-if #'(lambda (it) (member it '("cmin" @@ -53,35 +76,65 @@ result))))) (defmethod database-attribute-type (attribute (table string) - (database postgresql-database)) - (let ((result + (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 pg_type.typname 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" - table attribute) + (format nil "SELECT pg_type.typname 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) database nil)))) - (if result - (intern (string-upcase (car result)) :keyword) nil))) - + (when result + (intern (string-upcase (car result)) :keyword)))) (defmethod database-create-sequence (sequence-name (database postgresql-database)) (database-execute-command - (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name)) database)) + (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))))) + (defmethod database-sequence-next (sequence-name (database postgresql-database)) - (parse-integer - (caar - (database-query - (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") - database nil)))) + (values + (parse-integer + (caar + (database-query + (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')") + database 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))))) + ;; Functions depending upon high-level USQL classes/functions diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 78068fb..a2526ed 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -1,4 +1,4 @@ -;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -23,6 +23,9 @@ (defclass sqlite-database (database) ((sqlite-db :initarg :sqlite-db :accessor sqlite-db))) +(defmethod database-type ((database sqlite-database)) + :sqlite) + (defmethod database-initialize-database-type ((database-type (eql :sqlite))) t) diff --git a/db-sqlite/sqlite-usql.lisp b/db-sqlite/sqlite-usql.lisp index 4d66be7..852cf92 100644 --- a/db-sqlite/sqlite-usql.lisp +++ b/db-sqlite/sqlite-usql.lisp @@ -18,9 +18,57 @@ (in-package :clsql-sqlite) +(defmethod database-list-tables ((database sqlite-database) &key owner) + (declare (ignore owner)) + ;; Query is copied from .table command of sqlite comamnd line utility. + (remove-if #'(lambda (s) + (and (>= (length s) 10) + (string= (subseq s 0 10) "_usql_seq_"))) + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" + database '())))) + +(defmethod database-list-views ((database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='view' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='view' ORDER BY name" + database nil))) + +(defmethod database-list-indexes ((database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'car (database-query + "SELECT name FROM sqlite_master WHERE type='index' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' ORDER BY name" + database nil))) + +(declaim (inline sqlite-table-info)) +(defun sqlite-table-info (table database) + (database-query (format nil "PRAGMA table_info('~A')" table) + database '())) + +(defmethod database-list-attributes (table (database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcar #'(lambda (table-info) (second table-info)) + (sqlite-table-info table database))) + +(defmethod database-attribute-type (attribute table + (database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (loop for field-info in (sqlite-table-info table database) + when (string= attribute (second field-info)) + return (third field-info))) + (defun %sequence-name-to-table-name (sequence-name) (concatenate 'string "_usql_seq_" (sql-escape sequence-name))) +(defun %table-name-to-sequence-name (table-name) + (and (>= (length table-name) 10) + (string= (subseq table-name 0 10) "_usql_seq_") + (subseq table-name 10))) + (defmethod database-create-sequence (sequence-name (database sqlite-database)) (let ((table-name (%sequence-name-to-table-name sequence-name))) @@ -39,32 +87,35 @@ (%sequence-name-to-table-name sequence-name)) database)) +(defmethod database-list-sequences ((database sqlite-database) + &key (owner nil)) + (declare (ignore owner)) + (mapcan #'(lambda (s) + (let ((sn (%table-name-to-sequence-name (car s)))) + (and sn (list sn)))) + (database-query + "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" + database '()))) + (defmethod database-sequence-next (sequence-name (database sqlite-database)) (let ((table-name (%sequence-name-to-table-name sequence-name))) (database-execute-command (format nil "UPDATE ~A SET id=(SELECT id FROM ~A)+1" table-name table-name) - database)) - (sqlite:sqlite-last-insert-rowid (sqlite-db database))) - -(defmethod database-list-tables ((database sqlite-database) &key system-tables) - (declare (ignore system-tables)) - ;; Query is copied from .table command of sqlite comamnd line utility. - (mapcar #'car (database-query - "SELECT name FROM sqlite_master WHERE type='table' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='table' ORDER BY name" - database '()))) - -(declaim (inline sqlite-table-info)) -(defun sqlite-table-info (table database) - (database-query (format nil "PRAGMA table_info('~A')" table) - database '())) + database) + (sqlite:sqlite-last-insert-rowid (sqlite-db database)) + (parse-integer + (caar (database-query (format nil "SELECT id from ~A" table-name) + database nil))))) -(defmethod database-list-attributes (table (database sqlite-database)) - (mapcar #'(lambda (table-info) (third table-info)) - (sqlite-table-info table database))) +(defmethod database-set-sequence-position (sequence-name + (position integer) + (database sqlite-database)) + (let ((table-name (%sequence-name-to-table-name sequence-name))) + (database-execute-command + (format nil "UPDATE ~A SET id=~A" table-name position) + database) + (sqlite:sqlite-last-insert-rowid (sqlite-db database)))) -(defmethod database-attribute-type (attribute table - (database sqlite-database)) - (loop for field-info in (sqlite-table-info table database) - when (string= attribute (second field-info)) - return (third field-info))) +(defmethod database-sequence-last (sequence-name (database sqlite-database)) + (declare (ignore sequence-name database))) \ No newline at end of file diff --git a/debian/changelog b/debian/changelog index 7e9bd4c..480160e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (2.0.0-1) unstable; urgency=low + + * New upstream, integrating patch from Marcus Pearce + + -- Kevin M. Rosenberg Fri, 2 Apr 2004 13:34:35 -0700 + cl-sql (1.9.2-1) unstable; urgency=low * Automatically detect mysql version -- 2.34.1