From 84f9a22269a37d2d58bdb0f6211f8757855c18ab Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Mon, 2 Dec 2002 15:57:17 +0000
Subject: [PATCH] r3532: *** empty log message ***

---
 base-class.lisp |  5 +++-
 connect.lisp    | 16 ++---------
 hyperobject.asd |  4 +--
 metaclass.lisp  | 11 +++++--
 mop.lisp        | 44 ++++++++++------------------
 package.lisp    |  5 ++--
 sqlgen.lisp     | 76 ++++++++++++++++++++++++++++---------------------
 views.lisp      | 19 +++++++++++--
 8 files changed, 95 insertions(+), 85 deletions(-)

diff --git a/base-class.lisp b/base-class.lisp
index 4c03156..1e3c5df 100644
--- a/base-class.lisp
+++ b/base-class.lisp
@@ -7,12 +7,15 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: base-class.lisp,v 1.1 2002/11/25 02:10:38 kevin Exp $
+;;;; $Id: base-class.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (in-package :hyperobject)
+(eval-when (:compile-toplevel :execute)
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
+
 
 (defclass hyperobject ()
   ()
diff --git a/connect.lisp b/connect.lisp
index 434a4f4..d1b3789 100644
--- a/connect.lisp
+++ b/connect.lisp
@@ -7,15 +7,15 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: connect.lisp,v 1.1 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: connect.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))))
 
 (defvar *ho-sql-db* "ho")
 (defun ho-sql-db ()
@@ -70,22 +70,12 @@
 	 (progn ,@body)
        (when ,conn (clsql:disconnect :database ,conn)))))
 
-(defun sql (stmt conn)
-  (if (string-equal "SELECT" (subseq stmt 0 6))
-      (sql-query stmt conn)
-    (sql-execute stmt conn)))
-
 (defun sql-query (cmd conn &key (types :auto))
   (clsql:query cmd :database conn :types types))
 
 (defun sql-execute (cmd conn)
   (clsql:execute-command cmd :database conn))
 
-(defun ho-sql (stmt)
-  (check-type stmt string)
-  (with-sql-connection (conn)
-    (sql stmt conn)))
-
 ;;; Pool of open connections
 
 (defmacro with-mutex-sql ((conn) &body body)
diff --git a/hyperobject.asd b/hyperobject.asd
index 1459e52..c4ad863 100644
--- a/hyperobject.asd
+++ b/hyperobject.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: hyperobject.asd,v 1.11 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: hyperobject.asd,v 1.12 2002/12/02 15:57:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -27,6 +27,6 @@
      (:file "views" :depends-on ("mop"))
      (:file "base-class" :depends-on ("views"))
      )
-     :depends-on (:kmrcl))
+     :depends-on (:kmrcl :clsql))
 
 
diff --git a/metaclass.lisp b/metaclass.lisp
index b46ab98..9c85450 100644
--- a/metaclass.lisp
+++ b/metaclass.lisp
@@ -8,7 +8,7 @@
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;;
-;;;; $Id: metaclass.lisp,v 1.1 2002/11/29 05:05:29 kevin Exp $
+;;;; $Id: metaclass.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -16,12 +16,17 @@
  
 (in-package :hyperobject)
 
