X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=3073bfd17eb916214be19d3421e22dec168a61a8;hb=6c70be35cc348b559d8aa869ecd0e14e27d5edbc;hp=14bb76f8ddd3eb2f09e019d23191dfc7253f756b;hpb=7f0e4a65d1b425f2fa58fc7cce8296c1a6c52c2f;p=clsql.git diff --git a/sql/objects.lisp b/sql/objects.lisp index 14bb76f..3073bfd 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -1,39 +1,36 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: objects.lisp -;;;; Updated: <04/04/2004 12:07:55 marcusp> -;;;; ====================================================================== +;;;; ************************************************************************* ;;;; -;;;; 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-usql-sys) +(in-package #:clsql-sys) (defclass standard-db-object () - ((view-database - :initform nil - :initarg :view-database + ((view-database :initform nil :initarg :view-database :reader view-database :db-kind :virtual)) (:metaclass standard-db-class) - (:documentation "Superclass for all CLSQL-USQL View Classes.")) - -(defmethod view-database ((self standard-db-object)) - (slot-value self 'view-database)) + (:documentation "Superclass for all CLSQL View Classes.")) (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 standard-db-class) instance slot-def) (declare (optimize (speed 3))) (unless *db-deserializing* - (let ((slot-name (%slot-name slot)) - (slot-object (%slot-object slot class))) - (when (and (eql (view-class-slot-db-kind slot-object) :join) + (let* ((slot-name (%svuc-slot-name slot-def)) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) + (when (and (eql slot-kind :join) (not (slot-boundp instance slot-name))) (let ((*db-deserializing* t)) (if (view-database instance) @@ -47,24 +44,8 @@ (declare (ignore new-value instance slot)) (call-next-method)) -;; JMM - Can't go around trying to slot-access a symbol! Guess in -;; CMUCL slot-name is the actual slot _object_, while in lispworks it -;; is a lowly symbol (the variable is called slot-name after all) so -;; the object (or in MOP terminology- the "slot definition") has to be -;; retrieved using find-slot-definition - -(defun %slot-name (slot) - #+lispworks slot - #-lispworks (slot-definition-name slot)) - -(defun %slot-object (slot class) - (declare (ignorable class)) - #+lispworks (clos:find-slot-definition slot class) - #-lispworks slot) - (defmethod initialize-instance :around ((class standard-db-object) - &rest all-keys - &key &allow-other-keys) + &rest all-keys &key &allow-other-keys) (declare (ignore all-keys)) (let ((*db-deserializing* t)) (call-next-method))) @@ -99,36 +80,6 @@ (database-output-sql keylist database))))) -#.(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)) - ([vers] integer) - ([def] (string 32))) - :database database))) - -(defun update-schema-version-records (view-class-name - &key (database *default-database*)) - (let ((schemadef nil) - (tclass (find-class view-class-name))) - (dolist (slotdef (class-slots tclass)) - (let ((res (database-generate-column-definition view-class-name - slotdef database))) - (when res (setf schemadef (cons res schemadef))))) - (when schemadef - (delete-records :from [usql_object_v] - :where [= [name] (sql-escape (class-name tclass))] - :database database) - (insert-records :into [usql_object_v] - :av-pairs `(([name] ,(sql-escape (class-name tclass))) - ([vers] ,(car (object-version tclass))) - ([def] ,(prin1-to-string - (object-definition tclass)))) - :database database)))) - -#.(restore-sql-reader-syntax-state) - (defun create-view-from-class (view-class-name &key (database *default-database*)) "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines @@ -137,14 +88,12 @@ the view. The argument DATABASE has a default value of (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%install-class tclass database) - (ensure-schema-version-table database) - (update-schema-version-records view-class-name :database database)) + (%install-class tclass database)) (error "Class ~s not found." view-class-name))) (values)) (defmethod %install-class ((self standard-db-class) database &aux schemadef) - (dolist (slotdef (class-slots self)) + (dolist (slotdef (ordered-class-slots self)) (let ((res (database-generate-column-definition (class-name self) slotdef database))) (when res @@ -170,9 +119,7 @@ which defines that view. The argument DATABASE has a default value of (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%uninstall-class tclass) - (delete-records :from [usql_object_v] - :where [= [name] (sql-escape view-class-name)])) + (%uninstall-class tclass)) (error "Class ~s not found." view-class-name))) (values)) @@ -261,7 +208,7 @@ superclass of the newly-defined View 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)))) @@ -296,11 +243,7 @@ superclass of the newly-defined View Class." list)) (defun slot-type (slotdef) - (let ((slot-type (slot-definition-type slotdef))) - (if (listp slot-type) - (cons (find-symbol (symbol-name (car slot-type)) :usql-sys) - (cdr slot-type)) - (find-symbol (symbol-name slot-type) :usql-sys)))) + (specified-type slotdef)) (defmethod update-slot-from-db ((instance standard-db-object) slotdef value) (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) @@ -528,7 +471,7 @@ associated with that database.")) (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.")) @@ -557,7 +500,7 @@ associated with that database.")) (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.")) @@ -571,9 +514,6 @@ associated with that database.")) (setf (slot-value obj 'view-database) database)) (values))) -;; Perhaps the slot class is not correct in all CLOS implementations, -;; tho I have not run across a problem yet. - (defmethod handle-cascade-delete-rule ((instance standard-db-object) (slot view-class-effective-slot-definition)) @@ -618,7 +558,7 @@ associated with that database.")) (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 @@ -711,14 +651,14 @@ value. If nulls are allowed for the column, the slot's value will be nil, otherwise its value will be set to the result of calling DATABASE-NULL-VALUE on the type of the slot.")) -(defmethod update-slot-with-null ((instance standard-db-object) +(defmethod update-slot-with-null ((object standard-db-object) slotname slotdef) (let ((st (slot-type slotdef)) (allowed (slot-value slotdef 'nulls-ok))) (if allowed - (setf (slot-value instance slotname) nil) - (setf (slot-value instance slotname) + (setf (slot-value object slotname) nil) + (setf (slot-value object slotname) (database-null-value st))))) (defvar +no-slot-value+ '+no-slot-value+) @@ -931,7 +871,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) ;; ------------------------------------------------------------ ;; Logic for 'faulting in' :join slots -(defun fault-join-slot-raw (class instance slot-def) +(defun fault-join-slot-raw (class instancex slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) (jc (gethash :join-class dbi))) (let ((jq (join-qualifier class instance slot-def))) @@ -954,7 +894,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) ((and (not ts) (gethash :set dbi)) res))))) -(defun join-qualifier (class instance slot-def) +(defun join-qualifier (class object slot-def) (declare (ignore class)) (let* ((dbi (view-class-slot-db-info slot-def)) (jc (find-class (gethash :join-class dbi))) @@ -963,8 +903,8 @@ DATABASE-NULL-VALUE on the type of the slot.")) (foreign-keys (gethash :foreign-key dbi)) (home-keys (gethash :home-key dbi))) (when (every #'(lambda (slt) - (and (slot-boundp instance slt) - (not (null (slot-value instance slt))))) + (and (slot-boundp object slt) + (not (null (slot-value object slt))))) (if (listp home-keys) home-keys (list home-keys))) (let ((jc (mapcar #'(lambda (hk fk) @@ -979,7 +919,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) (t fk)) (typecase hk (symbol - (slot-value instance hk)) + (slot-value object hk)) (t hk))))) (if (listp home-keys) @@ -1096,6 +1036,7 @@ tuples." target-args)))) (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) + ;; (cmsg "Qual args = ~s" qualifier-args) (if (select-objects target-args) (apply #'find-all target-args qualifier-args) (let ((expr (apply #'make-query select-all-args)))