From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Sat, 28 Dec 2002 19:05:23 +0000 (+0000)
Subject: r3677: *** empty log message ***
X-Git-Tag: debian-2.11.0-2~215
X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=5a0ff7a2258a63267a93736d39100bcaec8aabbe;p=hyperobject.git

r3677: *** empty log message ***
---

diff --git a/sqlgen.lisp b/sqlgen.lisp
deleted file mode 100644
index 9ff023d..0000000
--- a/sqlgen.lisp
+++ /dev/null
@@ -1,244 +0,0 @@
-;;; -*- 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: sqlgen.lisp,v 1.4 2002/12/06 16:18:49 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 cl 'sql-name) (sql-name esd)))
-    (setf (slot-value cl 'create-table-cmd)
-	  (generate-create-table-cmd (slot-value cl 'sql-name) 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-if (it (slot-value cl 'sql-name))
-    (let* ((name (if (consp it) (car it) it))
-	   (lisp-name (if name name (class-name cl))))
-      (lisp-name-to-sql-name lisp-name))))
-
-(defmethod sql-name ((esd hyperobject-esd))
-  (let-if (it (slot-value esd 'sql-name))
-    (let* ((name (if (consp it) (car it) it))
-	   (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 (write-to-string lisp)))
-  (let ((sql (make-string (length lisp))))
-    (dotimes (i (length lisp))
-      (declare (fixnum 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 (table-name esds)
-  (let ((cmd (format nil "CREATE TABLE ~A (" table-name)))
-    (dolist (esd esds)
-      (unless (eq esd (car esds))
-	(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)
-  (ecase type
-    (:string
-     (cond
-       ((null length)
-	"LONGTEXT")
-       ((< length 8)
-	 (format nil "CHAR(~d)" length))
-       (t
-	(format nil "VARCHAR(~d)" length))))
-    (:text
-     "LONGTEXT")
-    (:fixnum
-     "INTEGER")
-    (:bigint
-     "BIGINT")
-    (:short-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 '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 ~A INDEX ~A ON ~A(~A)"
-	    (if unique "UNIQUE" "")
-	    table
-	    (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))
-
-||#