;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: base-class.lisp,v 1.1 2002/11/25 02:10:38 kevin Exp $
+;;;; $Id: base-class.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;; *************************************************************************
(in-package :hyperobject)
+(eval-when (:compile-toplevel :execute)
+ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
+
(defclass hyperobject ()
()
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: connect.lisp,v 1.1 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: connect.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))))
(defvar *ho-sql-db* "ho")
(defun ho-sql-db ()
(progn ,@body)
(when ,conn (clsql:disconnect :database ,conn)))))
-(defun sql (stmt conn)
- (if (string-equal "SELECT" (subseq stmt 0 6))
- (sql-query stmt conn)
- (sql-execute stmt conn)))
-
(defun sql-query (cmd conn &key (types :auto))
(clsql:query cmd :database conn :types types))
(defun sql-execute (cmd conn)
(clsql:execute-command cmd :database conn))
-(defun ho-sql (stmt)
- (check-type stmt string)
- (with-sql-connection (conn)
- (sql stmt conn)))
-
;;; Pool of open connections
(defmacro with-mutex-sql ((conn) &body body)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: hyperobject.asd,v 1.11 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: hyperobject.asd,v 1.12 2002/12/02 15:57:17 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;; *************************************************************************
(:file "views" :depends-on ("mop"))
(:file "base-class" :depends-on ("views"))
)
- :depends-on (:kmrcl))
+ :depends-on (:kmrcl :clsql))
;;;; Date Started: Apr 2000
;;;;
;;;;
-;;;; $Id: metaclass.lisp,v 1.1 2002/11/29 05:05:29 kevin Exp $
+;;;; $Id: metaclass.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
(in-package :hyperobject)
+(eval-when (:compile-toplevel :execute)
+ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
+
+
(defparameter *class-options*
'(:title :print-slots :description :version :sql-name)
"List of class options for hyperobjects.")
(defparameter *slot-options*
- '(:print-formatter :description :sql-name
- :index :subobject :hyperlink :inverse)
+ '(:print-formatter :description
+ :subobject :hyperlink :hyperlink-parameters
+ :stored :indexed :inverse :unique :sql-name)
"Slot options that can appear as an initarg")
(defparameter *slot-options-no-initarg*
'(:ho-type :sql-type)
;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
-;;;; $Id: mop.lisp,v 1.4 2002/12/01 21:07:28 kevin Exp $
+;;;; $Id: mop.lisp,v 1.5 2002/12/02 15:57:17 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
(in-package :hyperobject)
(eval-when (:compile-toplevel :execute)
- (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
;; Main class
((cl hyperobject-class) #+(or allegro lispworks) name dsds)
#+allergo (declare (ignore name))
(let* ((dsd (car dsds))
- (ho-type (slot-value dsd 'type)))
+ (ho-type (slot-value dsd 'type))
+ (sql-type (ho-type-to-sql-type ho-type)))
(setf (slot-value dsd 'ho-type) ho-type)
+ (setf (slot-value dsd 'sql-type) sql-type)
(setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
- (setf (slot-value dsd 'sql-type) (ho-type-to-sql-type ho-type))
(let ((ia (compute-effective-slot-definition-initargs
cl #+lispworks name dsds)))
(apply
:print-formatter (slot-value dsd 'print-formatter)
:subobject (slot-value dsd 'subobject)
:hyperlink (slot-value dsd 'hyperlink)
+ :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
:description (slot-value dsd 'description)
- ia)))
- )
+ ia))))
(defun ho-type-to-lisp-type (ho-type)
(check-type ho-type symbol)
(:string
'string)
(:fixnum
- 'fixnum)
+ 'integer)
(:boolean
'boolean)
(:integer
ho-type)))
-
-(defun ho-type-to-sql-type (sqltype)
- (ecase sqltype
- (:string
- 'string)
- (:fixnum
- 'fixnum)
- (:bigint
- 'integer)
- (:short-float
- 'short-float)
- (:long
- 'long-float)
- (:text
- 'string)))
-
;;;; Class initialization function
-(defun process-subobjects (cl)
+(defun finalize-subobjects (cl)
"Process class subobjects slot"
(setf (slot-value cl 'subobjects)
(let ((subobjects '()))
subobjects)))
subobjects)))
-(defun process-documentation (cl)
+(defun finalize-documentation (cl)
"Calculate class documentation slot"
(awhen (slot-value cl 'title)
(setf (slot-value cl 'title) (car it)))
(defun init-hyperobject-class (cl)
"Initialize a hyperobject class. Calculates all class slots"
- (process-subobjects cl)
- (process-views cl)
- (process-sql cl)
- (process-documentation cl))
+ (finalize-subobjects cl)
+ (finalize-views cl)
+ (finalize-hyperlinks cl)
+ (finalize-sql cl)
+ (finalize-documentation cl))
;;;; *************************************************************************
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: package.lisp,v 1.13 2002/11/29 05:05:29 kevin Exp $
+;;;; $Id: package.lisp,v 1.14 2002/12/02 15:57:17 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(eval-when (:compile-toplevel :execute)
+ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
(in-package :cl-user)
-;;;; -*- 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))))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: views.lisp,v 1.4 2002/11/29 23:14:31 kevin Exp $
+;;;; $Id: views.lisp,v 1.5 2002/12/02 15:57:17 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
(in-package :hyperobject)
(eval-when (:compile-toplevel :execute)
- (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
;;;; *************************************************************************
;;;; Metaclass Intialization
;;;; *************************************************************************
-(defun process-views (cl)
+(defun finalize-hyperlinks (cl)
+ (let ((hyperlinks '()))
+ (dolist (esd (class-slots cl))
+ (awhen (slot-value esd 'hyperlink)
+ (push
+ (make-instance 'hyperlink
+ :name (slot-definition-name esd)
+ :lookup it
+ :link-parameters (slot-value esd 'link-parameters))
+ hyperlinks)))
+ (setf (slot-value cl 'hyperlinks) hyperlinks)))
+
+
+(defun finalize-views (cl)
"Calculate all view slots for a hyperobject class"
(let ((fmtstr-text "")
(fmtstr-html "")