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
12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
15 (in-package #:hyperobject)
17 ;;;; Metaclass initialization commands
19 (defun finalize-sql (cl)
20 (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd
21 (slot-value cl 'sql-name)))
22 (let ((esds (class-slots cl)))
23 (setf (slot-value cl 'create-table-cmd)
24 (generate-create-table-cmd
26 (remove-if #'(lambda (esd) (null (esd-stored esd))) esds)))
27 (setf (slot-value cl 'create-indices-cmds)
28 (generate-create-indices-cmds (sql-name cl) esds))
30 (when (slot-value esd 'inverse)
31 (define-inverse cl esd))))
35 (defun define-inverse (class esd)
36 "Define an inverse function for a slot"
37 (let ((inverse (slot-value esd 'inverse)))
40 `(defun ,inverse (obj)
41 (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
42 ;; create inverse function
47 (defun generate-create-table-cmd (cl esds)
48 (with-output-to-string (s)
49 (format s "CREATE TABLE ~A (~{~A~^, ~})"
50 (slot-value cl 'sql-name)
55 (slot-value esd 'sql-name)
57 (sql-type-to-field-string (slot-value esd 'sql-type)
58 (slot-value esd 'sql-length)))))))
60 (defun sql-type-to-field-string (type length)
67 (format nil "CHAR(~d)" length))
69 (format nil "VARCHAR(~d)" length))))
75 (format nil "VARCHAR(~d)" length))))
83 (format nil "CHAR(~D)" length))
84 ((or :fixnum :integer)
90 ((or :short-float :float)
95 (defun generate-drop-table-cmd (table-name)
96 (format nil "DROP TABLE ~a" table-name))
98 (defun generate-create-indices-cmds (table-name slots)
101 (when (slot-value slot 'indexed)
102 (let ((sql-name (slot-value slot 'sql-name)))
103 (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
107 (defun sql-cmd-index (table field unique)
108 (let ((*print-circle* nil))
109 (format nil "CREATE ~AINDEX ~A ON ~A(~A)"
110 (if unique "UNIQUE " "")
111 (sql-index-name table field)
115 (defun sql-index-name (table field)
116 (format nil "~A_~A" table field))
118 ;;;; Runtime Commands
120 (defgeneric sql-create (cl))
121 (defmethod sql-create (cl)
122 (with-sql-connection (conn)
123 (sql-execute (slot-value cl 'create-table-cmd) conn)
124 (dolist (cmd (slot-value cl 'create-indices-cmds))
125 (sql-execute cmd conn))
128 (defgeneric sql-drop (cl))
129 (defmethod sql-drop (cl)
130 (mutex-sql-execute (slot-value cl 'drop-table-cmd))
134 (defmethod sql-insert (obj)
136 (format nil "INSERT INTO ~a (~a) VALUES (~a)"
137 (sql-name self) (sql-cmd-field-names self) (format-values self))))
139 (defmethod sql-select (obj lisp-name key)
143 (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
144 (sql-cmd-field-names self) (sql-name self)
145 (inverse-field-name self) key)))))
147 (format t "process returned fields"))))
150 (defun format-values (self)
152 (fields (fields self)))
153 (dolist (field fields)
154 (unless (eq field (car fields))
155 (string-append values ","))
156 (let ((name (car field)))
157 (with-key-value-list (key value (rest field))
159 (string-append values
161 ((:fixnum :bigint :short-float :double-float)
163 (slot-value self name)))
167 (slot-value self name))))))))))
170 (defun inverse-field-string (fields)
172 (dolist (field fields)
173 (let ((name-string (write-to-string (car field))))
174 (with-key-value-list (key value (rest field))
175 (when (eq key :inverse)
176 (setq inverse value)))))
178 (write-to-string inverse))))
180 (defun row-field-string (fields)
182 (dolist (field fields)
183 (unless (eq field (car fields))
184 (string-append names ","))
185 (string-append names (lisp-name-to-sql-name (car field))))
189 (defun parse-fields (table-name fields)
191 (dolist (field fields)
192 (let* ((fname (car field))
193 (name-string (write-to-string fname))
194 (initarg (intern name-string :keyword))concat-symbol
196 (options (rest field)))
197 (with-key-value-list (key value options)
200 (setq def (nconc def (list :type
214 (setq def (nconc def (list
216 :accessor (concat-symbol
217 (write-to-string table-name) "-"
218 (write-to-string fname)))))
219 (push def class-fields)))