-ld;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
;;;; *************************************************************************
;;;; 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.1 2002/12/09 10:42:06 kevin Exp $
+;;;; $Id: sql.lisp,v 1.6 2003/06/06 21:59:29 kevin Exp $
;;;;
-;;;; 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
(define-inverse cl esd))))
)
+(defgeneric sql-name (cl)
+ )
+
(defmethod sql-name ((cl hyperobject-class))
"Return name of SQL table for a class"
(let* ((sql-name-slot (slot-value cl '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"
(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)))
-
+ (do* ((len (length lisp))
+ (sql (make-string len))
+ (i 0 (1+ i)))
+ ((= i len) (string-upcase sql))
+ (declare (fixnum i)
+ (simple-string sql))
+ (setf (schar sql i)
+ (let ((c (char lisp i)))
+ (case c
+ ((#\- #\$ #\+ #\#) #\_)
+ (otherwise c))))))
(defun define-inverse (class esd)
"Define an inverse function for a slot"
;;;; Runtime Commands
+(defgeneric sql-create (cl))
(defmethod sql-create (cl)
- (with-sql-connection (conn)
+ (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)))
+(defgeneric sql-drop (cl))
(defmethod sql-drop (cl)
(mutex-sql-execute (slot-value cl 'drop-table-cmd))
(values))
(slot-value self name))))))))))
values))
-
-
(defun inverse-field-string (fields)
(let (inverse)
(dolist (field fields)