X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sqlgen.lisp;h=4b37fb902ccacb2f8bd25e697d18e078b863d65d;hb=84f9a22269a37d2d58bdb0f6211f8757855c18ab;hp=37a2c0102e8ce814d2a7de89de40b8e7c60630b2;hpb=edf35ea710bcc900bfc3cffe27a84bb8b2158652;p=hyperobject.git

diff --git a/sqlgen.lisp b/sqlgen.lisp
index 37a2c01..4b37fb9 100644
--- a/sqlgen.lisp
+++ b/sqlgen.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,38 +7,46 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sqlgen.lisp,v 1.1 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: sqlgen.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
 ;;;;
 ;;;; This file, part of Hyperobject-SQL, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
 ;;;; *************************************************************************
 
 (in-package :hyperobject)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+(eval-when (:compile-toplevel :execute)
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
 
 
 ;;;; Metaclass initialization commands
-(defun process-sql (cl)
+
+(defun finalize-sql (cl)
+  (declare (ignore cl))
+  nil
+  )
+
+#+ignore
+(defun finalize-sql (cl)
   (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)
-                                dsds)))
+                                esds)))
       (setf (slot-value cl 'create-table-cmd) generate-table-cmd))
 
-    (dolist (dsd dsds)
-      (when (dsd-inverse dsd)
-	(define-inverse cl dsd))))
+    (dolist (esd esds)
+      (when (slot-value esd 'inverse)
+	(define-inverse cl esd))))
   )
 
-(defun define-inverse (class dsd)
-  (let ((inverse (dsd-inverse dsd)))
+(defun define-inverse (class esd)
+  (let ((inverse (slot-value esd 'inverse)))
     (when inverse
       (eval
-       `(defun ,inverse (key)
-	  (format t "~&Finding key: ~a~%" key)
+       `(defun ,inverse (obj)
+	  (format t "~&Finding key: ~s~%" obj)
 	  (make-instance 'st)
 	  ))
 	   
@@ -46,18 +54,16 @@
       ))
   )
 
-(defun generate-create-table-string (table-name dsds)
+(defun generate-create-table-string (table-name esds)
   (let ((cmd (format nil "CREATE TABLE ~A (" 
 		     (slot-name-to-sql-name table-name))))
-    (dolist (dsd dsds)
-      (unless (eq dsd (car dsds))
+    (dolist (esd esds)
+      (unless (eq esd (car esds))
 	(string-append cmd ", "))
-      (string-append cmd (slot-name-to-sql-name 
-                             #+allegro (clos:slot-definition-name dsd)
-                             #+lispworks (clos:slot-definition-name dsd)
-                             ) " ")
-      (let ((length (dsd-length dsd))
-	    (sql-type (dsd-sql-type dsd)))
+      (string-append cmd (slot-name-to-sql-name (slot-definition-name esd))
+                             " ")
+      (let ((length (esd-length esd))
+	    (sql-type (esd-sql-type esd)))
 	(string-append cmd (sql-field-cmd sql-type length))))
     (string-append cmd ")")))
 
@@ -69,26 +75,27 @@
   )
 
 (defmethod sql-create ((self sqltable))
-  (sql (sql-cmd-create-table self))
-  (dolist (cmd (sql-cmd-create-indices self))
-    (sql cmd))
-  (values))
+  (with-sql-connection (conn)
+    (sql-execute (sql-cmd-create-table self) conn)
+    (dolist (cmd (sql-cmd-create-indices self))
+      (sql-execute cmd conn))
+    (values)))
 
 (defmethod sql-drop ((self sqltable))
-  (sql (sql-cmd-drop-table self))
+  (mutex-sql-execute (sql-cmd-drop-table self))
   (values))
 
 (defmethod sql-insert ((self sqltable))
-  (sql
+  (mutex-sql-execute
    (format nil "INSERT INTO ~a (~a) VALUES (~a)"
-	   (table-name self) (sql-cmd-field-names self) (format-values self))))
+	   (sql-name self) (sql-cmd-field-names self) (format-values self))))
 
 (defmethod sql-select ((self sqltable) key)
   (let ((tuple 
 	 (car 
-	  (sql
+	  (mutex-sql-query
 	   (format nil "SELECT ~a FROM ~a WHERE ~a=~a"
-		   (sql-cmd-field-names self) (table-name self)
+		   (sql-cmd-field-names self) (sql-name self)
 		   (inverse-field-name self) key)))))
     (when tuple
       (format t "process returned fields"))))
@@ -120,7 +127,7 @@
        ,(parse-fields tname fields)
        ,(default-initargs fields))
      
-     (defmethod table-name ((self ,tname))
+     (defmethod sql-name ((self ,tname))
        ,(substitute #\_ #\- (write-to-string tname)))
 
      (defmethod fields ((self ,tname))
@@ -184,7 +191,12 @@
     names))
 	  
 (defun slot-name-to-sql-name (name)
-  (substitute #\_ #\- (format nil "~a" 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))))