From fcc6e8f8135f3f5c3f4afd5754c43f6b132dbcc9 Mon Sep 17 00:00:00 2001 From: Dimitri Fontaine Date: Sat, 26 Mar 2016 20:25:03 +0100 Subject: [PATCH] Implement ALTER SCHEMA ... RENAME TO... That's only available for MS SQL as of now, as it's the only source database we have where the notion of a schema makes sense. Fix #224. --- src/package.lisp | 4 +++ src/parsers/command-alter-table.lisp | 20 ++++++++++++ src/parsers/command-mssql.lisp | 7 +++- src/pgsql/schema.lisp | 1 + src/sources/common/db-methods.lisp | 34 ++++++++++++++------ src/sources/mssql/mssql.lisp | 5 ++- src/utils/alter-table.lisp | 48 +++++++++++++++++++++++++--- src/utils/schema-structs.lisp | 41 ++++++++++-------------- 8 files changed, 118 insertions(+), 42 deletions(-) diff --git a/src/package.lisp b/src/package.lisp index eb360fb..7cfc07d 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -54,6 +54,7 @@ #:catalog-name #:catalog-schema-list #:schema-name + #:schema-source-name #:schema-table-list #:schema-view-list #:table-name @@ -101,6 +102,7 @@ #:push-to-end #:with-schema #:alter-table + #:alter-schema #:format-table-name)) @@ -218,6 +220,7 @@ #:catalog-name #:catalog-schema-list #:schema-name + #:schema-source-name #:schema-table-list #:schema-view-list #:table-name @@ -265,6 +268,7 @@ #:push-to-end #:with-schema #:alter-table + #:alter-schema #:format-table-name #:format-default-value diff --git a/src/parsers/command-alter-table.lisp b/src/parsers/command-alter-table.lisp index b665a56..c2f789f 100644 --- a/src/parsers/command-alter-table.lisp +++ b/src/parsers/command-alter-table.lisp @@ -56,3 +56,23 @@ (cons :alter-table (loop :for (command ws) :in alter-table-command-list :collect command)))) + +;;; +;;; ALTER SCHEMA ... RENAME TO ... +;;; +;;; Useful mainly for MS SQL at the moment +;;; +(defrule alter-schema-rename-to (and kw-alter kw-schema quoted-namestring + kw-rename kw-to quoted-namestring) + (:lambda (alter-schema-command) + (bind (((_ _ current-name _ _ new-name) alter-schema-command)) + (pgloader.schema::make-match-rule + :type :string + :target current-name + :action #'pgloader.schema::alter-schema-rename + :args (list new-name))))) + +;;; currently we only support a single ALTER SCHEMA variant +(defrule alter-schema alter-schema-rename-to + (:lambda (alter-schema-rename-to) + (cons :alter-schema (list (list alter-schema-rename-to))))) diff --git a/src/parsers/command-mssql.lisp b/src/parsers/command-mssql.lisp index f32e09a..90e511c 100644 --- a/src/parsers/command-mssql.lisp +++ b/src/parsers/command-mssql.lisp @@ -69,6 +69,7 @@ (defrule load-mssql-optional-clauses (* (or mssql-options gucs casts + alter-schema before-load after-load including-like-in-schema @@ -135,6 +136,7 @@ (defun lisp-code-for-loading-from-mssql (ms-db-conn pg-db-conn &key gucs casts before after options + alter-schema including excluding) `(lambda () ;; now is the time to load the CFFI lib we need (freetds) @@ -156,6 +158,7 @@ (pgloader.mssql:copy-database source :including ',including :excluding ',excluding + :alter-schema ',alter-schema :set-table-oids t ,@(remove-batch-control-option options)) @@ -165,7 +168,8 @@ (:lambda (source) (bind (((ms-db-uri pg-db-uri &key - gucs casts before after including excluding options) + gucs casts before after alter-schema + including excluding options) source)) (cond (*dry-run* (lisp-code-for-mssql-dry-run ms-db-uri pg-db-uri)) @@ -175,6 +179,7 @@ :casts casts :before before :after after + :alter-schema alter-schema :options options :including including :excluding excluding)))))) diff --git a/src/pgsql/schema.lisp b/src/pgsql/schema.lisp index 666cd42..768642a 100644 --- a/src/pgsql/schema.lisp +++ b/src/pgsql/schema.lisp @@ -364,6 +364,7 @@ (defmethod process-index-definitions ((table table) &key sql-dialect) "Rewrite all index filter in TABLE." (loop :for index :in (table-index-list table) + :when (pgsql-index-filter index) :do (let ((pg-filter (handler-case (translate-index-filter table index sql-dialect) diff --git a/src/sources/common/db-methods.lisp b/src/sources/common/db-methods.lisp index 4ad39e2..8bbda53 100644 --- a/src/sources/common/db-methods.lisp +++ b/src/sources/common/db-methods.lisp @@ -114,6 +114,24 @@ :columns columns :transforms transforms))) +(defun process-catalog (copy catalog &key alter-table alter-schema) + "Do all the PostgreSQL catalog tweaking here: casts, index WHERE clause + rewriting, pgloader level alter schema and alter table commands." + ;; cast the catalog into something PostgreSQL can work on + (cast catalog) + + ;; support code for index filters (where clauses) + (process-index-definitions catalog :sql-dialect (class-name (class-of copy))) + + ;; we may have to alter schemas + (when alter-schema + (alter-schema catalog alter-schema)) + + ;; if asked, now alter the catalog with given rules: the alter-table + ;; keyword parameter actually contains a set of alter table rules. + (when alter-table + (alter-table catalog alter-table))) + ;;; ;;; Generic enough implementation of the copy-database method. @@ -139,6 +157,7 @@ excluding set-table-oids alter-table + alter-schema materialize-views) "Export database source data and Import it into PostgreSQL" (let* ((copy-kernel (make-kernel worker-count)) @@ -166,16 +185,11 @@ (let ((lp:*kernel* idx-kernel)) (lp:make-channel))))) - ;; cast the catalog into something PostgreSQL can work on - (cast catalog) - - ;; support code for index filters (where clauses) - (process-index-definitions catalog :sql-dialect (class-name (class-of copy))) - - ;; if asked, now alter the catalog with given rules: the alter-table - ;; keyword parameter actually contains a set of alter table rules. - (when alter-table - (alter-table catalog alter-table)) + ;; apply catalog level transformations to support the database migration + ;; that's CAST rules, index WHERE clause rewriting and ALTER commands + (process-catalog copy catalog + :alter-table alter-table + :alter-schema alter-schema) ;; if asked, first drop/create the tables on the PostgreSQL side (handler-case diff --git a/src/sources/mssql/mssql.lisp b/src/sources/mssql/mssql.lisp index 4775d95..0c0bac1 100644 --- a/src/sources/mssql/mssql.lisp +++ b/src/sources/mssql/mssql.lisp @@ -31,7 +31,7 @@ (with-connection (*mssql-db* (source-db mssql)) (let* ((sql (format nil "SELECT ~{~a~^, ~} FROM [~a].[~a];" (get-column-list (fields mssql)) - (table-schema (source mssql)) + (schema-source-name (table-schema (source mssql))) (table-name (source mssql))))) (log-message :debug "~a" sql) (handler-case @@ -39,8 +39,7 @@ ((condition #'(lambda (c) (log-message :error "~a" c) - (update-stats :data (target mssql) :errs 1) - (invoke-restart 'mssql::use-nil)))) + (update-stats :data (target mssql) :errs 1)))) (mssql::map-query-results sql :row-fn process-row-fn :connection (conn-handle *mssql-db*))) diff --git a/src/utils/alter-table.lisp b/src/utils/alter-table.lisp index f280a58..0ccf9e4 100644 --- a/src/utils/alter-table.lisp +++ b/src/utils/alter-table.lisp @@ -49,7 +49,9 @@ ;;; (defun alter-table-set-schema (table schema-name) "Alter the schema of TABLE, set SCHEMA-NAME instead." - (setf (table-schema table) schema-name)) + (let* ((catalog (schema-catalog (table-schema table))) + (schema (maybe-add-schema catalog schema-name))) + (setf (table-schema table) schema))) (defun alter-table-rename (table new-name) "Alter the name of TABLE to NEW-NAME." @@ -60,12 +62,50 @@ ;;; Apply the match rules as given by the parser to a table name. ;;; -(declaim (inline rule-matches)) -(defun rule-matches (match-rule table) +(defgeneric rule-matches (match-rule object) + (:documentation "Returns non-nill when MATCH-RULE matches with OBJECT.")) + +(defmethod rule-matches ((match-rule match-rule) (table table)) "Return non-nil when TABLE matches given MATCH-RULE." - (declare (type match-rule match-rule) (type table table)) (let ((table-name (table-source-name table))) (ecase (match-rule-type match-rule) (:string (string= (match-rule-target match-rule) table-name)) (:regex (cl-ppcre:scan (match-rule-target match-rule) table-name))))) +(defmethod rule-matches ((match-rule match-rule) (schema schema)) + "Return non-nil when TABLE matches given MATCH-RULE." + (let ((schema-name (schema-source-name schema))) + (ecase (match-rule-type match-rule) + (:string (string= (match-rule-target match-rule) schema-name)) + (:regex (cl-ppcre:scan (match-rule-target match-rule) schema-name))))) + + +;;; +;;; Also implement ALTER SCHEMA support here, it's using the same underlying +;;; structure. +;;; +(defgeneric alter-schema (object alter-schema-rule-list)) + +(defmethod alter-schema ((catalog catalog) alter-schema-rule-list) + "Apply ALTER-SCHEMA-RULE-LIST to all schema of CATALOG." + (loop :for schema :in (catalog-schema-list catalog) + :do (alter-schema schema alter-schema-rule-list))) + +(defmethod alter-schema ((schema schema) alter-schema-rule-list) + "Apply ALTER-SCHEMA-RULE-LIST to SCHEMA." + ;; + ;; alter-schema-rule-list is a list of set of rules, within each set we + ;; only apply the first rules that matches. + ;; + (loop :for rule-list :in alter-schema-rule-list + :do (let ((match-rule + (loop :for match-rule :in rule-list + :thereis (when (rule-matches match-rule schema) + match-rule)))) + (when match-rule + (apply (match-rule-action match-rule) + (list* schema (match-rule-args match-rule))))))) + +(defun alter-schema-rename (schema new-name) + "Alter the name fo the given schema to new-name." + (setf (schema-name schema) new-name)) diff --git a/src/utils/schema-structs.lisp b/src/utils/schema-structs.lisp index 0c4f7dc..2a6a934 100644 --- a/src/utils/schema-structs.lisp +++ b/src/utils/schema-structs.lisp @@ -30,7 +30,7 @@ ;;; implemented in each source separately. ;;; (defstruct catalog name schema-list) -(defstruct schema source-name name table-list view-list) +(defstruct schema source-name name catalog table-list view-list) (defstruct table source-name name schema oid comment ;; field is for SOURCE ;; column is for TARGET @@ -155,7 +155,8 @@ (defmethod add-schema ((catalog catalog) schema-name &key) "Add SCHEMA-NAME to CATALOG and return the new schema instance." - (let ((schema (make-schema :source-name schema-name + (let ((schema (make-schema :catalog catalog + :source-name schema-name :name (when schema-name (apply-identifier-case schema-name))))) (push-to-end schema (catalog-schema-list catalog)))) @@ -165,7 +166,7 @@ (let ((table (make-table :source-name table-name :name (apply-identifier-case table-name) - :schema (schema-name schema) + :schema schema :comment (unless (or (null comment) (string= "" comment)) comment)))) (push-to-end table (schema-table-list schema)))) @@ -175,7 +176,7 @@ (let ((view (make-table :source-name view-name :name (apply-identifier-case view-name) - :schema (schema-name schema) + :schema schema :comment (unless (or (null comment) (string= "" comment)) comment)))) (push-to-end view (schema-view-list schema)))) @@ -336,29 +337,21 @@ "TABLE should be a table instance, but for hysterical raisins might be a CONS of a schema name and a table name, or just the table name as a string." - (format nil "~@[~a.~]~a" (table-schema table) (table-name table))) + (format nil "~@[~a.~]~a" + (schema-name (table-schema table)) + (table-name table))) -;;; -;;; Still lacking round tuits here, so for the moment the representation of -;;; a table name is either a string or a cons built from schema and -;;; table-name. -;;; (defmacro with-schema ((var table-name) &body body) "When table-name is a CONS, SET search_path TO its CAR and return its CDR, otherwise just return the TABLE-NAME. A PostgreSQL connection must be established when calling this function." - `(let ((,var - (typecase ,table-name - (table (if (table-schema ,table-name) - (let ((sql (format nil "SET search_path TO ~a;" - (table-schema ,table-name)))) - (pgloader.pgsql:pgsql-execute sql) - (table-name ,table-name)) - (table-name ,table-name))) - (cons (let ((sql (format nil "SET search_path TO ~a;" - (car ,table-name)))) - (pgloader.pgsql:pgsql-execute sql) - (cdr ,table-name))) - (string ,table-name)))) - ,@body)) + (let ((schema-name (gensym "SCHEMA-NAME"))) + `(let* ((,schema-name (schema-name (table-schema ,table-name))) + (,var + (progn + (if ,schema-name + (let ((sql (format nil "SET search_path TO ~a;" ,schema-name))) + (pgloader.pgsql:pgsql-execute sql))) + (table-name ,table-name)))) + ,@body)))