X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=sql.lisp;h=224652a8e51314716c5abf4f67a2e1d9a9993cfb;hp=e4faaa00ea3a61c2eefc8984bfc8f5e61f9391b9;hb=84f0745468d57540f972b31c230f1ccae2bc1768;hpb=09aedab69b129fc5929a770fab849d6452e1256d

diff --git a/sql.lisp b/sql.lisp
index e4faaa0..224652a 100644
--- a/sql.lisp
+++ b/sql.lisp
@@ -2,77 +2,35 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          sqlgen.lisp
+;;;; Name:          sql.lisp
 ;;;; Purpose:       SQL Generation functions for Hyperobject
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sql.lisp,v 1.4 2003/03/29 04:10:44 kevin Exp $
+;;;; $Id$
 ;;;;
-;;;; This file, part of Hyperobject-SQL, is
-;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
-(in-package :hyperobject)
-(eval-when (:compile-toplevel :execute)
-  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
-
+(in-package #:hyperobject)
 
 ;;;; 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)))))
-  (let ((sql (make-string (length lisp))))
-    (dotimes (i (length lisp))
-      (declare (fixnum i))
-      (setf (char sql 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"
@@ -87,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")
@@ -135,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))))
@@ -204,8 +167,6 @@ SQL name"
 					  (slot-value self name))))))))))
     values))
 
-
-
 (defun inverse-field-string (fields)
   (let (inverse)
     (dolist (field fields)
@@ -242,7 +203,7 @@ SQL name"
 					   'string)
 					  (:fixnum
 					   'fixnum)
-					  (:bigint
+					  (:long-integer
 					   'integer)
 					  (:short-float
 					   'short-float)