mirror of
https://github.com/dimitri/pgloader.git
synced 2025-08-08 07:16:58 +02:00
5c60f8c35c
MySQL allows using unsigned data types and pgloader should then target a signed type of a larger capacity so that values can fit. For example, the data definition “smallint(5) unsigned” should be casted to “integer”. This patch allows user defined cast rules to be written against “unsigned” data types as per their MySQL catalog representation. See #678.
167 lines
6.5 KiB
Common Lisp
167 lines
6.5 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.")
|
|
|
|
;;;
|
|
;;; Handling typmod in the general case, don't apply to ENUM types
|
|
;;;
|
|
(defun parse-column-typemod (data-type column-type)
|
|
"Given int(7), returns the number 7.
|
|
|
|
Beware that some data-type are using a typmod looking definition for
|
|
things that are not typmods at all: enum."
|
|
(unless (or (string= "enum" data-type)
|
|
(string= "set" data-type))
|
|
(let ((start-1 (position #\( column-type)) ; just before start position
|
|
(end (position #\) column-type))) ; just before end position
|
|
(when start-1
|
|
(destructuring-bind (a &optional b)
|
|
(mapcar #'parse-integer
|
|
(sq:split-sequence #\, column-type
|
|
:start (+ 1 start-1) :end end))
|
|
(list a b))))))
|
|
|
|
(defun typemod-expr-matches-p (rule-typemod-expr typemod)
|
|
"Check if an expression such as (< 10) matches given typemod."
|
|
(funcall (compile nil (typemod-expr-to-function rule-typemod-expr)) typemod))
|
|
|
|
(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))
|
|
&allow-other-keys)
|
|
rule-source
|
|
(destructuring-bind (&key table-name
|
|
column-name
|
|
type
|
|
ctype
|
|
typemod
|
|
default
|
|
not-null
|
|
unsigned
|
|
auto-increment)
|
|
source
|
|
(declare (ignore ctype))
|
|
(when
|
|
(and
|
|
(or (and t-s-p (string= type rule-source-type))
|
|
(and c-s-p
|
|
(string-equal table-name (car rule-source-column))
|
|
(string-equal column-name (cdr rule-source-column))))
|
|
(or (null tm-s-p) (typemod-expr-matches-p typemod-expr typemod))
|
|
(or (null d-s-p) (string= 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))))
|
|
(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))
|
|
((:not-null source-not-null))
|
|
&allow-other-keys)
|
|
source
|
|
(if target
|
|
(destructuring-bind (&key type
|
|
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)
|
|
: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
|
|
: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 (string= "auto_increment" 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
|
|
:auto-increment ,auto-increment)))
|
|
(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))))))
|
|
|