From 8fa7a86013f961f1dff48b3311b589a93b3b39d0 Mon Sep 17 00:00:00 2001
From: Dimitri Fontaine <dim@tapoueh.org>
Date: Sun, 17 Nov 2013 22:33:06 +0100
Subject: [PATCH] Implement typemod and default guards in the MySQL CAST
 clause.

---
 pgloader.1.md                     | 81 ++++++++++++++++++++++++-------
 src/parser.lisp                   | 57 +++++++++++++++++++---
 src/sources/mysql-cast-rules.lisp | 45 ++++++++++++-----
 test/parse/hans.goeuro.load       |  3 +-
 test/sakila.load                  |  5 +-
 5 files changed, 149 insertions(+), 42 deletions(-)

diff --git a/pgloader.1.md b/pgloader.1.md
index 499bb18..d0f03b8 100644
--- a/pgloader.1.md
+++ b/pgloader.1.md
@@ -862,21 +862,62 @@ The `database` command accepts the following clauses and options:
 	
 	A casting rule is expected to follow the form:
 	
-	    type <mysql-type-name> to <pgsql-type-name> [ <option> ... ]
+	    type <mysql-type-name> [ <guard> ... ] to <pgsql-type-name> [ <option> ... ]
+
+    The supported guards are:
 	
+	  - *when default 'value'*
+	  
+	    The casting rule is only applied against MySQL columns of the source
+	    type that have given *value*, which must be a single-quoted or a
+	    double-quoted string.
+		
+	  - *when typemod expression*
+	  
+	    The casting rule is only applied against MySQL columns of the source
+	    type that have a *typemod* value matching the given *typemod
+	    expression*. The *typemod* is separated into its *precision* and
+	    *scale* components.
+		
+		Example of a cast rule using a *typemod* guard:
+		
+		    type char when (= precision 1) to char keep typemod
+			
+        This expression casts MySQL `char(1)` column to a PostgreSQL column
+        of type `char(1)` while allowing for the general case `char(N)` will
+        be converted by the default cast rule into a PostgreSQL type
+        `varchar(N)`.
+
 	The supported casting options are:
 	
-	  - *drop default*
+	  - *drop default*, *keep default*
 
-        When this option is listed, pgloader drops any existing default
-        expression in the MySQL database for columns of the source type from
-        the `CREATE TABLE` statement it generates.
+        When the option *drop default* is listed, pgloader drops any
+        existing default expression in the MySQL database for columns of the
+        source type from the `CREATE TABLE` statement it generates.
 
-	  - *drop not null*
+	    The spelling *keep default* explicitely prevents that behavior and
+	    can be used to overlad the default casting rules.
 
-        When this option is listed, pgloader drop any existing `NOT NULL`
-        constraint associated with the given source MySQL datatype when it
-        creates the tables in the PostgreSQL database.
+	  - *drop not null*, *keep not null*
+
+        When the option *drop not null* is listed, pgloader drops any
+        existing `NOT NULL` constraint associated with the given source
+        MySQL datatype when it creates the tables in the PostgreSQL
+        database.
+
+	    The spelling *keep not null* explicitely prevents that behavior and
+	    can be used to overlad the default casting rules.
+
+      - *drop typemod*, *keep typemod*
+
+	    When the option *drop typemod* is listed, pgloader drops any
+	    existing *typemod* definition (e.g. *precision* and *scale*) from
+	    the datatype definition found in the MySQL columns of the source
+	    type when it created the tables in the PostgreSQL database.
+
+	    The spelling *keep typemod* explicitely prevents that behavior and
+	    can be used to overlad the default casting rules.
 
 	  - *using*
 
@@ -984,17 +1025,21 @@ Numbers:
   - type int to int       when not auto_increment and (< typemod 10)
   - type int to bigint    when not auto_increment and (<= 10 typemod)
   - type bigint to bigserial when auto_increment
