Add debian source format

[umlisp.git] / create-sql.lisp

diff --git a/create-sql.lisp b/create-sql.lisp
index 79732ebc649e4cc5816049944be951ce9f6ac470..974087726b0dde19e71c699399e0311f15bcb7d4 100644 (file)
--- a/create-sql.lisp
+++ b/create-sql.lisp
@@ -44,7 +44,7 @@
                 " MAX_ROWS=200000000"
               "")
             (if (eq *umls-sql-type* :mysql)
-                " TYPE=MYISAM CHARACTER SET utf8"
+                " TYPE=MYISAM CHARACTER SET utf8 COLLATE utf8_bin"
                 ""))))
 
 (defun create-custom-table-cmd (tablename sql-cmd)
@@ -206,13 +206,56 @@
      (format nil "DROP INDEX ~a"
              (concatenate 'string tablename "_" colname "_X")))))
 
+(defun sql-create-indexes-mysql (conn indexes verbose)
+  (let ((tables nil)
+        (table-cols nil))
+    (dolist (idx indexes)
+      (pushnew (second idx) tables :test 'string-equal)
+      (let ((table-col (find (second idx) table-cols :key 'car :test 'string-equal)))
+        (if table-col
+            (vector-push-extend (cons (first idx) (third idx)) (second table-col))
+            (push (list (second idx) (make-array (list 1) :initial-contents (list (cons (first idx) (third idx)))
+                                                 :adjustable t :fill-pointer 1))
+                  table-cols))))
+    (dolist (table tables)
+      (let ((table-col (find table table-cols :key 'car :test 'string-equal))
+            (first t)
+            (str (format nil "ALTER TABLE ~A" table)))
+        (loop for col across (second table-col)
+           do
+             (let ((colname (car col))
+                   (length (cdr col)))
+               (ignore-errors (sql-execute (drop-index-cmd colname table) conn))
+               (setq str (concatenate 'string
+                                      str
+                                      (if first
+                                          (progn
+                                            (setq first nil)
+                                            " ")
+                                          ", ")
+                                      (format nil "ADD INDEX ~A (~A)"
+                                              (concatenate 'string table "_" colname "_X")
+                                              (concatenate 'string
+                                                           colname
+                                                           (if (integerp length)
+                                                               (format nil " (~d)" length)
+                                                               "")))))))
+        (when verbose
+          (format t "UMLS Import: Creating indexes for columns ~A on table ~A.~%"
+                  (mapcar 'car (coerce (second table-col) 'list)) table))
+        (when conn
+          (sql-execute str conn))
+        ))))
+
 (defun sql-create-indexes (conn &key (indexes +index-cols+) verbose)
   "SQL Databases: create all indexes"
-  (dolist (idx indexes)
-    (when verbose (format t "UMLS Import: Creating index for column ~A on table ~A.~%"
-                          (first idx) (second idx)))
-    (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
-    (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
+  (if (eql :mysql *umls-sql-type*)
+      (sql-create-indexes-mysql conn indexes verbose)
+      (dolist (idx indexes)
+        (when verbose (format t "UMLS Import: Creating index for column ~A on table ~A.~%"
+                              (first idx) (second idx)))
+        (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
+        (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))))
 
 (defun make-usrl (conn)
   (if (eql :mysql *umls-sql-type*)
@@ -296,24 +339,24 @@ This is much faster that using create-umls-db-insert."
     (let ((translated-lines 0)
           (input-lines 0)
           (eof (cons nil nil)))
-      (catch 'done-counting
-        (with-open-file (ts output-path :direction :input
-                            #+(and sbcl sb-unicode) :external-format
-                            #+(and sbcl sb-unicode) :UTF-8
-                            #+(and allegro ics) :external-format
-                            #+(and allegro ics) :UTF-8
-                            #+lispworks :external-format
-                            #+lispworks :UTF-8
-                            #+(and clisp unicode) :external-format
-                            #+(and clisp unicode) charset:utf-8)
-          (do ()
-              ((eq (read-line ts nil eof) eof))
-            (incf translated-lines)))
-        (dolist (input-ufile input-ufiles)
-          (with-umls-ufile (line input-ufile)
-                           (incf input-lines)
-                           (when (> input-lines translated-lines)
-                             (throw 'done-counting 'incomplete)))))
+      (with-open-file (ts output-path :direction :input
+                          #+(and sbcl sb-unicode) :external-format
+                          #+(and sbcl sb-unicode) :UTF-8
+                          #+(and allegro ics) :external-format
+                          #+(and allegro ics) :UTF-8
+                          #+lispworks :external-format
+                          #+lispworks :UTF-8
+                          #+(and clisp unicode) :external-format
+                          #+(and clisp unicode) charset:utf-8)
+        (do ((c (read-char ts nil eof) (read-char ts nil eof)))
+            ((eq c eof))
+          (when (eql c #\newline)
+            (incf translated-lines))))
+      (dolist (input-ufile input-ufiles)
+        (with-umls-ufile (line input-ufile)
+          (incf input-lines)
+          (when (> input-lines translated-lines)
+            (return))))
       (cond
         ((< input-lines translated-lines)
           (format t "Translated file ~A incomplete, deleting...~%" output-path)