(no subject)
Mészáros Levente <[email protected]> Fri, 25 Nov 2005 08:56:55 +0100 (CET)
| Newsgroups | gmane.lisp.clsql.devel |
|---|---|
| Message-ID | <[email protected]> |
Here is the current version of the alter-table, update-view-from-class stuff. It's not a patch file yet... I merged my changes with Marco's. It has been tested only with MySQL and I will not test against other databases. There are a couple of test cases at the end if someone wants to do so. Status for alter-table: - alter-table-add-column does not handle constraints parameter - alter-table-drop-column works - alter-table-alter-column-type does not handle constraints parameter Status for update-view-from-class: - new slots are added to the table - removed slots are deleted from the table - modified slots are altered only if their database specification is different - constraints are not handled Issues: - databae constraints are not handled throughout the code - list-attribute-types returns INT(11) type specification for INT column types with MySQL, resulting in an alter-table-alter-column-type call even if the actual slot type did not change. Tests: - there are four test cases at the end of the file that uses list-attribute- types and create-view-from-class to check if the same table can be created as with subsequent calls to update-view-from-class. levy ______________________________________________________________________ KGFB 2006 - Garantáltan a legjobb ár! Nyerje meg az új Swiftet + garantált 10,000,- Ft értékű ajándék. WWW.NETRISK.HU _______________________________________________ CLSQL-Devel mailing list [email protected] http://lists.b9.com/mailman/listinfo/clsql-devel
alter-table-patch.lisp
(text/plain, 12.9 KB)
(in-package :clsql-sys)
(defclass sql-alter-table (%sql-expression)
((table-name
:accessor table-name
:initarg :table-name)
(alter-table-action
:accessor alter-table-action
:initarg :alter-table-action))
(:documentation
"An SQL ALTER TABLE statement."))
(defclass sql-alter-table-action (%sql-expression)
())
(defclass sql-alter-table-column-action (sql-alter-table-action)
((column-name
:accessor column-name
:initarg :column-name)
(column-type
:accessor column-type
:initarg :column-type)))
(defclass sql-alter-table-add-column-action (sql-alter-table-column-action)
((default-value
:accessor default-value
:initarg :default-value)
(constraints
:accessor constraints
:initarg :constraints)))
(defclass sql-alter-table-drop-column-action (sql-alter-table-column-action)
())
(defclass sql-alter-table-alter-column-type-action (sql-alter-table-column-action)
((constraints
:accessor constraints
:initarg :constraints)))
(defun database-column-type (column-type database)
(database-get-type-specifier (first (listify column-type))
(rest (listify column-type))
database
(database-underlying-type database)))
(defmethod output-sql ((stmt sql-alter-table) database)
(with-slots (table-name alter-table-action) stmt
(write-string "ALTER TABLE " *sql-stream*)
(output-sql table-name database)
(write-char #\Space *sql-stream*)
(output-sql alter-table-action database)))
;; TODO: output column constraints
(defmethod output-sql ((action sql-alter-table-add-column-action) database)
(with-slots (column-name column-type) action
(write-string "ADD (" *sql-stream*)
(output-sql column-name database)
(write-char #\Space *sql-stream*)
(write-string (database-column-type column-type database) *sql-stream*)
(write-char #\) *sql-stream*)))
(defmethod output-sql ((action sql-alter-table-drop-column-action) database)
(with-slots (column-name) action
(write-string "DROP COLUMN " *sql-stream*)
(output-sql column-name database)))
;; TODO: output column constraints
(defmethod output-sql ((action sql-alter-table-alter-column-type-action) database)
(with-slots (column-name column-type) action
(write-string "ALTER COLUMN " *sql-stream*)
(output-sql column-name database)
(write-string " TYPE " *sql-stream*)
(write-string (database-column-type column-type database) *sql-stream*)))
;; TODO: output column constraints
(defmethod output-sql ((action sql-alter-table-alter-column-type-action) (database mysql-database))
(with-slots (column-name column-type) action
(write-string "CHANGE COLUMN " *sql-stream*)
(output-sql column-name database)
(write-char #\Space *sql-stream*)
(output-sql column-name database)
(write-char #\Space *sql-stream*)
(write-string (database-column-type column-type database) *sql-stream*)))
(defun alter-table (table-name alter-table-column-action &key (database *default-database*))
(let* ((table-name (etypecase table-name
(symbol (sql-expression :attribute table-name))
(string (sql-expression :attribute table-name))
(sql-ident table-name)))
(stmt (make-instance 'sql-alter-table
:table-name table-name
:alter-table-action alter-table-column-action)))
(execute-command stmt :database database)))
(defun alter-table-add-column (table-name column-name column-type constraints &key (database *default-database*))
(alter-table table-name
(make-instance 'sql-alter-table-add-column-action
:column-name column-name
:column-type column-type
:constraints constraints)
:database database))
(defun alter-table-drop-column (table-name column-name &key (database *default-database*))
(alter-table table-name
(make-instance 'sql-alter-table-drop-column-action :column-name column-name)
:database database))
(defun alter-table-alter-column-type (table-name column-name column-type constraints &key (database *default-database*))
(alter-table table-name
(make-instance 'sql-alter-table-alter-column-type-action
:column-name column-name
:column-type column-type
:constraints constraints)
:database database))
(defmethod update-view-from-class ((class-name symbol) &key (database *default-database*) (transactions t))
(update-view-from-class (find-class class-name) :database database :transactions transactions))
(defmethod update-view-from-class ((class standard-db-class)
&key (database *default-database*) (transactions t)
(drop-extra-columns t)
(if-does-not-exist :create))
"Update the table correspoding to the CLASS.
DATABASE and TRANSACTIONS have the same semantics as with
CREATE-VIEW-FROM-CLASS. DROP-EXTRA-COLUMNS specifies what to do
with columns which appear in the table but not in the class. When
T we drop these 'extra' columns, when NIL we just leave them.
IF-DOES-NOT-EXIST specifies what to do when the table doesn't
exist:
:CREATE - Create the table using CREATE-VIEW-FROM-CLASS.
:ERROR - Signal an error.
NIL - Do nothing."
(if (table-exists-p (view-table class))
(update-existing-table class
:drop-extra-columns drop-extra-columns
:database database)
(ecase if-does-not-exist
(:create (create-view-from-class (class-name class)
:database database
:transactions transactions))
(:error (error "No existing table to update. Class: ~S; base-table: ~S"
class (view-table class)))
(nil (values)))))
#|
compare data types for the following class
((companyid
:db-kind :key
:db-constraints :not-null
:type integer
:initarg :companyid)
(name
:type (string 100)
:initarg :name)
(value
:type string
:initarg :value)
A., from schema-def
(database-generate-column-definition
'cl-user::company slot *default-database*)
(#<SQL-IDENT-ATTRIBUTE COMPANYID> INTEGER NIL :NOT-NULL)
(#<SQL-IDENT-ATTRIBUTE NAME> (STRING 100) NIL)
(#<SQL-IDENT-ATTRIBUTE VALUE> STRING NIL)
B., from list-attribute-types
TODO: it seems that mysql adds the parameter 11 to integer types which I don't
know how to get from the schema-def
(attribute-type 'name 'company)
:INT
11
NIL
0
:CHAR
100
NIL
1
:VARCHAR
255
NIL
1
|#
;; TODO: handle constraints
(defun schema-attribute-type (schema-def)
(let* ((schema-type (second schema-def))
(type (if (listp schema-type) (first schema-type) schema-type))
(args (when (listp schema-type) (list (second schema-type))))
(raw-type (database-get-type-specifier type args *default-database*
(database-underlying-type *default-database*)))
(start-length (position #\( raw-type))
(db-type (if start-length
(subseq raw-type 0 start-length)
raw-type))
(length (when start-length
(parse-integer (subseq raw-type (1+ start-length)) :junk-allowed t))))
(list
(ensure-keyword db-type)
length
nil
(if (eq (fourth schema-def) :not-null) 0 1))))
(defmethod update-existing-table ((class standard-db-class)
&key (database *default-database*)
(drop-extra-columns t))
(let* ((table-name (view-table class))
(table-attribute-types (list-attribute-types table-name :database database))
(schema-defs (remove-if #'null (mapcar (lambda (slot)
(database-generate-column-definition
class slot database))
(ordered-class-slots class)))))
;; for every slot in schemadef we make sure the corresponding
;; table has column of the proper name and type. if it doesn't
;; we add it, if it does we check (and possibly change) the
;; type.
(dolist (schema-def schema-defs)
(let* ((column-name (database-identifier (first schema-def) database))
(table-attribute-type (cdr (find (database-identifier column-name database) table-attribute-types
:key #'car
:test #'string=)))
(schema-attribute-type (schema-attribute-type schema-def)))
(if table-attribute-type
(progn
;; column already exists, check whether we need to alter the type
(print column-name)
(print schema-def)
(describe schema-attribute-type)
(describe table-attribute-type)
(when (not (equal schema-attribute-type table-attribute-type))
;; TODO: handle constraints
(alter-table-alter-column-type table-name
(column-name-from-arg column-name)
(second schema-def)
nil
:database database)))
;; add the new column
;; TODO: handle constraints
(alter-table-add-column table-name
(column-name-from-arg column-name)
(second schema-def)
nil
:database database))))
(when drop-extra-columns
;; look for any columns in the table which aren't defined by
;; the class.
(dolist (table-attribute-type table-attribute-types)
(let ((column-name (first table-attribute-type)))
(unless (find column-name schema-defs
:key (lambda (column-spec) (database-identifier (car column-spec) database))
:test #'string=)
;; COLUMN-NAME is no longer part of CLASS's schemadef, so we remove it
(alter-table-drop-column table-name
(column-name-from-arg column-name)
:database database)))))
(values)))
;;; test cases, this goes to clsql-test
(in-package :clsql-tests)
(defun check-and-drop-updated-view-class (view-class-name)
(let ((attribute-types-with-update (clsql:list-attribute-types view-class-name))
(attribute-types-with-create nil))
(clsql:drop-view-from-class view-class-name)
(clsql:create-view-from-class view-class-name)
(setq attribute-types-with-create (clsql:list-attribute-types view-class-name))
(clsql:drop-view-from-class view-class-name)
(equal attribute-types-with-update attribute-types-with-create)))
;; add column
(deftest :ooddl/update-view-from-class/add-column/1
(progn
(clsql:def-view-class uvfc () ((id :type integer)))
(clsql:create-view-from-class 'uvfc)
(clsql:def-view-class uvfc () ((id :type integer)
(add-me :type string)))
(clsql:update-view-from-class 'uvfc)
(check-and-drop-updated-view-class 'uvfc))
t)
;; change column type from integer to string
(deftest :ooddl/update-view-from-class/alter-column/1
(progn
(clsql:def-view-class uvfc () ((id :type integer)
(change-me :type integer)))
(clsql:create-view-from-class 'uvfc)
(clsql:def-view-class uvfc () ((id :type integer)
(change-me :type string)))
(clsql:update-view-from-class 'uvfc)
(check-and-drop-updated-view-class 'uvfc))
t)
;; change column type from integer to (string 200)
(deftest :ooddl/update-view-from-class/alter-column/2
(progn
(clsql:def-view-class uvfc () ((id :type integer)
(change-me :type integer)))
(clsql:create-view-from-class 'uvfc)
(clsql:def-view-class uvfc () ((id :type integer)
(change-me :type (string 200))))
(clsql:update-view-from-class 'uvfc)
(check-and-drop-updated-view-class 'uvfc))
t)
;; drop column
(deftest :ooddl/update-view-from-class/drop-column/1
(progn
(clsql:def-view-class uvfc () ((id :type integer)
(drop-me :type integer)))
(clsql:create-view-from-class 'uvfc)
(clsql:def-view-class uvfc () ((id :type integer)))
(clsql:update-view-from-class 'uvfc)
(check-and-drop-updated-view-class 'uvfc))
t)