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: sql.lisp,v 1.5 2003/05/14 05:29:48 kevin Exp $
12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
15 (in-package :hyperobject)
16 (eval-when (:compile-toplevel :execute)
17 (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
20 ;;;; Metaclass initialization commands
22 (defun finalize-sql (cl)
23 (setf (slot-value cl 'sql-name) (sql-name cl))
24 (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd
25 (slot-value cl 'sql-name)))
26 (let ((esds (class-slots cl)))
28 (setf (slot-value esd 'sql-name) (sql-name esd)))
29 (setf (slot-value cl 'create-table-cmd)
30 (generate-create-table-cmd cl esds))
31 (setf (slot-value cl 'create-indices-cmds)
32 (generate-create-indices-cmds (slot-value cl 'sql-name) esds))
34 (when (slot-value esd 'inverse)
35 (define-inverse cl esd))))
38 (defgeneric sql-name (cl)
41 (defmethod sql-name ((cl hyperobject-class))
42 "Return name of SQL table for a class"
43 (let* ((sql-name-slot (slot-value cl 'sql-name))
44 (name (if (consp sql-name-slot) (car sql-name-slot) sql-name-slot))
45 (lisp-name (if name name (class-name cl))))
46 (lisp-name-to-sql-name lisp-name)))
48 (defmethod sql-name ((esd hyperobject-esd))
49 (let* ((name (slot-value esd 'sql-name))
50 (lisp-name (if name name (slot-definition-name esd))))
51 (lisp-name-to-sql-name lisp-name)))
54 (defun lisp-name-to-sql-name (lisp)
55 "Convert a lisp name (atom or list, string or symbol) into a canonical
57 (unless (stringp lisp)
60 (symbol (symbol-name lisp))
61 (t (write-to-string lisp)))))
62 (let ((sql (make-string (length lisp))))
63 (dotimes (i (length lisp))
66 (let ((c (char lisp i)))
76 (defun define-inverse (class esd)
77 "Define an inverse function for a slot"
78 (let ((inverse (slot-value esd 'inverse)))
81 `(defun ,inverse (obj)
82 (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
83 ;; create inverse function
88 (defun generate-create-table-cmd (cl esds)
89 (let ((cmd (format nil "CREATE TABLE ~A" (slot-value cl 'sql-name)))
90 (subobjects (slot-value cl 'subobjects)))
92 (unless (find (slot-definition-name esd) subobjects :key #'name-slot)
93 (if (eq esd (car esds))
94 (string-append cmd " (")
95 (string-append cmd ", "))
96 (string-append cmd (lisp-name-to-sql-name (slot-definition-name esd))
98 (let ((length (slot-value esd 'length))
99 (sql-type (slot-value esd 'sql-type)))
100 (string-append cmd (sql-field-cmd sql-type length)))))
101 (string-append cmd ")")))
104 (defun sql-field-cmd (type length)
105 (case (intern (symbol-name type) (symbol-name :keyword))
111 (format nil "CHAR(~d)" length))
113 (format nil "VARCHAR(~d)" length))))
119 (format nil "CHAR(~D)" length))
122 ((or :fixnum :integer)
126 ((or :short-float :float)
131 (defun generate-drop-table-cmd (table-name)
132 (format nil "DROP TABLE ~a" table-name))
134 (defun generate-create-indices-cmds (table-name slots)
137 (when (slot-value slot 'index)
138 (let ((sql-name (slot-value slot 'sql-name)))
139 (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
143 (defun sql-cmd-index (table field unique)
144 (let ((*print-circle* nil))
145 (format nil "CREATE ~AINDEX ~A ON ~A(~A)"
146 (if unique "UNIQUE " "")
147 (sql-index-name table field)
151 (defun sql-index-name (table field)
152 (format nil "~A_~A" table field))
154 ;;;; Runtime Commands
156 (defgeneric sql-create (cl))
157 (defmethod sql-create (cl)
158 (with-sql-connection (conn)
159 (sql-execute (slot-value cl 'create-table-cmd) conn)
160 (dolist (cmd (slot-value cl 'create-indices-cmds))
161 (sql-execute cmd conn))
164 (defgeneric sql-drop (cl))
165 (defmethod sql-drop (cl)
166 (mutex-sql-execute (slot-value cl 'drop-table-cmd))
170 (defmethod sql-insert (obj)
172 (format nil "INSERT INTO ~a (~a) VALUES (~a)"
173 (sql-name self) (sql-cmd-field-names self) (format-values self))))
175 (defmethod sql-select (obj lisp-name key)
179 (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
180 (sql-cmd-field-names self) (sql-name self)
181 (inverse-field-name self) key)))))
183 (format t "process returned fields"))))
186 (defun format-values (self)
188 (fields (fields self)))
189 (dolist (field fields)
190 (unless (eq field (car fields))
191 (string-append values ","))
192 (let ((name (car field)))
193 (with-key-value-list (key value (rest field))
195 (string-append values
197 ((:fixnum :bigint :short-float :double-float)
199 (slot-value self name)))
203 (slot-value self name))))))))))
208 (defun inverse-field-string (fields)
210 (dolist (field fields)
211 (let ((name-string (write-to-string (car field))))
212 (with-key-value-list (key value (rest field))
213 (when (eq key :inverse)
214 (setq inverse value)))))
216 (write-to-string inverse))))
218 (defun row-field-string (fields)
220 (dolist (field fields)
221 (unless (eq field (car fields))
222 (string-append names ","))
223 (string-append names (lisp-name-to-sql-name (car field))))
227 (defun parse-fields (table-name fields)
229 (dolist (field fields)
230 (let* ((fname (car field))
231 (name-string (write-to-string fname))
232 (initarg (intern name-string :keyword))concat-symbol
234 (options (rest field)))
235 (with-key-value-list (key value options)
238 (setq def (nconc def (list :type
252 (setq def (nconc def (list
254 :accessor (concat-symbol
255 (write-to-string table-name) "-"
256 (write-to-string fname)))))
257 (push def class-fields)))