+(eval-when (:compile-toplevel :execute)
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
+
+  
 (defparameter *class-options*
   '(:title :print-slots :description :version :sql-name)
   "List of class options for hyperobjects.")
 (defparameter *slot-options*
-  '(:print-formatter :description :sql-name
-    :index :subobject :hyperlink :inverse)
+  '(:print-formatter :description
+    :subobject :hyperlink :hyperlink-parameters
+    :stored :indexed :inverse :unique :sql-name)
   "Slot options that can appear as an initarg")
 (defparameter *slot-options-no-initarg*
   '(:ho-type :sql-type)
diff --git a/mop.lisp b/mop.lisp
index 39e58b9..37d3da8 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: mop.lisp,v 1.4 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: mop.lisp,v 1.5 2002/12/02 15:57:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -20,7 +20,7 @@
 (in-package :hyperobject)
 
 (eval-when (:compile-toplevel :execute)
-  (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
 
 ;; Main class
 
@@ -155,10 +155,11 @@
     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
   #+allergo (declare (ignore name))
   (let* ((dsd (car dsds))
-	 (ho-type (slot-value dsd 'type)))
+	 (ho-type (slot-value dsd 'type))
+	 (sql-type (ho-type-to-sql-type ho-type)))
     (setf (slot-value dsd 'ho-type) ho-type)
+    (setf (slot-value dsd 'sql-type) sql-type)
     (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
-    (setf (slot-value dsd 'sql-type) (ho-type-to-sql-type ho-type))
     (let ((ia (compute-effective-slot-definition-initargs
 	       cl #+lispworks name dsds)))
       (apply
@@ -168,9 +169,9 @@
        :print-formatter (slot-value dsd 'print-formatter)
        :subobject (slot-value dsd 'subobject)
        :hyperlink (slot-value dsd 'hyperlink)
+       :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
        :description (slot-value dsd 'description)
-       ia)))
-  )
+       ia))))
 
 (defun ho-type-to-lisp-type (ho-type)
   (check-type ho-type symbol)
@@ -198,7 +199,7 @@
     (:string
      'string)
     (:fixnum
-     'fixnum)
+     'integer)
     (:boolean
      'boolean)
     (:integer
@@ -213,25 +214,9 @@
      ho-type)))
 
 
-
-(defun ho-type-to-sql-type (sqltype)
-  (ecase sqltype
-    (:string
-     'string)
-    (:fixnum
-     'fixnum)
-    (:bigint
-     'integer)
-    (:short-float
-     'short-float)
-    (:long
-     'long-float)
-    (:text
-     'string)))
-
 ;;;; Class initialization function
 
-(defun process-subobjects (cl)
+(defun finalize-subobjects (cl)
   "Process class subobjects slot"
   (setf (slot-value cl 'subobjects)
     (let ((subobjects '()))
@@ -244,7 +229,7 @@
 		subobjects)))
       subobjects)))
 
-(defun process-documentation (cl)
+(defun finalize-documentation (cl)
   "Calculate class documentation slot"
   (awhen (slot-value cl 'title)
 	 (setf (slot-value cl 'title) (car it)))
@@ -266,10 +251,11 @@
 
 (defun init-hyperobject-class (cl)
   "Initialize a hyperobject class. Calculates all class slots"
-  (process-subobjects cl)
-  (process-views cl)
-  (process-sql cl)
-  (process-documentation cl))
+  (finalize-subobjects cl)
+  (finalize-views cl)
+  (finalize-hyperlinks cl)
+  (finalize-sql cl)
+  (finalize-documentation cl))
 
 
 ;;;; *************************************************************************
diff --git a/package.lisp b/package.lisp
index c2f3f5b..656342f 100644
--- a/package.lisp
+++ b/package.lisp
@@ -7,12 +7,13 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.13 2002/11/29 05:05:29 kevin Exp $
+;;;; $Id: package.lisp,v 1.14 2002/12/02 15:57:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(eval-when (:compile-toplevel :execute)
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
 
 (in-package :cl-user)
 
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))))
diff --git a/views.lisp b/views.lisp
index 2626743..8b72193 100644
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.4 2002/11/29 23:14:31 kevin Exp $
+;;;; $Id: views.lisp,v 1.5 2002/12/02 15:57:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -16,14 +16,27 @@
 (in-package :hyperobject)
 
 (eval-when (:compile-toplevel :execute)
-  (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
 
 
 ;;;; *************************************************************************
 ;;;;  Metaclass Intialization
 ;;;; *************************************************************************
 
-(defun process-views (cl)
+(defun finalize-hyperlinks (cl)
+  (let ((hyperlinks '()))
+    (dolist (esd (class-slots cl))
+      (awhen (slot-value esd 'hyperlink)
+        (push
+	 (make-instance 'hyperlink
+			:name (slot-definition-name esd)
+			:lookup it
+			:link-parameters (slot-value esd 'link-parameters))
+	 hyperlinks)))
+    (setf (slot-value cl 'hyperlinks) hyperlinks)))
+
+
+(defun finalize-views (cl)
   "Calculate all view slots for a hyperobject class"
   (let ((fmtstr-text "")
 	(fmtstr-html "")
-- 
2.34.1