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.4 2002/12/06 16:18:49 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)
24 (setf (slot-value cl 'sql-name) (sql-name cl))
25 (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd
26 (slot-value cl 'sql-name)))
27 (let ((esds (class-slots cl)))
29 (setf (slot-value cl 'sql-name) (sql-name esd)))
30 (setf (slot-value cl 'create-table-cmd)
31 (generate-create-table-cmd (slot-value cl 'sql-name) esds))
32 (setf (slot-value cl 'create-indices-cmds)
33 (generate-create-indices-cmds (slot-value cl 'sql-name) esds))
35 (when (slot-value esd 'inverse)
36 (define-inverse cl esd))))
39 (defmethod sql-name ((cl hyperobject-class))
40 "Return name of SQL table for a class"
41 (let-if (it (slot-value cl 'sql-name))
42 (let* ((name (if (consp it) (car it) it))
43 (lisp-name (if name name (class-name cl))))
44 (lisp-name-to-sql-name lisp-name))))
46 (defmethod sql-name ((esd hyperobject-esd))
47 (let-if (it (slot-value esd 'sql-name))
48 (let* ((name (if (consp it) (car it) it))
49 (lisp-name (if name name (slot-definition-name esd))))
50 (lisp-name-to-sql-name lisp-name))))
53 (defun lisp-name-to-sql-name (lisp)
54 "Convert a lisp name (atom or list, string or symbol) into a canonical
56 (unless (stringp lisp)
57 (setq lisp (write-to-string lisp)))
58 (let ((sql (make-string (length lisp))))
59 (dotimes (i (length lisp))
61 (let ((c (char lisp i)))
70 (defun define-inverse (class esd)
71 "Define an inverse function for a slot"
72 (let ((inverse (slot-value esd 'inverse)))
75 `(defun ,inverse (obj)
76 (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
77 ;; create inverse function
82 (defun generate-create-table-cmd (table-name esds)
83 (let ((cmd (format nil "CREATE TABLE ~A (" table-name)))
85 (unless (eq esd (car esds))
86 (string-append cmd ", "))
87 (string-append cmd (lisp-name-to-sql-name (slot-definition-name esd))
89 (let ((length (slot-value esd 'length))
90 (sql-type (slot-value esd 'sql-type)))
91 (string-append cmd (sql-field-cmd sql-type length))))
92 (string-append cmd ")")))
95 (defun sql-field-cmd (type length)
102 (format nil "CHAR(~d)" length))
104 (format nil "VARCHAR(~d)" length))))
116 (defun generate-drop-table-cmd (table-name)
117 (format nil "DROP TABLE ~a" table-name))
119 (defun generate-create-indices-cmds (table-name slots)
122 (when (slot-value slot 'indexed)
123 (let ((sql-name (slot-value slot 'sql-name)))
124 (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
128 (defun sql-cmd-index (table field unique)
129 (let ((*print-circle* nil))
130 (format nil "CREATE ~A INDEX ~A ON ~A(~A)"
131 (if unique "UNIQUE" "")
133 (sql-index-name table field)
137 (defun sql-index-name (table field)
138 (format nil "~A_~A" table field))
140 ;;;; Runtime Commands
142 (defmethod sql-create (cl)
143 (with-sql-connection (conn)
144 (sql-execute (slot-value cl 'create-table-cmd) conn)
145 (dolist (cmd (slot-value cl 'create-indices-cmds))
146 (sql-execute cmd conn))
149 (defmethod sql-drop (cl)
150 (mutex-sql-execute (slot-value cl 'drop-table-cmd))
154 (defmethod sql-insert (obj)
156 (format nil "INSERT INTO ~a (~a) VALUES (~a)"
157 (sql-name self) (sql-cmd-field-names self) (format-values self))))
159 (defmethod sql-select (obj lisp-name key)
163 (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
164 (sql-cmd-field-names self) (sql-name self)
165 (inverse-field-name self) key)))))
167 (format t "process returned fields"))))
170 (defun format-values (self)
172 (fields (fields self)))
173 (dolist (field fields)
174 (unless (eq field (car fields))
175 (string-append values ","))
176 (let ((name (car field)))
177 (with-key-value-list (key value (rest field))
179 (string-append values
181 ((:fixnum :bigint :short-float :double-float)
183 (slot-value self name)))
187 (slot-value self name))))))))))
192 (defun inverse-field-string (fields)
194 (dolist (field fields)
195 (let ((name-string (write-to-string (car field))))
196 (with-key-value-list (key value (rest field))
197 (when (eq key :inverse)
198 (setq inverse value)))))
200 (write-to-string inverse))))
202 (defun row-field-string (fields)
204 (dolist (field fields)
205 (unless (eq field (car fields))
206 (string-append names ","))
207 (string-append names (lisp-name-to-sql-name (car field))))
211 (defun parse-fields (table-name fields)
213 (dolist (field fields)
214 (let* ((fname (car field))
215 (name-string (write-to-string fname))
216 (initarg (intern name-string :keyword))concat-symbol
218 (options (rest field)))
219 (with-key-value-list (key value options)
222 (setq def (nconc def (list :type
236 (setq def (nconc def (list
238 :accessor (concat-symbol
239 (write-to-string table-name) "-"
240 (write-to-string fname)))))
241 (push def class-fields)))