mirror of
https://github.com/dimitri/pgloader.git
synced 2025-08-08 07:16:58 +02:00
213edbe930
The types TEXT and text are the same, and should match both when used as a casting rule and when checking a catalog merge. See #132.
167 lines
6.9 KiB
Common Lisp
167 lines
6.9 KiB
Common Lisp
;;;
|
|
;;; Type casting machinery, to share among all database kind sources.
|
|
;;;
|
|
(in-package #:pgloader.sources)
|
|
|
|
;;
|
|
;; The special variables *default-cast-rules* and *cast-rules* must be bound
|
|
;; by specific database commands with proper values at run-time.
|
|
;;
|
|
(defvar *default-cast-rules* nil "Default casting rules.")
|
|
(defvar *cast-rules* nil "Specific casting rules added in the command.")
|
|
|
|
(defun parse-column-unsigned (data-type column-type)
|
|
"See if we find the term unsigned in the column-type."
|
|
(declare (ignore data-type))
|
|
(when (search "unsigned" column-type :test #'string-equal) t))
|
|
|
|
(defun cast-rule-matches (rule source)
|
|
"Returns the target datatype if the RULE matches the SOURCE, or nil"
|
|
(destructuring-bind (&key ((:source rule-source))
|
|
((:target rule-target))
|
|
using)
|
|
rule
|
|
(destructuring-bind
|
|
;; it's either :type or :column, just cope with both thanks to
|
|
;; &allow-other-keys
|
|
(&key ((:type rule-source-type) nil t-s-p)
|
|
((:column rule-source-column) nil c-s-p)
|
|
((:typemod typemod-expr) nil tm-s-p)
|
|
((:default rule-source-default) nil d-s-p)
|
|
((:unsigned rule-unsigned) nil u-s-p)
|
|
((:not-null rule-source-not-null) nil n-s-p)
|
|
((:auto-increment rule-source-auto-increment))
|
|
((:on-update-current-timestamp rule-source-updts))
|
|
&allow-other-keys)
|
|
rule-source
|
|
(destructuring-bind (&key table-name
|
|
column-name
|
|
type
|
|
ctype
|
|
typemod
|
|
default
|
|
not-null
|
|
extra
|
|
unsigned
|
|
auto-increment
|
|
on-update-current-timestamp)
|
|
source
|
|
(declare (ignore ctype extra))
|
|
(when
|
|
(or
|
|
;; if we match by column, then table and column is all we
|
|
;; need to compare
|
|
(and c-s-p
|
|
(string-equal table-name (car rule-source-column))
|
|
(string-equal column-name (cdr rule-source-column)))
|
|
|
|
;; otherwide, we do the full dance
|
|
(and
|
|
(or (and t-s-p (string-equal type rule-source-type)))
|
|
(or (null tm-s-p) (when typemod
|
|
(typemod-expr-matches-p typemod-expr typemod)))
|
|
(or (null d-s-p) (string-equal default rule-source-default))
|
|
(or (null u-s-p) (eq unsigned rule-unsigned))
|
|
(or (null n-s-p) (eq not-null rule-source-not-null))
|
|
|
|
;; current RULE only matches SOURCE when both have an
|
|
;; auto_increment property, or none have it.
|
|
(or (and auto-increment rule-source-auto-increment)
|
|
(and (not auto-increment) (not rule-source-auto-increment)))
|
|
|
|
;; current RULE only matches SOURCE when both have an
|
|
;; on-update-current-timestamp property, or none have it.
|
|
(or (and on-update-current-timestamp rule-source-updts)
|
|
(and (not on-update-current-timestamp)
|
|
(not rule-source-updts)))))
|
|
(list :using using :target rule-target))))))
|
|
|
|
(defun make-pgsql-type (source target using)
|
|
"Returns a COLUMN struct suitable for a PostgreSQL type definition"
|
|
(destructuring-bind (&key ((:table-name source-table-name))
|
|
((:column-name source-column-name))
|
|
((:type source-type))
|
|
((:ctype source-ctype))
|
|
((:typemod source-typemod))
|
|
((:default source-default))
|
|
((:extra source-extra))
|
|
((:not-null source-not-null))
|
|
&allow-other-keys)
|
|
source
|
|
(if target
|
|
(destructuring-bind (&key type
|
|
drop-extra
|
|
drop-default
|
|
drop-not-null
|
|
set-not-null
|
|
(drop-typemod t)
|
|
&allow-other-keys)
|
|
target
|
|
(let ((type-name
|
|
(typecase type
|
|
(function (funcall type
|
|
source-table-name source-column-name
|
|
source-type source-ctype source-typemod))
|
|
(t type)))
|
|
(pg-typemod
|
|
(when source-typemod
|
|
(destructuring-bind (a &optional b) source-typemod
|
|
(format nil "(~a~:[~*~;,~a~])" a b b)))))
|
|
(make-column :name (apply-identifier-case source-column-name)
|
|
:type-name type-name
|
|
:type-mod (when (and source-typemod (not drop-typemod))
|
|
pg-typemod)
|
|
:nullable (and (not set-not-null)
|
|
(or (not source-not-null)
|
|
drop-not-null))
|
|
:default (when (and source-default (not drop-default))
|
|
source-default)
|
|
:extra (when (and source-extra (not drop-extra))
|
|
source-extra)
|
|
:transform using)))
|
|
|
|
;; NO MATCH
|
|
;;
|
|
;; prefer char(24) over just char, that is the column type over the
|
|
;; data type.
|
|
(make-column :name (apply-identifier-case source-column-name)
|
|
:type-name source-ctype
|
|
:nullable (not source-not-null)
|
|
:default source-default
|
|
:extra source-extra
|
|
:transform using))))
|
|
|
|
(defun apply-casting-rules (table-name column-name
|
|
dtype ctype default nullable extra
|
|
&key
|
|
(rules (append *cast-rules*
|
|
*default-cast-rules*)))
|
|
"Apply the given RULES to the MySQL SOURCE type definition"
|
|
(let* ((typemod (parse-column-typemod dtype ctype))
|
|
(unsigned (parse-column-unsigned dtype ctype))
|
|
(not-null (string-equal nullable "NO"))
|
|
(auto-increment (eq :auto-increment extra))
|
|
(on-upd-cts (eq :on-update-current-timestamp extra))
|
|
(source `(:table-name ,table-name
|
|
:column-name ,column-name
|
|
:type ,dtype
|
|
:ctype ,ctype
|
|
,@(when typemod (list :typemod typemod))
|
|
:unsigned ,unsigned
|
|
:default ,default
|
|
:not-null ,not-null
|
|
:extra ,extra
|
|
:auto-increment ,auto-increment
|
|
:on-update-current-timestamp ,on-upd-cts)))
|
|
(let (first-match-using)
|
|
(loop
|
|
:for rule :in rules
|
|
:for (target using) := (destructuring-bind (&key target using)
|
|
(cast-rule-matches rule source)
|
|
(list target using))
|
|
:do (when (and (null target) using (null first-match-using))
|
|
(setf first-match-using using))
|
|
:until target
|
|
:finally (return (make-pgsql-type source target using))))))
|
|
|