-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; 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.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)
-(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)
- (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)))
- (setf (slot-value cl 'create-table-cmd) generate-table-cmd))
- (dolist (dsd dsds)
- (when (dsd-inverse dsd)
- (define-inverse cl dsd))))
+(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))))
)
-(defun define-inverse (class dsd)
- (let ((inverse (dsd-inverse dsd)))
+(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 (key)
- (format t "~&Finding key: ~a~%" key)
- (make-instance 'st)
+ `(defun ,inverse (obj)
+ (format t "~&Finding key: ~S for class ~S ~%" obj ,class)
+ ;; create inverse function
))
-
- ;; create inverse function
))
)
-(defun generate-create-table-string (table-name dsds)
- (let ((cmd (format nil "CREATE TABLE ~A ("
- (slot-name-to-sql-name table-name))))
- (dolist (dsd dsds)
- (unless (eq dsd (car dsds))
+(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 (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 (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 ")")))
-;;;; Runtime Commands
+(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")))
-(defclass sqltable ()
- ()
- )
+(defun generate-drop-table-cmd (table-name)
+ (format nil "DROP TABLE ~a" table-name))
-(defmethod sql-create ((self sqltable))
- (sql (sql-cmd-create-table self))
- (dolist (cmd (sql-cmd-create-indices self))
- (sql cmd))
- (values))
+(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))
-(defmethod sql-drop ((self sqltable))
- (sql (sql-cmd-drop-table self))
+(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 ((self sqltable))
- (sql
+#|
+(defmethod sql-insert (obj)
+ (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)
+(defmethod sql-select (obj lisp-name 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"))))
(slot-value self name))))))))))
values))
-(defmacro defsqltable (tname &key fields)
- `(progn
- (defclass ,tname (sqltable)
- ,(parse-fields tname fields)
- ,(default-initargs fields))
-
- (defmethod table-name ((self ,tname))
- ,(substitute #\_ #\- (write-to-string tname)))
-
- (defmethod fields ((self ,tname))
- (quote ,fields))
-
- (defmethod sql-cmd-create-table ((self ,tname))
- ,(create-table-string tname fields))
-
- (defmethod sql-cmd-create-indices ((self ,tname))
- "Return a list of index cmds"
- (quote ,(create-indices-string tname fields)))
- (defmethod sql-cmd-drop-table ((self ,tname))
- ,(format nil "DROP TABLE ~a" tname))
-
- (defmethod sql-cmd-field-names ((self ,tname))
- ,(row-field-string fields))
-
- (defmethod inverse-field-name ((self ,tname))
- ,(inverse-field-string fields))
- ))
-
-(defun create-indices-string (table-name fields)
- (let (indices)
- (dolist (field fields)
- (let ((name-string (write-to-string (car field))))
- (with-key-value-list (key value (rest field))
- (when (eq key :unique)
- (case value
- (nil
- (push (sql-cmd-index table-name name-string nil) indices))
- (t
- (push (sql-cmd-index table-name name-string t) indices)))))))
- indices))
(defun inverse-field-string (fields)
(let (inverse)
(when inverse
(write-to-string inverse))))
-(defun sql-cmd-index (table field unique)
- (let ((*print-circle* nil))
- (format nil "CREATE ~A INDEX ~A_~A ON ~A(~A)"
- (if unique "UNIQUE" "")
- (slot-name-to-sql-name table)
- (slot-name-to-sql-name field)
- (slot-name-to-sql-name table)
- (slot-name-to-sql-name field))))
-
(defun row-field-string (fields)
(let ((names ""))
(dolist (field fields)
(unless (eq field (car fields))
(string-append names ","))
- (string-append names (slot-name-to-sql-name (car field))))
+ (string-append names (lisp-name-to-sql-name (car field))))
names))
-
-(defun slot-name-to-sql-name (name)
- (substitute #\_ #\- (format nil "~a" name)))
-(defun create-table-string (table-name fields)
- (let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name))))
- (dolist (field fields)
- (unless (eq field (car fields))
- (string-append cmd ", "))
- (string-append cmd (slot-name-to-sql-name (car field)) " ")
- (let (length type)
- (with-key-value-list (key value (rest field))
- (case key
- (:length
- (setq length value))
- (:type
- (setq type value))))
- (string-append cmd (sql-field-cmd type length))))
- (string-append cmd ")")))
-
-
-(defun sql-field-cmd (type length)
- (ecase type
- (:string
- (if (< length 8)
- (format nil "CHAR(~d)" length)
- (format nil "VARCHAR(~d)" length)))
- (:text
- "LONGTEXT")
- (:fixnum
- "INTEGER")
- (:bigint
- "BIGINT")
- (:short-float
- "SINGLE")
- (:long-float
- "DOUBLE")))
-(defmacro with-key-value-list ((key value list) form)
- (let ((i (gensym)))
- `(loop for ,i from 0 to (1- (length ,list)) by 2 do
- (let ((,key (nth ,i ,list))
- (,value (nth (1+ ,i) ,list)))
- ,form))))
-
(defun parse-fields (table-name fields)
(let (class-fields)
(dolist (field fields)
(push def class-fields)))
class-fields))
-(defun default-initargs (fields)
- (let ((initargs (list :default-initargs)))
- (dolist (field fields)
- (let* ((fname (car field))
- (name-string (write-to-string fname))
- (initarg (intern name-string :keyword)))
- (setq initargs (nconc initargs (list initarg nil)))))
- initargs))
-
-
+||#
projects / hyperobject.git / blobdiff