;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; $Id: $
+;;;; *************************************************************************
;;;;
-;;;; Description ==========================================================
-;;;; ======================================================================
+;;;; $Id$
;;;;
-;;;; The CLSQL-USQL Object Oriented Data Definitional Language (OODDL)
+;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
;;;; and Object Oriented Data Manipulation Language (OODML).
;;;;
-;;;; ======================================================================
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
(in-package #:clsql-sys)
:initform nil
:initarg :view-database
:db-kind :virtual))
- (:metaclass standard-db-class)
- (:documentation "Superclass for all CLSQL-USQL View Classes."))
+ (:metaclass view-metaclass)
+ (:documentation "Superclass for all CLSQL View Classes."))
(defmethod view-database ((self standard-db-object))
(slot-value self 'view-database))
(defvar *db-deserializing* nil)
(defvar *db-initializing* nil)
-(defmethod slot-value-using-class ((class standard-db-class) instance slot)
+(defmethod slot-value-using-class ((class view-metaclass) instance slot)
(declare (optimize (speed 3)))
(unless *db-deserializing*
(let ((slot-name (%slot-name slot))
(setf (slot-value instance slot-name) nil))))))
(call-next-method))
-(defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
+(defmethod (setf slot-value-using-class) (new-value (class view-metaclass)
instance slot)
(declare (ignore new-value instance slot))
(call-next-method))
;; Build the database tables required to store the given view class
;;
-(defmethod database-pkey-constraint ((class standard-db-class) database)
+(defmethod database-pkey-constraint ((class view-metaclass) database)
(let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
(when keylist
(format nil "CONSTRAINT ~APK PRIMARY KEY~A"
#.(locally-enable-sql-reader-syntax)
(defun ensure-schema-version-table (database)
- (unless (table-exists-p "usql_object_v" :database database)
- (create-table [usql_object_v] '(([name] (string 32))
+ (unless (table-exists-p "clsql_object_v" :database database)
+ (create-table [clsql_object_v] '(([name] string)
([vers] integer)
- ([def] (string 32)))
+ ([def] string))
:database database)))
(defun update-schema-version-records (view-class-name
slotdef database)))
(when res (setf schemadef (cons res schemadef)))))
(when schemadef
- (delete-records :from [usql_object_v]
+ (delete-records :from [clsql_object_v]
:where [= [name] (sql-escape (class-name tclass))]
:database database)
- (insert-records :into [usql_object_v]
+ (insert-records :into [clsql_object_v]
:av-pairs `(([name] ,(sql-escape (class-name tclass)))
([vers] ,(car (object-version tclass)))
([def] ,(prin1-to-string
(error "Class ~s not found." view-class-name)))
(values))
-(defmethod %install-class ((self standard-db-class) database &aux schemadef)
- (dolist (slotdef (class-slots self))
+(defmethod %install-class ((self view-metaclass) database &aux schemadef)
+ (dolist (slotdef (ordered-class-slots self))
(let ((res (database-generate-column-definition (class-name self)
slotdef database)))
(when res
(if tclass
(let ((*default-database* database))
(%uninstall-class tclass)
- (delete-records :from [usql_object_v]
+ (delete-records :from [clsql_object_v]
:where [= [name] (sql-escape view-class-name)]))
(error "Class ~s not found." view-class-name)))
(values))
superclass of the newly-defined View Class."
`(progn
(defclass ,class ,supers ,slots ,@options
- (:metaclass standard-db-class))
+ (:metaclass view-metaclass))
(finalize-inheritance (find-class ',class))))
(defun keyslots-for-class (class)
(defun generate-selection-list (vclass)
(let ((sels nil))
- (dolist (slotdef (class-slots vclass))
+ (dolist (slotdef (ordered-class-slots vclass))
(let ((res (generate-attribute-reference vclass slotdef)))
(when res
(push (cons slotdef res) sels))))
list))
(defun slot-type (slotdef)
- (let ((slot-type (slot-definition-type slotdef)))
+ (let ((slot-type (specified-type slotdef)))
(if (listp slot-type)
- (cons (find-symbol (symbol-name (car slot-type)) :usql-sys)
+ (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys)
(cdr slot-type))
- (find-symbol (symbol-name slot-type) :usql-sys))))
+ (find-symbol (symbol-name slot-type) :clsql-sys))))
(defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
(declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
(db-value-from-slot slot value database)))))
(let* ((view-class (class-of obj))
(view-class-table (view-table view-class))
- (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+ (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
(record-values (mapcar #'slot-value-list slots)))
(unless record-values
(error "No settable slots."))
(db-value-from-slot slot value database)))))
(let* ((view-class (class-of obj))
(view-class-table (view-table view-class))
- (slots (remove-if-not #'slot-storedp (class-slots view-class)))
+ (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
(record-values (mapcar #'slot-value-list slots)))
(unless record-values
(error "No settable slots."))
(let* ((view-class (class-of instance))
(joins (remove-if #'(lambda (sd)
(not (equal (view-class-slot-db-kind sd) :join)))
- (class-slots view-class))))
+ (ordered-class-slots view-class))))
(dolist (slot joins)
(let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
(cond