From b31ccded6f26b5d46f21cb2fb81aaeea321d7a07 Mon Sep 17 00:00:00 2001
From: Dimitri Fontaine <dim@tapoueh.org>
Date: Mon, 18 Nov 2013 10:09:21 +0100
Subject: [PATCH] Implement per-column MySQL CAST rules.

---
 README.md                         |  4 ----
 pgloader.1.md                     |  9 ++++++++-
 src/parser.lisp                   | 31 ++++++++++++++++++++++---------
 src/sources/mysql-cast-rules.lisp | 13 ++++++++++---
 test/parse/hans.goeuro.load       |  2 +-
 5 files changed, 41 insertions(+), 18 deletions(-)

diff --git a/README.md b/README.md
index 233fc5c..ff6650f 100644
--- a/README.md
+++ b/README.md
@@ -136,10 +136,6 @@ Some notes about what I intend to be working on next.
   - error reporting (done)
   - add input line number to log file?
 
-### transformation and casts
-
-  - add per-column support for cast rules in the system
-
 ### data output
 
   - PostgreSQL COPY Text format output for any supported input
diff --git a/pgloader.1.md b/pgloader.1.md
index d0f03b8..42ad612 100644
--- a/pgloader.1.md
+++ b/pgloader.1.md
@@ -860,9 +860,16 @@ The `database` command accepts the following clauses and options:
 	The cast clause allows to specify custom casting rules, either to
 	overload the default casting rules or to amend them with special cases.
 	
-	A casting rule is expected to follow the form:
+	A casting rule is expected to follow one of the forms:
 	
 	    type <mysql-type-name> [ <guard> ... ] to <pgsql-type-name> [ <option> ... ]
+		column <table-name>.<column-name> [ <guards> ] to ...
+
+    It's possible for a *casting rule* to either match against a MySQL data
+    type or against a given *column name* in a given *table name*. That
+    flexibility allows to cope with cases where the type `tinyint` might
+    have been used as a `boolean` in some cases but as a `smallint` in
+    others.
 
     The supported guards are:
 	
diff --git a/src/parser.lisp b/src/parser.lisp
index e1a2463..d1991b9 100644
--- a/src/parser.lisp
+++ b/src/parser.lisp
@@ -604,26 +604,39 @@
     (alexandria:alist-plist guards)))
 
 ;; at the moment we only know about extra auto_increment
-(defrule cast-source-extra (and ignore-whitespace
-				kw-with kw-extra kw-auto-increment)
+(defrule cast-source-extra (and kw-with kw-extra kw-auto-increment)
   (:constant (list :auto-increment t)))
 
-(defrule cast-source (and (or kw-column kw-type)
-			  trimmed-name
+(defrule cast-source-type (and kw-type trimmed-name)
+  (:destructure (kw name) (declare (ignore kw)) (list :type name)))
+
+(defrule table-column-name (and namestring "." namestring)
+  (:destructure (table-name dot column-name)
+    (declare (ignore dot))
+    (list :column (cons (text table-name) (text column-name)))))
+
+(defrule cast-source-column (and kw-column table-column-name)
+  ;; well, we want namestring . namestring
+  (:destructure (kw name) (declare (ignore kw)) name))
+
+(defrule cast-source (and (or cast-source-type cast-source-column)
 			  (? cast-source-extra)
 			  (? cast-source-guards)
 			  ignore-whitespace)
   (:lambda (source)
-    (destructuring-bind (kw name opts guards ws) source
+    (destructuring-bind (name-and-type opts guards ws) source
       (declare (ignore ws))
       (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
+				&allow-other-keys)
+	  guards
+	(destructuring-bind (&key (auto-increment nil ai-s-p)
+				  &allow-other-keys)
+	    opts
+	  `(,@name-and-type
 		,@(when t-s-p (list :typemod typemod))
 		,@(when d-s-p (list :default default))
-		:auto-increment ,auto-increment))))))
+		,@(when ai-s-p (list :auto-increment auto-increment))))))))
 
 (defrule cast-type-name (and (alpha-char-p character)
 			     (* (or (alpha-char-p character)
diff --git a/src/sources/mysql-cast-rules.lisp b/src/sources/mysql-cast-rules.lisp
index 70f3394..998094c 100644
--- a/src/sources/mysql-cast-rules.lisp
+++ b/src/sources/mysql-cast-rules.lisp
@@ -181,11 +181,15 @@
 			    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)
 		((:not-null rule-source-not-null) nil n-s-p)
-		((:auto-increment rule-source-auto-increment) nil ai-s-p))
+		((:auto-increment rule-source-auto-increment) nil ai-s-p)
+		&allow-other-keys)
 	rule-source
       (destructuring-bind (&key table-name
 				column-name
@@ -196,10 +200,13 @@
 				not-null
 				auto-increment)
 	  source
-	(declare (ignore table-name column-name ctype))
+	(declare (ignore ctype))
 	(when
 	    (and
-	     (string= type rule-source-type)
+	     (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 n-s-p)  (eq not-null rule-source-not-null))
diff --git a/test/parse/hans.goeuro.load b/test/parse/hans.goeuro.load
index 15677da..06615c3 100644
--- a/test/parse/hans.goeuro.load
+++ b/test/parse/hans.goeuro.load
@@ -6,7 +6,7 @@ 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 drop typemod using tinyint-to-boolean,
+      column bools.a 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