From 3da54733f61bd3305fdc5abd5fc961051c59ffb8 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Mon, 9 Dec 2002 10:42:06 +0000
Subject: [PATCH] r3588: sql.lisp

---
 sql.lisp | 256 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 256 insertions(+)
 create mode 100644 sql.lisp

diff --git a/sql.lisp b/sql.lisp
new file mode 100644
index 0000000..6667de0
--- /dev/null
+++ b/sql.lisp
@@ -0,0 +1,256 @@
+ld;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          sqlgen.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 $
+;;;;
+;;;; This file, part of Hyperobject-SQL, is
+;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; *************************************************************************
+
+(in-package :hyperobject)
+(eval-when (:compile-toplevel :execute)
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
+
+
+;;;; 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))
+    (setf (slot-value cl 'create-indices-cmds)
+	  (generate-create-indices-cmds (slot-value cl 'sql-name) esds))
+    (dolist (esd esds)
+      (when (slot-value esd 'inverse)
+	(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
+	  ))
+      ))
+  )
+
+(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))
+    (:string
+     (cond
+       ((null length)
+	"LONGTEXT")
+       ((< length 8)
+	 (format nil "CHAR(~d)" length))
+       (t
+	(format nil "VARCHAR(~d)" length))))
+    (:text
+     "LONGTEXT")
+    (:char
+     (unless length
+       (setq length 1))
+     (format nil "CHAR(~D)" length))
+    (:character
+     "CHAR(1)")
+    ((or :fixnum :integer)
+     "INTEGER")
+    (:bigint
+     "BIGINT")
+    ((or :short-float :float)
+     "SINGLE")
+    (:long-float
+     "DOUBLE")))
+
+(defun generate-drop-table-cmd (table-name)
+  (format nil "DROP TABLE ~a" table-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))))
+    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)))
+
+(defun sql-index-name (table field)
+  (format nil "~A_~A" table field))
+
+;;;; Runtime Commands
+
+(defmethod sql-create (cl)
+  (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)))
+
+(defmethod sql-drop (cl)
+  (mutex-sql-execute (slot-value cl 'drop-table-cmd))
+  (values))
+
+#|
+(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))))
+
+(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)))))
+    (when tuple
+      (format t "process returned fields"))))
+
+
+(defun format-values (self)
+  (let ((values "")
+	(fields (fields self)))
+    (dolist (field fields)
+      (unless (eq field (car fields))
+	(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))))))))))
+    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)))))
+    (when inverse
+      (write-to-string inverse))))
+
+(defun row-field-string (fields)
+  (let ((names ""))
+    (dolist (field fields)
+      (unless (eq field (car fields))
+	(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)))
+    class-fields))
+
+||#
-- 
2.34.1