1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: SQL Generation functions for Hyperobject
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: sqlgen.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
12 ;;;; This file, part of Hyperobject-SQL, is
13 ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
14 ;;;; *************************************************************************
16 (in-package :hyperobject)
17 (eval-when (:compile-toplevel :execute)
18 (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
21 ;;;; Metaclass initialization commands
23 (defun finalize-sql (cl)
29 (defun finalize-sql (cl)
30 (let ((esds (class-slots cl)))
31 (let* ((table-name-slot (slot-value cl 'sql-name))
32 (generate-table-cmd (generate-create-table-string
33 (if (consp table-name-slot)
37 (setf (slot-value cl 'create-table-cmd) generate-table-cmd))
40 (when (slot-value esd 'inverse)
41 (define-inverse cl esd))))
44 (defun define-inverse (class esd)
45 (let ((inverse (slot-value esd 'inverse)))
48 `(defun ,inverse (obj)
49 (format t "~&Finding key: ~s~%" obj)
53 ;; create inverse function
57 (defun generate-create-table-string (table-name esds)
58 (let ((cmd (format nil "CREATE TABLE ~A ("
59 (slot-name-to-sql-name table-name))))
61 (unless (eq esd (car esds))
62 (string-append cmd ", "))
63 (string-append cmd (slot-name-to-sql-name (slot-definition-name esd))
65 (let ((length (esd-length esd))
66 (sql-type (esd-sql-type esd)))
67 (string-append cmd (sql-field-cmd sql-type length))))
68 (string-append cmd ")")))
77 (defmethod sql-create ((self sqltable))
78 (with-sql-connection (conn)
79 (sql-execute (sql-cmd-create-table self) conn)
80 (dolist (cmd (sql-cmd-create-indices self))
81 (sql-execute cmd conn))
84 (defmethod sql-drop ((self sqltable))
85 (mutex-sql-execute (sql-cmd-drop-table self))
88 (defmethod sql-insert ((self sqltable))
90 (format nil "INSERT INTO ~a (~a) VALUES (~a)"
91 (sql-name self) (sql-cmd-field-names self) (format-values self))))
93 (defmethod sql-select ((self sqltable) key)
97 (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
98 (sql-cmd-field-names self) (sql-name self)
99 (inverse-field-name self) key)))))
101 (format t "process returned fields"))))
104 (defun format-values (self)
106 (fields (fields self)))
107 (dolist (field fields)
108 (unless (eq field (car fields))
109 (string-append values ","))
110 (let ((name (car field)))
111 (with-key-value-list (key value (rest field))
113 (string-append values
115 ((:fixnum :bigint :short-float :double-float)
117 (slot-value self name)))
121 (slot-value self name))))))))))
124 (defmacro defsqltable (tname &key fields)
126 (defclass ,tname (sqltable)
127 ,(parse-fields tname fields)
128 ,(default-initargs fields))
130 (defmethod sql-name ((self ,tname))
131 ,(substitute #\_ #\- (write-to-string tname)))
133 (defmethod fields ((self ,tname))
136 (defmethod sql-cmd-create-table ((self ,tname))
137 ,(create-table-string tname fields))
139 (defmethod sql-cmd-create-indices ((self ,tname))
140 "Return a list of index cmds"
141 (quote ,(create-indices-string tname fields)))
143 (defmethod sql-cmd-drop-table ((self ,tname))
144 ,(format nil "DROP TABLE ~a" tname))
146 (defmethod sql-cmd-field-names ((self ,tname))
147 ,(row-field-string fields))
149 (defmethod inverse-field-name ((self ,tname))
150 ,(inverse-field-string fields))
153 (defun create-indices-string (table-name fields)
155 (dolist (field fields)
156 (let ((name-string (write-to-string (car field))))
157 (with-key-value-list (key value (rest field))
158 (when (eq key :unique)
161 (push (sql-cmd-index table-name name-string nil) indices))
163 (push (sql-cmd-index table-name name-string t) indices)))))))
166 (defun inverse-field-string (fields)
168 (dolist (field fields)
169 (let ((name-string (write-to-string (car field))))
170 (with-key-value-list (key value (rest field))
171 (when (eq key :inverse)
172 (setq inverse value)))))
174 (write-to-string inverse))))
176 (defun sql-cmd-index (table field unique)
177 (let ((*print-circle* nil))
178 (format nil "CREATE ~A INDEX ~A_~A ON ~A(~A)"
179 (if unique "UNIQUE" "")
180 (slot-name-to-sql-name table)
181 (slot-name-to-sql-name field)
182 (slot-name-to-sql-name table)
183 (slot-name-to-sql-name field))))
185 (defun row-field-string (fields)
187 (dolist (field fields)
188 (unless (eq field (car fields))
189 (string-append names ","))
190 (string-append names (slot-name-to-sql-name (car field))))
193 (defun slot-name-to-sql-name (name)
194 (let ((str (string-upcase (etypecase name
198 (write-to-string name))))))
199 (substitute #\_ #\- str)))
201 (defun create-table-string (table-name fields)
202 (let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name))))
203 (dolist (field fields)
204 (unless (eq field (car fields))
205 (string-append cmd ", "))
206 (string-append cmd (slot-name-to-sql-name (car field)) " ")
208 (with-key-value-list (key value (rest field))
214 (string-append cmd (sql-field-cmd type length))))
215 (string-append cmd ")")))
218 (defun sql-field-cmd (type length)
222 (format nil "CHAR(~d)" length)
223 (format nil "VARCHAR(~d)" length)))
235 (defmacro with-key-value-list ((key value list) form)
237 `(loop for ,i from 0 to (1- (length ,list)) by 2 do
238 (let ((,key (nth ,i ,list))
239 (,value (nth (1+ ,i) ,list)))
242 (defun parse-fields (table-name fields)
244 (dolist (field fields)
245 (let* ((fname (car field))
246 (name-string (write-to-string fname))
247 (initarg (intern name-string :keyword))concat-symbol
249 (options (rest field)))
250 (with-key-value-list (key value options)
253 (setq def (nconc def (list :type
267 (setq def (nconc def (list
269 :accessor (concat-symbol
270 (write-to-string table-name) "-"
271 (write-to-string fname)))))
272 (push def class-fields)))
275 (defun default-initargs (fields)
276 (let ((initargs (list :default-initargs)))
277 (dolist (field fields)
278 (let* ((fname (car field))
279 (name-string (write-to-string fname))
280 (initarg (intern name-string :keyword)))
281 (setq initargs (nconc initargs (list initarg nil)))))