;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: sqlgen.lisp
+;;;; Name: sql.lisp
;;;; Purpose: SQL Generation functions for Hyperobject
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: sql.lisp,v 1.5 2003/05/14 05:29:48 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
-(in-package :hyperobject)
-(eval-when (:compile-toplevel :execute)
- (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
-
+(in-package #:hyperobject)
;;;; 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)))
+ (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))
+ (generate-create-table-cmd
+ cl
+ (remove-if #'(lambda (esd) (null (esd-stored esd))) esds)))
(setf (slot-value cl 'create-indices-cmds)
- (generate-create-indices-cmds (slot-value cl 'sql-name) esds))
+ (generate-create-indices-cmds (sql-name cl) esds))
(dolist (esd esds)
(when (slot-value esd 'inverse)
- (define-inverse cl esd))))
- )
-
-(defgeneric sql-name (cl)
+ (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
- ))
+ (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))
+ (with-output-to-string (s)
+ (format s "CREATE TABLE ~A (~{~A~^, ~})"
+ (slot-value cl 'sql-name)
+ (loop for esd in esds
+ collect
+ (concatenate
+ 'string
+ (slot-value esd 'sql-name)
+ " "
+ (sql-type-to-field-string (slot-value esd 'sql-type)
+ (slot-value esd 'sql-length)))))))
+
+(defun sql-type-to-field-string (type length)
+ (ecase type
(:string
(cond
- ((null length)
- "LONGTEXT")
- ((< length 8)
- (format nil "CHAR(~d)" length))
- (t
- (format nil "VARCHAR(~d)" length))))
+ ((null length)
+ "LONGTEXT")
+ ((< length 8)
+ (format nil "CHAR(~d)" length))
+ (t
+ (format nil "VARCHAR(~d)" length))))
+ (:varchar
+ (cond
+ ((null length)
+ "LONGTEXT")
+ (t
+ (format nil "VARCHAR(~d)" length))))
(:text
"LONGTEXT")
+ (:datetime
+ "VARCHAR(20)")
(:char
(unless length
(setq length 1))
(format nil "CHAR(~D)" length))
- (:character
- "CHAR(1)")
((or :fixnum :integer)
"INTEGER")
- (:bigint
+ (:boolean
+ "CHAR(1)")
+ (:long-integer
"BIGINT")
((or :short-float :float)
"SINGLE")
(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))))
+ (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 ~AINDEX ~A ON ~A(~A)"
- (if unique "UNIQUE " "")
- (sql-index-name table field)
- table
- field)))
+ (if unique "UNIQUE " "")
+ (sql-index-name table field)
+ table
+ field)))
(defun sql-index-name (table field)
(format nil "~A_~A" table field))
(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))))
+ (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)))))
+ (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)))
+ (fields (fields self)))
(dolist (field fields)
(unless (eq field (car fields))
- (string-append values ","))
+ (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))))))))))
+ (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)))))
+ (with-key-value-list (key value (rest field))
+ (when (eq key :inverse)
+ (setq inverse value)))))
(when inverse
(write-to-string inverse))))
(let ((names ""))
(dolist (field fields)
(unless (eq field (car fields))
- (string-append names ","))
+ (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)))
+ (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)
+ (:long-integer
+ '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 / blobdiff