;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: sqlgen.lisp,v 1.3 2002/12/05 18:15:23 kevin Exp $
+;;;; $Id: sqlgen.lisp,v 1.4 2002/12/06 16:18:49 kevin Exp $
;;;;
;;;; This file, part of Hyperobject-SQL, is
;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
;;;; Metaclass initialization commands
(defun finalize-sql (cl)
- (declare (ignore cl))
- nil
- )
-
-#||
-
-(defun finalize-sql (cl)
+ (setf (slot-value cl 'sql-name) (sql-name cl))
+ (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd
+ (slot-value cl 'sql-name)))
(let ((esds (class-slots cl)))
- (let* ((table-name-slot (slot-value cl 'sql-name))
- (generate-table-cmd (generate-create-table-string
- (if (consp table-name-slot)
- (car table-name-slot)
- table-name-slot)
- esds)))
- (setf (slot-value cl 'create-table-cmd) generate-table-cmd))
-
+ (dolist (esd esds)
+ (setf (slot-value cl 'sql-name) (sql-name esd)))
+ (setf (slot-value cl 'create-table-cmd)
+ (generate-create-table-cmd (slot-value cl 'sql-name) esds))
+ (setf (slot-value cl 'create-indices-cmds)
+ (generate-create-indices-cmds (slot-value cl 'sql-name) esds))
(dolist (esd esds)
(when (slot-value esd 'inverse)
(define-inverse cl esd))))
)
+(defmethod sql-name ((cl hyperobject-class))
+ "Return name of SQL table for a class"
+ (let-if (it (slot-value cl 'sql-name))
+ (let* ((name (if (consp it) (car it) it))
+ (lisp-name (if name name (class-name cl))))
+ (lisp-name-to-sql-name lisp-name))))
+
+(defmethod sql-name ((esd hyperobject-esd))
+ (let-if (it (slot-value esd 'sql-name))
+ (let* ((name (if (consp it) (car it) it))
+ (lisp-name (if name name (slot-definition-name esd))))
+ (lisp-name-to-sql-name lisp-name))))
+
+
+(defun lisp-name-to-sql-name (lisp)
+ "Convert a lisp name (atom or list, string or symbol) into a canonical
+SQL name"
+ (unless (stringp lisp)
+ (setq lisp (write-to-string lisp)))
+ (let ((sql (make-string (length lisp))))
+ (dotimes (i (length lisp))
+ (declare (fixnum i))
+ (let ((c (char lisp i)))
+ (case c
+ (#\- #\_)
+ (#\$ #\_)
+ (#\+ #\_)
+ (otherwise c))))
+ (string-upcase sql)))
+
+
(defun define-inverse (class esd)
+ "Define an inverse function for a slot"
(let ((inverse (slot-value esd 'inverse)))
(when inverse
(eval
`(defun ,inverse (obj)
- (format t "~&Finding key: ~s~%" obj)
- (make-instance 'st)
+ (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
+ ;; create inverse function
))
-
- ;; create inverse function
))
)
-(defun generate-create-table-string (table-name esds)
- (let ((cmd (format nil "CREATE TABLE ~A ("
- (slot-name-to-sql-name table-name))))
+(defun generate-create-table-cmd (table-name esds)
+ (let ((cmd (format nil "CREATE TABLE ~A (" table-name)))
(dolist (esd esds)
(unless (eq esd (car esds))
(string-append cmd ", "))
- (string-append cmd (slot-name-to-sql-name (slot-definition-name esd))
+ (string-append cmd (lisp-name-to-sql-name (slot-definition-name esd))
" ")
- (let ((length (esd-length esd))
- (sql-type (esd-sql-type esd)))
+ (let ((length (slot-value esd 'length))
+ (sql-type (slot-value esd 'sql-type)))
(string-append cmd (sql-field-cmd sql-type length))))
(string-append cmd ")")))
-;;;; Runtime Commands
+(defun sql-field-cmd (type length)
+ (ecase type
+ (:string
+ (cond
+ ((null length)
+ "LONGTEXT")
+ ((< length 8)
+ (format nil "CHAR(~d)" length))
+ (t
+ (format nil "VARCHAR(~d)" length))))
+ (:text
+ "LONGTEXT")
+ (:fixnum
+ "INTEGER")
+ (:bigint
+ "BIGINT")
+ (:short-float
+ "SINGLE")
+ (:long-float
+ "DOUBLE")))
-(defclass sqltable ()
- ()
- )
+(defun generate-drop-table-cmd (table-name)
+ (format nil "DROP TABLE ~a" table-name))
-(defmethod sql-create ((self sqltable))
+(defun generate-create-indices-cmds (table-name slots)
+ (let (indices)
+ (dolist (slot slots)
+ (when (slot-value slot 'indexed)
+ (let ((sql-name (slot-value slot 'sql-name)))
+ (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
+ indices))))
+ indices))
+
+(defun sql-cmd-index (table field unique)
+ (let ((*print-circle* nil))
+ (format nil "CREATE ~A INDEX ~A ON ~A(~A)"
+ (if unique "UNIQUE" "")
+ table
+ (sql-index-name table field)
+ table
+ field)))
+
+(defun sql-index-name (table field)
+ (format nil "~A_~A" table field))
+
+;;;; Runtime Commands
+
+(defmethod sql-create (cl)
(with-sql-connection (conn)
- (sql-execute (sql-cmd-create-table self) conn)
- (dolist (cmd (sql-cmd-create-indices self))
+ (sql-execute (slot-value cl 'create-table-cmd) conn)
+ (dolist (cmd (slot-value cl 'create-indices-cmds))
(sql-execute cmd conn))
(values)))
-(defmethod sql-drop ((self sqltable))
- (mutex-sql-execute (sql-cmd-drop-table self))
+(defmethod sql-drop (cl)
+ (mutex-sql-execute (slot-value cl 'drop-table-cmd))
(values))
-(defmethod sql-insert ((self sqltable))
+#|
+(defmethod sql-insert (obj)
(mutex-sql-execute
(format nil "INSERT INTO ~a (~a) VALUES (~a)"
(sql-name self) (sql-cmd-field-names self) (format-values self))))
-(defmethod sql-select ((self sqltable) key)
+(defmethod sql-select (obj lisp-name key)
(let ((tuple
(car
(mutex-sql-query
(slot-value self name))))))))))
values))
-(defmacro defsqltable (tname &key fields)
- `(progn
- (defclass ,tname (sqltable)
- ,(parse-fields tname fields)
- ,(default-initargs fields))
-
- (defmethod sql-name ((self ,tname))
- ,(substitute #\_ #\- (write-to-string tname)))
-
- (defmethod fields ((self ,tname))
- (quote ,fields))
-
- (defmethod sql-cmd-create-table ((self ,tname))
- ,(create-table-string tname fields))
-
- (defmethod sql-cmd-create-indices ((self ,tname))
- "Return a list of index cmds"
- (quote ,(create-indices-string tname fields)))
-
- (defmethod sql-cmd-drop-table ((self ,tname))
- ,(format nil "DROP TABLE ~a" tname))
-
- (defmethod sql-cmd-field-names ((self ,tname))
- ,(row-field-string fields))
-
- (defmethod inverse-field-name ((self ,tname))
- ,(inverse-field-string fields))
- ))
-(defun create-indices-string (table-name fields)
- (let (indices)
- (dolist (field fields)
- (let ((name-string (write-to-string (car field))))
- (with-key-value-list (key value (rest field))
- (when (eq key :unique)
- (case value
- (nil
- (push (sql-cmd-index table-name name-string nil) indices))
- (t
- (push (sql-cmd-index table-name name-string t) indices)))))))
- indices))
(defun inverse-field-string (fields)
(let (inverse)
(when inverse
(write-to-string inverse))))
-(defun sql-cmd-index (table field unique)
- (let ((*print-circle* nil))
- (format nil "CREATE ~A INDEX ~A_~A ON ~A(~A)"
- (if unique "UNIQUE" "")
- (slot-name-to-sql-name table)
- (slot-name-to-sql-name field)
- (slot-name-to-sql-name table)
- (slot-name-to-sql-name field))))
-
(defun row-field-string (fields)
(let ((names ""))
(dolist (field fields)
(unless (eq field (car fields))
(string-append names ","))
- (string-append names (slot-name-to-sql-name (car field))))
+ (string-append names (lisp-name-to-sql-name (car field))))
names))
-
-(defun slot-name-to-sql-name (name)
- (let ((str (string-upcase (etypecase name
- (string
- name)
- (symbol
- (write-to-string name))))))
- (substitute #\_ #\- str)))
-(defun create-table-string (table-name fields)
- (let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name))))
- (dolist (field fields)
- (unless (eq field (car fields))
- (string-append cmd ", "))
- (string-append cmd (slot-name-to-sql-name (car field)) " ")
- (let (length type)
- (with-key-value-list (key value (rest field))
- (case key
- (:length
- (setq length value))
- (:type
- (setq type value))))
- (string-append cmd (sql-field-cmd type length))))
- (string-append cmd ")")))
-
-
-(defun sql-field-cmd (type length)
- (ecase type
- (:string
- (if (< length 8)
- (format nil "CHAR(~d)" length)
- (format nil "VARCHAR(~d)" length)))
- (:text
- "LONGTEXT")
- (:fixnum
- "INTEGER")
- (:bigint
- "BIGINT")
- (:short-float
- "SINGLE")
- (:long-float
- "DOUBLE")))
-(defmacro with-key-value-list ((key value list) form)
- (let ((i (gensym)))
- `(loop for ,i from 0 to (1- (length ,list)) by 2 do
- (let ((,key (nth ,i ,list))
- (,value (nth (1+ ,i) ,list)))
- ,form))))
-
(defun parse-fields (table-name fields)
(let (class-fields)
(dolist (field fields)
(push def class-fields)))
class-fields))
-(defun default-initargs (fields)
- (let ((initargs (list :default-initargs)))
- (dolist (field fields)
- (let* ((fname (car field))
- (name-string (write-to-string fname))
- (initarg (intern name-string :keyword)))
- (setq initargs (nconc initargs (list initarg nil)))))
- initargs))
-
-
||#
projects / hyperobject.git / commitdiff