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