-;;;; -*- 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.2 2002/12/02 15:57:17 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)
+
+(defun finalize-sql (cl)
+ (declare (ignore cl))
+ nil
+ )
+
+#+ignore
+(defun finalize-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)))
+ esds)))
(setf (slot-value cl 'create-table-cmd) generate-table-cmd))
- (dolist (dsd dsds)
- (when (dsd-inverse dsd)
- (define-inverse cl dsd))))
+ (dolist (esd esds)
+ (when (slot-value esd 'inverse)
+ (define-inverse cl esd))))
)
-(defun define-inverse (class dsd)
- (let ((inverse (dsd-inverse dsd)))
+(defun define-inverse (class esd)
+ (let ((inverse (slot-value esd 'inverse)))
(when inverse
(eval
- `(defun ,inverse (key)
- (format t "~&Finding key: ~a~%" key)
+ `(defun ,inverse (obj)
+ (format t "~&Finding key: ~s~%" obj)
(make-instance 'st)
))
))
)
-(defun generate-create-table-string (table-name dsds)
+(defun generate-create-table-string (table-name esds)
(let ((cmd (format nil "CREATE TABLE ~A ("
(slot-name-to-sql-name table-name))))
- (dolist (dsd dsds)
- (unless (eq dsd (car dsds))
+ (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 (slot-name-to-sql-name (slot-definition-name esd))
+ " ")
+ (let ((length (esd-length esd))
+ (sql-type (esd-sql-type esd)))
(string-append cmd (sql-field-cmd sql-type length))))
(string-append cmd ")")))
)
(defmethod sql-create ((self sqltable))
- (sql (sql-cmd-create-table self))
- (dolist (cmd (sql-cmd-create-indices self))
- (sql cmd))
- (values))
+ (with-sql-connection (conn)
+ (sql-execute (sql-cmd-create-table self) conn)
+ (dolist (cmd (sql-cmd-create-indices self))
+ (sql-execute cmd conn))
+ (values)))
(defmethod sql-drop ((self sqltable))
- (sql (sql-cmd-drop-table self))
+ (mutex-sql-execute (sql-cmd-drop-table self))
(values))
(defmethod sql-insert ((self sqltable))
- (sql
+ (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)
(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"))))
,(parse-fields tname fields)
,(default-initargs fields))
- (defmethod table-name ((self ,tname))
+ (defmethod sql-name ((self ,tname))
,(substitute #\_ #\- (write-to-string tname)))
(defmethod fields ((self ,tname))
names))
(defun slot-name-to-sql-name (name)
- (substitute #\_ #\- (format nil "~a" name)))
+ (let ((str (string-upcase (etypecase name
+ (string
+ name)
+ (symbol
+ (write-to-string name))))))
+ (substitute #\_ #\- str)))
(defun create-table-string (table-name fields)
(let ((cmd (format nil "CREATE TABLE ~A (" (slot-name-to-sql-name table-name))))