-  - type tinyint to smallint
-  - type smallint to smallint
-  - type mediumint to integer
-  - type float to float
-  - type bigint to bigint
-  - type double to double precision
-  - type numeric to numeric (keeping the typemod)
-  - type decimal to deciman (keeping the typemod)
+
+  - type tinyint to smallint   drop typemod
+  - type smallint to smallint  drop typemod
+  - type mediumint to integer  drop typemod
+  - type integer to integer    drop typemod
+  - type float to float        drop typemod
+  - type bigint to bigint      drop typemod
+  - type double to double precision drop typemod
+
+  - type numeric to numeric keep typemod
+  - type decimal to deciman keep typemod
 
 Texts:
 
+  - type char       to varchar keep typemod
   - type varchar    to text
   - type tinytext   to text
   - type text       to text
@@ -1029,7 +1074,7 @@ Date:
   - type date to date
   - type datetime to timestamptz
   - type timestamp to timestamptz
-  - type year to integer
+  - type year to integer drop typemod
 
 Geometric:
 
diff --git a/src/parser.lisp b/src/parser.lisp
index e3caae8..e1a2463 100644
--- a/src/parser.lisp
+++ b/src/parser.lisp
@@ -82,6 +82,7 @@
   (def-keyword-rule "no")
   (def-keyword-rule "null")
   (def-keyword-rule "default")
+  (def-keyword-rule "typemod")
   (def-keyword-rule "using")
   ;; option for loading from a file
   (def-keyword-rule "workers")
@@ -591,6 +592,16 @@
 ;;;
 ;;; Now parsing CAST rules for migrating from MySQL
 ;;;
