;;;; *************************************************************************
;;;; 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.3 2003/03/29 04:04:21 kevin Exp $
+;;;; $Id$
;;;;
-;;;; This file, part of Hyperobject-SQL, is
-;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; 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)))
(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 hyperobject-class))
- )
-
-(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"
)
(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)
+ (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))))
(slot-value self name))))))))))
values))
-
-
(defun inverse-field-string (fields)
(let (inverse)
(dolist (field fields)
'string)
(:fixnum
'fixnum)
- (:bigint
+ (:long-integer
'integer)
(:short-float
'short-float)
projects / hyperobject.git / blobdiff