r3532: *** empty log message ***

[hyperobject.git] / sqlgen.lisp

diff --git a/sqlgen.lisp b/sqlgen.lisp
index 37a2c0102e8ce814d2a7de89de40b8e7c60630b2..4b37fb902ccacb2f8bd25e697d18e078b863d65d 100644 (file)
--- 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))))