X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=sql.lisp;h=d529f678b52e6b15bcd22711b77c2a5d68db651e;hp=179a452d9e3cc9dbe0d9852e36120826dc34b79d;hb=384290f4271aa9acef79d39ba86deb49ae828cbf;hpb=3537a8422aeb2817b41ee835c5ff45ba1d973c98

diff --git a/sql.lisp b/sql.lisp
index 179a452..d529f67 100644
--- 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)