X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=sql.lisp;h=294effe8cc135438d94baa522560d133d52eaa91;hp=6667de0c91137dae6f4c879c8a86e7c3bc75beb7;hb=HEAD;hpb=3da54733f61bd3305fdc5abd5fc961051c59ffb8

diff --git a/sql.lisp b/sql.lisp
index 6667de0..294effe 100644
--- a/sql.lisp
+++ b/sql.lisp
@@ -1,125 +1,91 @@
-ld;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
 ;;;; *************************************************************************
 ;;;; 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.1 2002/12/09 10:42:06 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)))
+                                         (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))))
+        (define-inverse cl esd))))
   )
 
-(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"
   (let ((inverse (slot-value esd 'inverse)))
     (when inverse
       (eval
        `(defun ,inverse (obj)
-	  (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
-	  ;; create inverse function
-	  ))
+          (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
+          ;; create inverse function
+          ))
       ))
   )
 
 (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")
@@ -132,32 +98,34 @@ SQL name"
 (defun generate-create-indices-cmds (table-name slots)
   (let (indices)
     (dolist (slot slots)
-      (when (slot-value slot 'index)
-	(let ((sql-name (slot-value slot 'sql-name)))
-	  (push (sql-cmd-index table-name sql-name (slot-value slot 'unique))
-		indices))))
+      (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 ~AINDEX ~A ON ~A(~A)"
-	    (if unique "UNIQUE " "")
-	    (sql-index-name table field)
-	    table
-	    field)))
+            (if unique "UNIQUE " "")
+            (sql-index-name table field)
+            table
+            field)))
 
 (defun sql-index-name (table field)
   (format nil "~A_~A" table field))
 
 ;;;; Runtime Commands
 
+(defgeneric sql-create (cl))
 (defmethod sql-create (cl)
-  (with-sql-connection (conn)
+ (with-sql-connection (conn)
     (sql-execute (slot-value cl 'create-table-cmd) conn)
     (dolist (cmd (slot-value cl 'create-indices-cmds))
       (sql-execute cmd conn))
     (values)))
 
+(defgeneric sql-drop (cl))
 (defmethod sql-drop (cl)
   (mutex-sql-execute (slot-value cl 'drop-table-cmd))
   (values))
@@ -166,48 +134,46 @@ SQL name"
 (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))))
+           (sql-name self) (sql-cmd-field-names self) (format-values self))))
 
 (defmethod sql-select (obj lisp-name key)
-  (let ((tuple 
-	 (car 
-	  (mutex-sql-query
-	   (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
-		   (sql-cmd-field-names self) (sql-name self)
-		   (inverse-field-name self) key)))))
+  (let ((tuple
+         (car
+          (mutex-sql-query
+           (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
+                   (sql-cmd-field-names self) (sql-name self)
+                   (inverse-field-name self) key)))))
     (when tuple
       (format t "process returned fields"))))
 
 
 (defun format-values (self)
   (let ((values "")
-	(fields (fields self)))
+        (fields (fields self)))
     (dolist (field fields)
       (unless (eq field (car fields))
-	(string-append values ","))
+        (string-append values ","))
       (let ((name (car field)))
-	(with-key-value-list (key value (rest field))
-	  (when (eq key :type)
-	    (string-append values
-			      (ecase value
-				((:fixnum :bigint :short-float :double-float)
-				 (write-to-string 
-				  (slot-value self name)))
-				((:string :text)
-				 (format nil "'~a'" 
-					 (add-sql-quotes 
-					  (slot-value self name))))))))))
+        (with-key-value-list (key value (rest field))
+          (when (eq key :type)
+            (string-append values
+                              (ecase value
+                                ((:fixnum :bigint :short-float :double-float)
+                                 (write-to-string
+                                  (slot-value self name)))
+                                ((:string :text)
+                                 (format nil "'~a'"
+                                         (add-sql-quotes
+                                          (slot-value self name))))))))))
     values))
 
-
-
 (defun inverse-field-string (fields)
   (let (inverse)
     (dolist (field fields)
       (let ((name-string (write-to-string (car field))))
-	(with-key-value-list (key value (rest field))
-	  (when (eq key :inverse)
-	    (setq inverse value)))))
+        (with-key-value-list (key value (rest field))
+          (when (eq key :inverse)
+            (setq inverse value)))))
     (when inverse
       (write-to-string inverse))))
 
@@ -215,42 +181,42 @@ SQL name"
   (let ((names ""))
     (dolist (field fields)
       (unless (eq field (car fields))
-	(string-append names ","))
+        (string-append names ","))
       (string-append names (lisp-name-to-sql-name (car field))))
     names))
 
-      
+
 (defun parse-fields (table-name fields)
   (let (class-fields)
     (dolist (field fields)
       (let* ((fname (car field))
-	     (name-string (write-to-string fname))
-	     (initarg (intern name-string :keyword))concat-symbol
-	     (def (list fname))
-	     (options (rest field)))
-	(with-key-value-list (key value options)
-	  (case key
-	    (:type
-	     (setq def (nconc def (list :type 
-					(ecase value
-					  (:string
-					   'string)
-					  (:fixnum
-					   'fixnum)
-					  (:bigint
-					   'integer)
-					  (:short-float
-					   'short-float)
-					  (:long
-					   'long-float)
-					  (:text
-					   'string))))))))
-	(setq def (nconc def (list 
-			      :initarg initarg
-			      :accessor (concat-symbol 
-					 (write-to-string table-name) "-"
-					 (write-to-string fname)))))
-	(push def class-fields)))
+             (name-string (write-to-string fname))
+             (initarg (intern name-string :keyword))concat-symbol
+             (def (list fname))
+             (options (rest field)))
+        (with-key-value-list (key value options)
+          (case key
+            (:type
+             (setq def (nconc def (list :type
+                                        (ecase value
+                                          (:string
+                                           'string)
+                                          (:fixnum
+                                           'fixnum)
+                                          (:long-integer
+                                           'integer)
+                                          (:short-float
+                                           'short-float)
+                                          (:long
+                                           'long-float)
+                                          (:text
+                                           'string))))))))
+        (setq def (nconc def (list
+                              :initarg initarg
+                              :accessor (concat-symbol
+                                         (write-to-string table-name) "-"
+                                         (write-to-string fname)))))
+        (push def class-fields)))
     class-fields))
 
 ||#