r5167: *** empty log message ***

[hyperobject.git] / sql.lisp

diff --git a/sql.lisp b/sql.lisp
index 179a452d9e3cc9dbe0d9852e36120826dc34b79d..d529f678b52e6b15bcd22711b77c2a5d68db651e 100644 (file)
--- a/sql.lisp
+++ b/sql.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sql.lisp,v 1.6 2003/06/06 21:59:29 kevin Exp $
+;;;; $Id: sql.lisp,v 1.7 2003/06/20 08:35:21 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -17,55 +17,20 @@
 ;;;; Metaclass initialization commands
 
 (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)))
-    (dolist (esd esds)
-      (setf (slot-value esd 'sql-name) (sql-name esd)))
     (setf (slot-value cl 'create-table-cmd)
-         (generate-create-table-cmd cl esds))
+      (generate-create-table-cmd 
+       cl 
+       (remove-if #'(lambda (esd) (null (esd-stored esd))) esds)))
     (setf (slot-value cl 'create-indices-cmds)
-         (generate-create-indices-cmds (slot-value cl 'sql-name) esds))
+      (generate-create-indices-cmds (sql-name cl) esds))
     (dolist (esd esds)
       (when (slot-value esd 'inverse)
        (define-inverse cl esd))))
   )
 
-(defgeneric sql-name (cl)
-  )
-
-(defmethod sql-name ((cl hyperobject-class))
-  "Return name of SQL table for a class"
-  (let* ((sql-name-slot (slot-value cl 'sql-name))
-        (name (if (consp sql-name-slot) (car sql-name-slot) sql-name-slot))
-        (lisp-name (if name name (class-name cl))))
-    (lisp-name-to-sql-name lisp-name)))
-
-(defmethod sql-name ((esd hyperobject-esd))
-  (let* ((name (slot-value esd 'sql-name))
-        (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
-         (typecase lisp
-           (symbol (symbol-name lisp))
-           (t (write-to-string lisp)))))
-  (do* ((len (length lisp))
-       (sql (make-string len))
-       (i 0 (1+ i)))
-      ((= i len) (string-upcase sql))
-    (declare (fixnum i)
-            (simple-string sql))
-    (setf (schar sql i)
-         (let ((c (char lisp i)))
-           (case c
-             ((#\- #\$ #\+ #\#) #\_)
-             (otherwise c))))))
                        
 (defun define-inverse (class esd)
   "Define an inverse function for a slot"
@@ -80,42 +45,47 @@ SQL name"
   )
 
 (defun generate-create-table-cmd (cl esds)
-  (let ((cmd (format nil "CREATE TABLE ~A" (slot-value cl 'sql-name)))
-       (subobjects (slot-value cl 'subobjects)))
-    (dolist (esd esds)
-      (unless (find (slot-definition-name esd) subobjects :key #'name-slot)
-       (if (eq esd (car esds))
-           (string-append cmd " (")
-           (string-append cmd ", "))
-       (string-append cmd (lisp-name-to-sql-name (slot-definition-name 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 ")")))
-
-
-(defun sql-field-cmd (type length)
-  (case (intern (symbol-name type) (symbol-name :keyword))
+  (with-output-to-string (s)
+    (format s "CREATE TABLE ~A (~{~A~^, ~})" 
+           (slot-value cl 'sql-name)
+           (loop for esd in esds
+               collect
+                 (concatenate 
+                     'string
+                   (slot-value esd 'sql-name)  
+                   " "
+                   (sql-type-to-field-string (slot-value esd 'sql-type)
+                                             (slot-value esd 'sql-length)))))))
+
+(defun sql-type-to-field-string (type length)
+  (ecase type
     (:string
      (cond
-       ((null length)
-       "LONGTEXT")
-       ((< length 8)
-        (format nil "CHAR(~d)" length))
-       (t
-       (format nil "VARCHAR(~d)" length))))
+      ((null length)
+       "LONGTEXT")
+      ((< length 8)
+       (format nil "CHAR(~d)" length))
+      (t
+       (format nil "VARCHAR(~d)" length))))
+    (:varchar
+     (cond
+      ((null length)
+       "LONGTEXT")
+      (t
+       (format nil "VARCHAR(~d)" length))))
     (:text
      "LONGTEXT")
+    (:datetime
+     "VARCHAR(20)")
     (:char
      (unless length
        (setq length 1))
      (format nil "CHAR(~D)" length))
-    (:character
-     "CHAR(1)")
     ((or :fixnum :integer)
      "INTEGER")
-    (:bigint
+    (:boolean
+     "CHAR(1)")
+    (:long-integer
      "BIGINT")
     ((or :short-float :float)
      "SINGLE")
@@ -128,7 +98,7 @@ SQL name"
 (defun generate-create-indices-cmds (table-name slots)
   (let (indices)
     (dolist (slot slots)
-      (when (slot-value slot 'index)
+      (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))))
@@ -233,7 +203,7 @@ SQL name"
                                           'string)
                                          (:fixnum
                                           'fixnum)
-                                         (:bigint
+                                         (:long-integer
                                           'integer)
                                          (:short-float
                                           'short-float)