;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: sql-create.lisp,v 1.7 2003/05/05 23:13:28 kevin Exp $
+;;;; $Id: sql-create.lisp,v 1.8 2003/05/06 01:34:57 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
;;;; *************************************************************************
(in-package :umlisp)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
-
-
-(defun create-table-cmd-old (file)
- "Return sql command to create a table"
- (let ((col-func
- (lambda (c)
- (let ((sqltype (umls-col-sqltype c)))
- (concatenate 'string (umls-col-col c)
- " "
- (if (or (string-equal sqltype "VARCHAR")
- (string-equal sqltype "CHAR"))
- (format nil "~a (~a)" sqltype (umls-col-max c))
- sqltype)
- ",")))))
- (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
- (string-trim-last-character
- (mapcar-append-string col-func (umls-cols-for-umls-file file))))))
+(eval-when (:compile-toplevel)
+ (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
(defun create-table-cmd (file)
"Return sql command to create a table"
"Return SQL command to create a custom table"
(format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
-(defun insert-values-cmd-old (file values)
- "Return sql insert command for a row of values"
- (let ((insert-func
- (lambda (col value)
- (concatenate
- 'string
- (umls-col-quotechar col)
- (if (null (umls-col-parsefunc col))
- value
- (format nil "~A" (funcall (umls-col-parsefunc col) value)))
- (umls-col-quotechar col)
- ","))))
- (format
- nil "INSERT INTO ~a (~a) VALUES (~a)"
- (umls-file-table file)
- (string-trim-last-character
- (mapcar-append-string (lambda (c) (concatenate 'string c ","))
- (umls-file-fields file)))
- (string-trim-last-character
- (concatenate 'string
- (mapcar2-append-string insert-func
- (remove-custom-cols (umls-file-colstructs file))
- values)
- (custom-col-values-old (custom-colstructs-for-file file) values "," t)))
- )))
-
(defun insert-col-value (col value)
(if (null (umls-col-parsefunc col))
value
(mapcar insert-func (remove-custom-cols (umls-file-colstructs file)) values)
(custom-col-values (custom-colstructs-for-file file) values t)))))
-(defun custom-col-values-old (colstructs values delim doquote)
- "Returns a string of column values for SQL inserts for custom columns"
- (let ((result ""))
- (dolist (col colstructs)
- (let* ((func (umls-col-custom-value-func col))
- (custom-value (funcall func values)))
- (string-append result
- (if doquote (umls-col-quotechar col))
- (escape-backslashes custom-value)
- (if doquote (umls-col-quotechar col))
- delim)))
- result))
(defun custom-col-value (col doquote values)
(let ((custom-value (funcall (umls-col-custom-value-func col) values)))
(remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
(defun noneng-lang-index-files ()
- (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
- (string-equal (umls-file-fil f) "MRXW." :end1 5)
- (not (string-equal (umls-file-fil f) "MRXW.ENG"))
- (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
- *umls-files*))
+ (remove-if-not
+ (lambda (f) (and (> (length (umls-file-fil f)) 4)
+ (string-equal (umls-file-fil f) "MRXW." :end1 5)
+ (not (string-equal (umls-file-fil f) "MRXW.ENG"))
+ (not (string-equal (umls-file-fil f) "MRXW.NONENG"))))
+ *umls-files*))
;;; SQL Command Functions
(defun create-index-cmd (colname tablename length)
"Return sql create index command"
(format nil "CREATE INDEX ~a ON ~a (~a ~a)"
- (concatenate 'string tablename "_" colname "_X") tablename colname
- (if (integerp length)
- (format nil "(~d)" length)
- "")))
+ (concatenate 'string tablename "_" colname "_X")
+ tablename colname
+ (if (integerp length) (format nil "(~d)" length) "")))
(defun create-all-tables-cmdfile ()
"Return sql commands to create all tables. Not need for automated SQL import"
(mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
-
;; SQL Execution functions
(defun sql-drop-tables (conn)
"SQL Databases: drop all tables"
- (mapcar
- (lambda (file)
- (ignore-errors
- (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
- *umls-files*))
+ (dolist (file *umls-files*)
+ (ignore-errors
+ (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn))))
(defun sql-create-tables (conn)
"SQL Databases: create all tables"
- (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))
+ (dolist (file *umls-files*)
+ (sql-execute (create-table-cmd file) conn)))
(defun sql-create-custom-tables (conn)
"SQL Databases: create all custom tables"
- (mapcar (lambda (ct)
- (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
- +custom-tables+))
+ (dolist (ct +custom-tables+)
+ (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
(defun sql-insert-values (conn file)
"SQL Databases: inserts all values for a file"
(defun sql-insert-all-values (conn)
"SQL Databases: inserts all values for all files"
- (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))
+ (dolist (file *umls-files*)
+ (sql-insert-values conn file)))
(defun sql-create-indexes (conn &optional (indexes +index-cols+))
"SQL Databases: create all indexes"
- (mapcar
- (lambda (idx)
- (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))
- indexes))
+ (dolist (idx indexes)
+ (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
(defun make-usrl (conn)
(sql-execute "drop table if exists USRL" conn)
(sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
- (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc"))
+ (dolist (tuple (mutex-sql-query
+ "select distinct SAB,SRL from MRSO order by SAB asc"))
(sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
(car tuple) (ensure-integer (cadr tuple)))
conn)))
(defun translate-all-files (&optional (extension ".trans"))
"Copy translated files and return postgresql copy commands to import"
(make-noneng-index-file extension)
- (map 'nil (lambda (f) (translate-file f extension)) *umls-files*))
+ (dolist (f *umls-files*) (translate-umls-file f extension)))
-(defun translate-file (file extension)
+(defun translate-file (filename extension files)
"Translate a umls file into a format suitable for sql copy cmd"
- (let ((path (umls-pathname (umls-file-fil file) extension)))
+ (let ((path (umls-pathname filename extension))
+ (input-files (mklist files)))
(if (probe-file path)
- (progn
- (format t "File ~A already exists: skipping~%" path)
- nil)
- (with-open-file (ostream path :direction :output)
- (with-umls-file (line (umls-file-fil file))
- (umls-translate file line ostream)
- (princ #\newline ostream))
- t))))
+ (format t "File ~A already exists: skipping~%" path)
+ (dolist (input-file input-files)
+ (with-open-file (ostream :direction :output)
+ (with-umls-file (line (umls-file-fil input-file))
+ (umls-translate file line ostream)
+ (princ #\newline ostream)))))))
+
+(defun translate-umls-file (file extension)
+ "Translate a umls file into a format suitable for sql copy cmd"
+ (translate-file (umls-file-fil file) extension (umls-file-fil file)))
(defun make-noneng-index-file (extension)
"Make non-english index file"
- (let* ((outfile (find-umls-file "MRXW.NONENG"))
- (path (umls-pathname (umls-file-fil outfile) extension)))
-
- (if (probe-file path)
- (progn
- (format t "File ~A already exists: skipping~%" path)
- nil)
- (progn
- (with-open-file (ostream path :direction :output)
- (dolist (inputfile (noneng-lang-index-files))
- (with-umls-file (line (umls-file-fil inputfile))
- (umls-translate outfile line ostream) ;; use outfile for custom cols
- (princ #\newline ostream))))
- t))))
+ (translate-file (find-umls-file "MRXW.NONENG" extension
+ (noneng-lang-index-files))))
(defun pg-copy-cmd (file extension)
"Return postgresql copy statement for a file"
- (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
- (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
+ (format
+ nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
+ (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
(defun mysql-copy-cmd (file extension)
"Return mysql copy statement for a file"
- (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
- (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
-
-(defun umls-translate-old (file line)
- "Translate a single line for sql output"
- (string-trim-last-character
- (concatenate 'string
- (mapcar2-append-string
- (lambda (col value)
- (concatenate
- 'string
- (if (eq (umls-col-datatype col) 'sql-u)
- (format nil "~d" (parse-ui value ""))
- (escape-backslashes value))
- "|"))
- (remove-custom-cols (umls-file-colstructs file))
- line)
- (custom-col-values-old (custom-colstructs-for-file file) line "|" nil))))
-
-(defun concat-separated-strings (separator &rest lists)
- (format nil (format nil "~~{~~A~~^~A~~}" separator) (mapappend #'identity lists)))
-
-(defun print-separated-strings (strm separator &rest lists)
- (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) (compilation-speed 0)))
- (do* ((rest-lists lists (cdr rest-lists))
- (list (car rest-lists) (car rest-lists))
- (last-list (null (cdr rest-lists)) (null (cdr rest-lists))))
- ((null list) strm)
- (do* ((lst list (cdr lst))
- (elem (car lst) (car lst))
- (last-elem (null (cdr lst)) (null (cdr lst))))
- ((null lst))
- (write-string elem strm)
- (unless (and last-elem last-list)
- (write-string separator strm)))))
+ (format
+ nil
+ "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
+ (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
(defun col-value (col value)
(if (eq (umls-col-datatype col) 'sql-u)
(defun max-umls-row ()
"Return length of longest row"
- (if t
- 6000 ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
- (progn
- (unless *umls-files*
- (init-umls))
- (let ((rowsizes '()))
- (dolist (file *umls-files*)
- (let ((row 0)
- (fields (umls-file-colstructs file)))
- (dolist (field fields)
- (incf row (1+ (umls-col-max field))))
- (push row rowsizes)))
- (car (sort rowsizes #'>))))))
+ (unless *umls-files*
+ (init-umls))
+ (let ((rowsizes '()))
+ (dolist (file *umls-files*)
+ (let ((row 0)
+ (fields (umls-file-colstructs file)))
+ (dolist (field fields)
+ (incf row (1+ (umls-col-max field))))
+ (push row rowsizes)))
+ (car (sort rowsizes #'>))))
projects / umlisp.git / blobdiff