+(defrule cast-typemod-guard (and kw-when sexp)
+  (:destructure (w expr) (declare (ignore w)) (cons :typemod expr)))
+
+(defrule cast-default-guard (and kw-when kw-default quoted-string)
+  (:destructure (w d value) (declare (ignore w d)) (cons :default value)))
+
+(defrule cast-source-guards (* (or cast-default-guard
+				   cast-typemod-guard))
+  (:lambda (guards)
+    (alexandria:alist-plist guards)))
 
 ;; at the moment we only know about extra auto_increment
 (defrule cast-source-extra (and ignore-whitespace
@@ -600,12 +611,19 @@
 (defrule cast-source (and (or kw-column kw-type)
 			  trimmed-name
 			  (? cast-source-extra)
+			  (? cast-source-guards)
 			  ignore-whitespace)
   (:lambda (source)
-    (destructuring-bind (kw name opts ws) source
+    (destructuring-bind (kw name opts guards ws) source
       (declare (ignore ws))
-      (destructuring-bind (&key auto-increment &allow-other-keys) opts
-	(list kw name :auto-increment auto-increment)))))
+      (destructuring-bind (&key (default nil d-s-p)
+				(typemod nil t-s-p)
+				&allow-other-keys) guards
+	(destructuring-bind (&key auto-increment &allow-other-keys) opts
+	  `(,kw ,name
+		,@(when t-s-p (list :typemod typemod))
+		,@(when d-s-p (list :default default))
+		:auto-increment ,auto-increment))))))
 
 (defrule cast-type-name (and (alpha-char-p character)
 			     (* (or (alpha-char-p character)
@@ -618,20 +636,39 @@
       (declare (ignore to ws))
       (list :type type-name))))
 
+(defrule cast-keep-default  (and kw-keep kw-default)
+  (:constant (list :drop-default nil)))
+
+(defrule cast-keep-typemod (and kw-keep kw-typemod)
+  (:constant (list :drop-typemod nil)))
+
+(defrule cast-keep-not-null (and kw-keep kw-not kw-null)
+  (:constant (list :drop-not-null nil)))
+
 (defrule cast-drop-default  (and kw-drop kw-default)
   (:constant (list :drop-default t)))
 
+(defrule cast-drop-typemod (and kw-drop kw-typemod)
+  (:constant (list :drop-typemod t)))
+
 (defrule cast-drop-not-null (and kw-drop kw-not kw-null)
   (:constant (list :drop-not-null t)))
 
 (defrule cast-def (+ (or cast-to-type
+			 cast-keep-default
 			 cast-drop-default
+			 cast-keep-typemod
+			 cast-drop-typemod
+			 cast-keep-not-null
 			 cast-drop-not-null))
   (:lambda (source)
     (destructuring-bind
-	  (&key type drop-default drop-not-null &allow-other-keys)
+	  (&key type drop-default drop-typemod drop-not-null &allow-other-keys)
 	(apply #'append source)
-      (list :type type :drop-default drop-default :drop-not-null drop-not-null))))
+      (list :type type
+	    :drop-default drop-default
+	    :drop-typemod drop-typemod
+	    :drop-not-null drop-not-null))))
 
 (defun function-name-character-p (char)
   (or (member char #.(quote (coerce "/:.-%" 'list)))
@@ -1341,10 +1378,14 @@ load database
   (not (eql #\" char)))
 
 (defun symbol-character-p (character)
-  (or (alphanumericp character)
-      (member character '(#\_ #\-))))
+  (not (member character '(#\Space #\( #\)))))
 
-(defrule sexp-symbol (+ (symbol-character-p character))
+(defun symbol-first-character-p (character)
+  (and (symbol-character-p character)
+       (not (member character '(#\+ #\-)))))
+
+(defrule sexp-symbol (and (symbol-first-character-p character)
+			  (* (symbol-character-p character)))
   (:lambda (schars)
     (pgloader.transforms:intern-symbol (text schars))))
 
diff --git a/src/sources/mysql-cast-rules.lisp b/src/sources/mysql-cast-rules.lisp
index 8aa93ed..70f3394 100644
--- a/src/sources/mysql-cast-rules.lisp
+++ b/src/sources/mysql-cast-rules.lisp
@@ -45,28 +45,31 @@
 ;;; The default MySQL Type Casting Rules
 ;;;
 (defparameter *default-cast-rules*
-  `((:source (:type "int" :auto-increment t :typemod (< (car typemod) 10))
+  `((:source (:type "int" :auto-increment t :typemod (< precision 10))
      :target (:type "serial"))
 
-    (:source (:type "int" :auto-increment t :typemod (<= 10 (car typemod)))
+    (:source (:type "int" :auto-increment t :typemod (<= 10 precision))
      :target (:type "bigserial"))
 
-    (:source (:type "int" :auto-increment nil :typemod (< (car typemod) 10))
+    (:source (:type "int" :auto-increment nil :typemod (< precision 10))
      :target (:type "int"))
 
-    (:source (:type "int" :auto-increment nil :typemod (<= 10 (car typemod)))
+    (:source (:type "int" :auto-increment nil :typemod (<= 10 precision))
      :target (:type "bigint"))
 
     ;; bigint with auto_increment always are bigserial
     (:source (:type "bigint" :auto-increment t) :target (:type "bigserial"))
 
     ;; we need the following to benefit from :drop-typemod
-    (:source (:type "tinyint")   :target (:type "smallint"))
-    (:source (:type "smallint")  :target (:type "smallint"))
-    (:source (:type "mediumint") :target (:type "integer"))
-    (:source (:type "float")     :target (:type "float"))
-    (:source (:type "bigint")    :target (:type "bigint"))
-    (:source (:type "double")    :target (:type "double precision"))
+    (:source (:type "tinyint")   :target (:type "smallint" :drop-typemod t))
+    (:source (:type "smallint")  :target (:type "smallint" :drop-typemod t))
+    (:source (:type "mediumint") :target (:type "integer"  :drop-typemod t))
+    (:source (:type "integer")   :target (:type "integer"  :drop-typemod t))
+    (:source (:type "float")     :target (:type "float"    :drop-typemod t))
+    (:source (:type "bigint")    :target (:type "bigint"   :drop-typemod t))
+
+    (:source (:type "double")
+	     :target (:type "double precision" :drop-typemod t))
 
     (:source (:type "numeric")
      :target (:type "numeric" :drop-typemod nil))
@@ -115,7 +118,7 @@
     (:source (:type "date")      :target (:type "date"))
     (:source (:type "datetime")  :target (:type "timestamptz"))
     (:source (:type "timestamp") :target (:type "timestamptz"))
-    (:source (:type "year")      :target (:type "integer"))
+    (:source (:type "year")      :target (:type "integer" :drop-typemod t))
 
     ;; Inline MySQL "interesting" datatype
     (:source (:type "enum")
@@ -152,9 +155,24 @@
 				       :start (+ 1 start-1) :end end))
 	  (cons a b))))))
 
+(defun typemod-expr-to-function (expr)
+  "Transform given EXPR into a callable function object."
+  `(lambda (typemod)
+     (destructuring-bind (precision &optional (scale 0)) typemod
+       (declare (ignorable precision scale))
+       ;;
+       ;; The command parser interns symbols into the pgloader.transforms
+       ;; package, whereas the default casting rules are defined in the
+       ;; pgloader.mysql package. Have a compatibility layer here for the
+       ;; generated code.
+       ;;
+       (let ((pgloader.transforms::precision precision))
+	 (declare (ignorable pgloader.transforms::precision))
+	 ,expr))))
+
 (defun typemod-expr-matches-p (rule-typemod-expr typemod)
   "Check if an expression such as (< 10) matches given typemod."
-  (funcall (compile nil `(lambda (typemod) ,rule-typemod-expr)) typemod))
+  (funcall (compile nil (typemod-expr-to-function rule-typemod-expr)) typemod))
 
 (defun cast-rule-matches (rule source)
   "Returns the target datatype if the RULE matches the SOURCE, or nil"
@@ -346,7 +364,8 @@ that would be int and int(7) or varchar and varchar(25)."
 	   ("o"  "timestamp" "timestamp" "CURRENT_TIMESTAMP" "NO" "on update CURRENT_TIMESTAMP")
 	   ("p"  "point"     "point"     nil "YES" nil)
 	   ("q"  "char"      "char(5)"   nil "YES" nil)
-	   ("l"  "char"      "char(1)"   nil "YES" nil))))
+	   ("l"  "char"      "char(1)"   nil "YES" nil)
+	   ("m"  "integer"   "integer(4)"    nil "YES" nil))))
 
     ;;
     ;; format-pgsql-column when given a mysql-column would call `cast' for
diff --git a/test/parse/hans.goeuro.load b/test/parse/hans.goeuro.load
index 557249d..15677da 100644
--- a/test/parse/hans.goeuro.load
+++ b/test/parse/hans.goeuro.load
@@ -6,7 +6,8 @@ LOAD DATABASE
 
  CAST type datetime to timestamptz drop default drop not null using zero-dates-to-null,
       type date drop not null drop default using zero-dates-to-null,
-      type tinyint to boolean using tinyint-to-boolean,
+      type tinyint to boolean drop typemod using tinyint-to-boolean,
+      type char when (= precision 1) to char keep typemod,
       type year to integer,
       type timestamp to timestamptz drop not null using zero-dates-to-null
 
diff --git a/test/sakila.load b/test/sakila.load
index 2fb0308..8a37274 100644
--- a/test/sakila.load
+++ b/test/sakila.load
@@ -8,9 +8,10 @@ load database
   SET maintenance_work_mem to '128MB', work_mem to '12MB', search_path to 'sakila'
 
  CAST type datetime to timestamptz drop default drop not null using zero-dates-to-null,
-      type date drop not null drop default using zero-dates-to-null,
+      type date drop not null drop default using zero-dates-to-null
+
       -- type tinyint to boolean using tinyint-to-boolean,
-      type year to integer
+      -- type year to integer drop typemod -- now a default
 
  MATERIALIZE VIEWS film_list, staff_list