--- /dev/null
+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))
+
+||#
projects / hyperobject.git / commitdiff