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.3 2002/12/05 18:15:23 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)
30 (defun finalize-sql (cl)
31 (let ((esds (class-slots cl)))
32 (let* ((table-name-slot (slot-value cl 'sql-name))
33 (generate-table-cmd (generate-create-table-string
34 (if (consp table-name-slot)
38 (setf (slot-value cl 'create-table-cmd) generate-table-cmd))
41 (when (slot-value esd 'inverse)
42 (define-inverse cl esd))))
45 (defun define-inverse (class esd)
46 (let ((inverse (slot-value esd 'inverse)))
49 `(defun ,inverse (obj)
50 (format t "~&Finding key: ~s~%" obj)
54 ;; create inverse function
58 (defun generate-create-table-string (table-name esds)
59 (let ((cmd (format nil "CREATE TABLE ~A ("
60 (slot-name-to-sql-name table-name))))
62 (unless (eq esd (car esds))
63 (string-append cmd ", "))
64 (string-append cmd (slot-name-to-sql-name (slot-definition-name esd))
66 (let ((length (esd-length esd))
67 (sql-type (esd-sql-type esd)))
68 (string-append cmd (sql-field-cmd sql-type length))))
69 (string-append cmd ")")))
78 (defmethod sql-create ((self sqltable))
79 (with-sql-connection (conn)
80 (sql-execute (sql-cmd-create-table self) conn)
81 (dolist (cmd (sql-cmd-create-indices self))
82 (sql-execute cmd conn))
85 (defmethod sql-drop ((self sqltable))
86 (mutex-sql-execute (sql-cmd-drop-table self))
89 (defmethod sql-insert ((self sqltable))
91 (format nil "INSERT INTO ~a (~a) VALUES (~a)"
92 (sql-name self) (sql-cmd-field-names self) (format-values self))))
94 (defmethod sql-select ((self sqltable) key)
98 (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
99 (sql-cmd-field-names self) (sql-name self)
100 (inverse-field-name self) key)))))
102 (format t "process returned fields"))))
105 (defun format-values (self)
107 (fields (fields self)))
108 (dolist (field fields)
109 (unless (eq field (car fields))
110 (string-append values ","))
111 (let ((name (car field)))
112 (with-key-value-list (key value (rest field))
114 (string-append values
116 ((:fixnum :bigint :short-float :double-float)
118 (slot-value self name)))
122 (slot-value self name))))))))))
125 (defmacro defsqltable (tname &key fields)
127 (defclass ,tname (sqltable)
128 ,(parse-fields tname fields)
129 ,(default-initargs fields))
131 (defmethod sql-name ((self ,tname))
132 ,(substitute #\_ #\- (write-to-string tname)))
134 (defmethod fields ((self ,tname))
137 (defmethod sql-cmd-create-table ((self ,tname))
138 ,(create-table-string tname fields))
140 (defmethod sql-cmd-create-indices ((self ,tname))
141 "Return a list of index cmds"
142 (quote ,(create-indices-string tname fields)))
144 (defmethod sql-cmd-drop-table ((self ,tname))
145 ,(format nil "DROP TABLE ~a" tname))
147 (defmethod sql-cmd-field-names ((self ,tname))
148 ,(row-field-string fields))
150 (defmethod inverse-field-name ((self ,tname))
151 ,(inverse-field-string fields))
154 (defun create-indices-string (table-name fields)
156 (dolist (field fields)
157 (let ((name-string (write-to-string (car field))))
158 (with-key-value-list (key value (rest field))
159 (when (eq key :unique)
162 (push (sql-cmd-index table-name name-string nil) indices))
164 (push (sql-cmd-index table-name name-string t) indices)))))))
167 (defun inverse-field-string (fields)
169 (dolist (field fields)
170 (let ((name-string (write-to-string (car field))))
171 (with-key-value-list (key value (rest field))
172 (when (eq key :inverse)
173 (setq inverse value)))))
175 (write-to-string inverse))))
177 (defun sql-cmd-index (table field unique)
178 (let ((*print-circle* nil))
179 (format nil "CREATE ~A INDEX ~A_~A ON ~A(~A)"
180 (if unique "UNIQUE" "")
181 (slot-name-to-sql-name table)
182 (slot-name-to-sql-name field)
183 (slot-name-to-sql-name table)
184 (slot-name-to-sql-name field))))
186 (defun row-field-string (fields)
188 (dolist (field fields)
189 (unless (eq field (car fields))
190 (string-append names ","))
191 (string-append names (slot-name-to-sql-name (car field))))
194 (defun slot-name-to-sql-name (name)
195 (let ((str (string-upcase (etypecase name
199 (write-to-string name))))))
200 (substitute #\_ #\- str)))
202 (defun create-table-string (table-name fields)
203 (let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name))))
204 (dolist (field fields)
205 (unless (eq field (car fields))
206 (string-append cmd ", "))
207 (string-append cmd (slot-name-to-sql-name (car field)) " ")
209 (with-key-value-list (key value (rest field))
215 (string-append cmd (sql-field-cmd type length))))
216 (string-append cmd ")")))
219 (defun sql-field-cmd (type length)
223 (format nil "CHAR(~d)" length)
224 (format nil "VARCHAR(~d)" length)))
236 (defmacro with-key-value-list ((key value list) form)
238 `(loop for ,i from 0 to (1- (length ,list)) by 2 do
239 (let ((,key (nth ,i ,list))
240 (,value (nth (1+ ,i) ,list)))
243 (defun parse-fields (table-name fields)
245 (dolist (field fields)
246 (let* ((fname (car field))
247 (name-string (write-to-string fname))
248 (initarg (intern name-string :keyword))concat-symbol
250 (options (rest field)))
251 (with-key-value-list (key value options)
254 (setq def (nconc def (list :type
268 (setq def (nconc def (list
270 :accessor (concat-symbol
271 (write-to-string table-name) "-"
272 (write-to-string fname)))))
273 (push def class-fields)))
276 (defun default-initargs (fields)
277 (let ((initargs (list :default-initargs)))
278 (dolist (field fields)
279 (let* ((fname (car field))
280 (name-string (write-to-string fname))
281 (initarg (intern name-string :keyword)))
282 (setq initargs (nconc initargs (list initarg nil)))))