From: Kevin M. Rosenberg Date: Wed, 5 May 2004 01:12:03 +0000 (+0000) Subject: r9235: fix test X-Git-Tag: v3.8.6~524 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=021d4ab301e290da50d80e2689a2e71129108248 r9235: fix test --- diff --git a/ChangeLog b/ChangeLog index 643670f..b0e070e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -27,7 +27,8 @@ Add test that default :result-types is auto for FDML QUERY. * test/test-syntax.lisp: Don't expect TYPE in the SQL-OUTPUT of SQL-IDENT-ATTRIBUTE. - * test/test-oodml.lisp: Enable OO loop iteration test + * test/test-oodml.lisp: Enable OO loop iteration test, + modify it so it doesn't depend on boolean where. 4 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) * Version 2.10.9 diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp deleted file mode 100644 index d2013b7..0000000 --- a/sql/new-objects.lisp +++ /dev/null @@ -1,878 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; -;;;; $Id: objects.lisp 8906 2004-04-09 12:41:07Z kevin $ -;;;; -;;;; 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) - -(defclass standard-db-object () - ((stored :db-kind :virtual - :initarg :stored - :initform nil)) - (:metaclass standard-db-class) - (: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-def) - (declare (optimize (speed 3))) - (unless *db-deserializing* - (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)) - (setf (slot-value instance slot-name) - (fault-join-slot class instance slot-def)))))) - (call-next-method)) - -(defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def) - (declare (ignore new-value)) - (let* ((slot-name (slot-definition-name slot-def)) - (slot-kind (view-class-slot-db-kind slot-def)) - (no-update? (or (eql slot-kind :virtual) - *db-initializing* - *db-deserializing*))) - (call-next-method) - (unless no-update? - (update-record-from-slot instance slot-name)))) - -(defmethod initialize-instance :around ((object standard-db-object) - &rest all-keys &key &allow-other-keys) - (declare (ignore all-keys)) - (let ((*db-initializing* t)) - (call-next-method) - (unless *db-deserializing* - #+nil (created-object object) - (update-records-from-instance object)))) - -(defun sequence-from-class (view-class-name) - (sql-escape - (concatenate - 'string - (symbol-name (view-table (find-class view-class-name))) - "-SEQ"))) - -(defun create-sequence-from-class (view-class-name - &key (database *default-database*)) - (create-sequence (sequence-from-class view-class-name) :database database)) - -(defun drop-sequence-from-class (view-class-name - &key (if-does-not-exist :error) - (database *default-database*)) - (drop-sequence (sequence-from-class view-class-name) - :if-does-not-exist if-does-not-exist - :database database)) - -;; -;; Build the database tables required to store the given view class -;; - -(defmethod database-pkey-constraint ((class standard-db-class) database) - (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) - (when keylist - (format nil "CONSTRAINT ~APK PRIMARY KEY~A" - (database-output-sql (view-table class) database) - (database-output-sql keylist database))))) - - -(defun create-view-from-class (view-class-name - &key (database *default-database*)) - "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines -the view. The argument DATABASE has a default value of -*DEFAULT-DATABASE*." - (let ((tclass (find-class view-class-name))) - (if tclass - (let ((*default-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 (ordered-class-slots self)) - (let ((res (database-generate-column-definition (class-name self) - slotdef database))) - (when res - (push res schemadef)))) - (unless schemadef - (error "Class ~s has no :base slots" self)) - (create-table (sql-expression :table (view-table self)) schemadef - :database database - :constraints (database-pkey-constraint self database)) - (push self (database-view-classes database)) - t) - -;; -;; Drop the tables which store the given view class -;; - -#.(locally-enable-sql-reader-syntax) - -(defun drop-view-from-class (view-class-name &key (database *default-database*)) - "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME -which defines that view. The argument DATABASE has a default value of -*DEFAULT-DATABASE*." - (let ((tclass (find-class view-class-name))) - (if tclass - (let ((*default-database* database)) - (%uninstall-class tclass)) - (error "Class ~s not found." view-class-name))) - (values)) - -#.(restore-sql-reader-syntax-state) - -(defun %uninstall-class (self &key (database *default-database*)) - (drop-table (sql-expression :table (view-table self)) - :if-does-not-exist :ignore - :database database) - (setf (database-view-classes database) - (remove self (database-view-classes database)))) - - -;; -;; List all known view classes -;; - -(defun list-classes (&key (test #'identity) - (root-class 'standard-db-object) - (database *default-database*)) - "Returns a list of View Classes connected to a given DATABASE which -defaults to *DEFAULT-DATABASE*." - (declare (ignore root-class)) - (remove-if #'(lambda (c) (not (funcall test c))) - (database-view-classes database))) - -;; -;; Define a new view class -;; - -(defmacro def-view-class (class supers slots &rest options) - "Extends the syntax of defclass to allow special slots to be mapped -onto the attributes of database views. The macro DEF-VIEW-CLASS -creates a class called CLASS which maps onto a database view. Such a -class is called a View Class. The macro DEF-VIEW-CLASS extends the -syntax of DEFCLASS to allow special base slots to be mapped onto the -attributes of database views (presently single tables). When a select -query that names a View Class is submitted, then the corresponding -database view is queried, and the slots in the resulting View Class -instances are filled with attribute values from the database. If -SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the -superclass of the newly-defined View Class." - `(progn - (defclass ,class ,supers ,slots ,@options - (:metaclass standard-db-class)) - (finalize-inheritance (find-class ',class)))) - -(defun keyslots-for-class (class) - (slot-value class 'key-slots)) - -(defun key-qualifier-for-instance (obj &key (database *default-database*)) - (let ((tb (view-table (class-of obj)))) - (flet ((qfk (k) - (sql-operation '== - (sql-expression :attribute - (view-class-slot-column k) - :table tb) - (db-value-from-slot - k - (slot-value obj (slot-definition-name k)) - database)))) - (let* ((keys (keyslots-for-class (class-of obj))) - (keyxprs (mapcar #'qfk (reverse keys)))) - (cond - ((= (length keyxprs) 0) nil) - ((= (length keyxprs) 1) (car keyxprs)) - ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs))))))) - -;; -;; Function used by 'generate-selection-list' -;; - -(defun generate-attribute-reference (vclass slotdef) - (cond - ((eq (view-class-slot-db-kind slotdef) :base) - (sql-expression :attribute (view-class-slot-column slotdef) - :table (view-table vclass))) - ((eq (view-class-slot-db-kind slotdef) :key) - (sql-expression :attribute (view-class-slot-column slotdef) - :table (view-table vclass))) - (t nil))) - -;; -;; Function used by 'find-all' -;; - -(defun generate-selection-list (vclass) - (let ((sels nil)) - (dolist (slotdef (ordered-class-slots vclass)) - (let ((res (generate-attribute-reference vclass slotdef))) - (when res - (push (cons slotdef res) sels)))) - (if sels - sels - (error "No slots of type :base in view-class ~A" (class-name vclass))))) - -;; -;; Used by 'create-view-from-class' -;; - - -(defmethod database-generate-column-definition (class slotdef database) - (declare (ignore database class)) - (when (member (view-class-slot-db-kind slotdef) '(:base :key)) - (let ((cdef - (list (sql-expression :attribute (view-class-slot-column slotdef)) - (slot-type slotdef)))) - (let ((const (view-class-slot-db-constraints slotdef))) - (when const - (setq cdef (append cdef (list const))))) - cdef))) - -;; -;; Called by 'get-slot-values-from-view' -;; - -(declaim (inline delistify)) -(defun delistify (list) - (if (listp list) - (car list) - list)) - -(defun slot-type (slotdef) - (specified-type slotdef)) - -(defvar *update-context* nil) - -(defmethod update-slot-from-db ((instance standard-db-object) slotdef value) - (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) - (let* ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-name (slot-definition-name slotdef)) - (slot-type (slot-type slotdef)) - (*update-context* (cons (type-of instance) slot-name))) - (cond ((and value (null slot-reader)) - (setf (slot-value instance slot-name) - (read-sql-value value (delistify slot-type) - *default-database*))) - ((null value) - (update-slot-with-null instance slot-name slotdef)) - ((typep slot-reader 'string) - (setf (slot-value instance slot-name) - (format nil slot-reader value))) - ((typep slot-reader 'function) - (setf (slot-value instance slot-name) - (apply slot-reader (list value)))) - (t - (error "Slot reader is of an unusual type."))))) - -(defmethod key-value-from-db (slotdef value database) - (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) - (let ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-type (slot-type slotdef))) - (cond ((and value (null slot-reader)) - (read-sql-value value (delistify slot-type) database)) - ((null value) - nil) - ((typep slot-reader 'string) - (format nil slot-reader value)) - ((typep slot-reader 'function) - (apply slot-reader (list value))) - (t - (error "Slot reader is of an unusual type."))))) - -(defun db-value-from-slot (slotdef val database) - (let ((dbwriter (view-class-slot-db-writer slotdef)) - (dbtype (slot-type slotdef))) - (typecase dbwriter - (string (format nil dbwriter val)) - (function (apply dbwriter (list val))) - (t - (typecase dbtype - (cons - (database-output-sql-as-type (car dbtype) val database)) - (t - (database-output-sql-as-type dbtype val database))))))) - -(defun check-slot-type (slotdef val) - (let* ((slot-type (slot-type slotdef)) - (basetype (if (listp slot-type) (car slot-type) slot-type))) - (when (and slot-type val) - (unless (typep val basetype) - (error 'clsql-type-error - :slotname (slot-definition-name slotdef) - :typespec slot-type - :value val))))) - -;; -;; Called by find-all -;; - -(defmethod get-slot-values-from-view (obj slotdeflist values) - (flet ((update-slot (slot-def values) - (update-slot-from-db obj slot-def values))) - (mapc #'update-slot slotdeflist values) - obj)) - -(defgeneric update-record-from-slot (object slot &key database) - (:documentation - "The generic function UPDATE-RECORD-FROM-SLOT updates an individual -data item in the column represented by SLOT. The DATABASE is only used -if OBJECT is not yet associated with any database, in which case a -record is created in DATABASE. Only SLOT is initialized in this case; -other columns in the underlying database receive default values. The -argument SLOT is the CLOS slot name; the corresponding column names -are derived from the View Class definition.")) - -(defmethod update-record-from-slot ((obj standard-db-object) slot &key - (database *default-database*)) - #+nil (odcl:updated-object obj) - (let* ((vct (view-table (class-of obj))) - (stored? (slot-value obj 'stored)) - (sd (slotdef-for-slot-with-class slot (class-of obj)))) - (check-slot-type sd (slot-value obj slot)) - (let* ((att (view-class-slot-column sd)) - (val (db-value-from-slot sd (slot-value obj slot) database))) - (cond ((and vct sd stored?) - (update-records (sql-expression :table vct) - :attributes (list (sql-expression :attribute att)) - :values (list val) - :where (key-qualifier-for-instance obj :database database) - :database database)) - ((not stored?) - t) - (t - (error "Unable to update record"))))) - t) - -(defgeneric update-record-from-slots (object slots &key database) - (:documentation - "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the -columns represented by SLOTS. The DATABASE is only used if OBJECT is -not yet associated with any database, in which case a record is -created in DATABASE. Only slots are initialized in this case; other -columns in the underlying database receive default values. The -argument SLOTS contains the CLOS slot names; the corresponding column -names are derived from the view class definition.")) - -(defmethod update-record-from-slots ((obj standard-db-object) slots &key - (database *default-database*)) - (let* ((vct (view-table (class-of obj))) - (stored? (slot-value obj 'stored)) - (sds (slotdefs-for-slots-with-class slots (class-of obj))) - (avps (mapcar #'(lambda (s) - (let ((val (slot-value - obj (slot-definition-name s)))) - (check-slot-type s val) - (list (sql-expression - :attribute (view-class-slot-column s)) - (db-value-from-slot s val database)))) - sds))) - (cond ((and avps stored?) - (update-records (sql-expression :table vct) - :av-pairs avps - :where (key-qualifier-for-instance - obj :database database) - :database database)) - (avps - (insert-records :into (sql-expression :table vct) - :av-pairs avps - :database database) - (setf (slot-value obj 'stored) t)) - (t - (error "Unable to update records")))) - t) - -(defgeneric update-records-from-instance (object &key database) - (:documentation - "Using an instance of a view class, update the database table that -stores its instance data. If the instance is already associated with a -database, that database is used, and database is ignored. If instance -is not yet associated with a database, a record is created for -instance in the appropriate table of database and the instance becomes -associated with that database.")) - -(defmethod update-records-from-instance ((obj standard-db-object) - &key (database *default-database*)) - (labels ((slot-storedp (slot) - (and (member (view-class-slot-db-kind slot) '(:base :key)) - (slot-boundp obj (slot-definition-name slot)))) - (slot-value-list (slot) - (let ((value (slot-value obj (slot-definition-name slot)))) - (check-slot-type slot value) - (list (sql-expression :attribute (view-class-slot-column slot)) - (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))) - (record-values (mapcar #'slot-value-list slots))) - (unless record-values - (error "No settable slots.")) - (if (slot-value obj 'stored) - (update-records (sql-expression :table view-class-table) - :av-pairs record-values - :where (key-qualifier-for-instance - obj :database database) - :database database) - (progn - (insert-records :into (sql-expression :table view-class-table) - :av-pairs record-values - :database database) - (setf (slot-value obj 'stored) t))))) - t) - - (setf (symbol-function (intern (symbol-name '#:store-instance))) - (symbol-function 'update-records-from-instance)) - -(defgeneric delete-instance-records (instance) - (:documentation - "Deletes the records represented by INSTANCE from the database -associated with it. If instance has no associated database, an error -is signalled.")) - -(defmethod delete-instance-records ((object standard-db-object)) - (let ((vt (sql-expression :table (view-table (class-of object)))) - (qualifier (key-qualifier-for-instance object :database *default-database*))) - (delete-records :from vt :where qualifier :database *default-database*) - #+ignore (odcl::deleted-object object))) - -(defgeneric update-instance-from-db (instance) - (:documentation - "Updates the values in the slots of the View Class instance -INSTANCE using the data in the database DATABASE which defaults to the -database that INSTANCE is associated with, or the value of -*DEFAULT-DATABASE*.")) - -(defmethod update-instance-from-db ((object standard-db-object)) - (let* ((view-class (find-class (class-name (class-of object)))) - (view-table (sql-expression :table (view-table view-class))) - (view-qual (key-qualifier-for-instance object :database *default-database*)) - (sels (generate-selection-list view-class)) - (res (apply #'select (append (mapcar #'cdr sels) (list :from view-table - :where view-qual))))) - (when res - (get-slot-values-from-view object (mapcar #'car sels) (car res)) - res))) - - -(defgeneric database-null-value (type) - (:documentation "Return an expression of type TYPE which SQL NULL values -will be converted into.")) - -(defmethod database-null-value ((type t)) - (cond - ((subtypep type 'string) nil) - ((subtypep type 'integer) nil) - ((subtypep type 'list) nil) - ((subtypep type 'boolean) nil) - ((eql type t) nil) - ((subtypep type 'symbol) nil) - ((subtypep type 'keyword) nil) - ((subtypep type 'wall-time) nil) - ((subtypep type 'duration) nil) - ((subtypep type 'money) nil) - (t - (error "Unable to handle null for type ~A" type)))) - -(defgeneric update-slot-with-null (instance slotname slotdef) - (:documentation "Called to update a slot when its column has a NULL -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 ((object standard-db-object) - slotname - slotdef) - (let ((st (slot-definition-type slotdef)) - (allowed (slot-value slotdef 'nulls-ok))) - (if allowed - (setf (slot-value object slotname) nil) - (setf (slot-value object slotname) - (database-null-value st))))) - -(defvar +no-slot-value+ '+no-slot-value+) - -(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*)) - (let* ((class (find-class classname)) - (sld (slotdef-for-slot-with-class slot class))) - (if sld - (if (eq value +no-slot-value+) - (sql-expression :attribute (view-class-slot-column sld) - :table (view-table class)) - (db-value-from-slot - sld - value - database)) - (error "Unknown slot ~A for class ~A" slot classname)))) - -(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) - (declare (ignore database)) - (let* ((class (find-class classname))) - (unless (view-table class) - (error "No view-table for class ~A" classname)) - (sql-expression :table (view-table class)))) - -(defmethod database-get-type-specifier (type args database) - (declare (ignore type args)) - (if (member (database-underlying-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)")) - -(defmethod database-get-type-specifier ((type (eql 'integer)) args database) - (declare (ignore database)) - ;;"INT8") - (if args - (format nil "INT(~A)" (car args)) - "INT")) - -(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args - database) - (if args - (format nil "VARCHAR(~A)" (car args)) - (if (member (database-underlying-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)"))) - -(defmethod database-get-type-specifier ((type (eql 'simple-string)) args - database) - (if args - (format nil "VARCHAR(~A)" (car args)) - (if (member (database-underlying-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)"))) - -(defmethod database-get-type-specifier ((type (eql 'string)) args database) - (if args - (format nil "VARCHAR(~A)" (car args)) - (if (member (database-underlying-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)"))) - -(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) - (declare (ignore args)) - (case (database-underlying-type database) - (:postgresql - "TIMESTAMP WITHOUT TIME ZONE") - (:postgresql-socket - "TIMESTAMP WITHOUT TIME ZONE") - (:mysql - "DATETIME") - (t "TIMESTAMP"))) - -(defmethod database-get-type-specifier ((type (eql 'duration)) args database) - (declare (ignore database args)) - "VARCHAR") - -(defmethod database-get-type-specifier ((type (eql 'money)) args database) - (declare (ignore database args)) - "INT8") - -(deftype raw-string (&optional len) - "A string which is not trimmed when retrieved from the database" - `(string ,len)) - -(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) - (declare (ignore database)) - (if args - (format nil "VARCHAR(~A)" (car args)) - "VARCHAR")) - -(defmethod database-get-type-specifier ((type (eql 'float)) args database) - (declare (ignore database)) - (if args - (format nil "FLOAT(~A)" (car args)) - "FLOAT")) - -(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) - (declare (ignore database)) - (if args - (format nil "FLOAT(~A)" (car args)) - "FLOAT")) - -(defmethod database-get-type-specifier ((type (eql 't)) args database) - (declare (ignore args database)) - "BOOL") - -(defmethod database-output-sql-as-type (type val database) - (declare (ignore type database)) - val) - -(defmethod database-output-sql-as-type ((type (eql 'list)) val database) - (declare (ignore database)) - (progv '(*print-circle* *print-array*) '(t t) - (let ((escaped (prin1-to-string val))) - (clsql-base::substitute-char-string - escaped #\Null " ")))) - -(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) - (declare (ignore database)) - (if val - (symbol-name val)) - "") - -(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) - (declare (ignore database)) - (if val - (symbol-name val) - "")) - -(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) - (declare (ignore database)) - (progv '(*print-circle* *print-array*) '(t t) - (prin1-to-string val))) - -(defmethod database-output-sql-as-type ((type (eql 'array)) val database) - (declare (ignore database)) - (progv '(*print-circle* *print-array*) '(t t) - (prin1-to-string val))) - -(defmethod database-output-sql-as-type ((type (eql 't)) val database) - (declare (ignore database)) - (if val "t" "f")) - -(defmethod database-output-sql-as-type ((type (eql 'string)) val database) - (declare (ignore database)) - val) - -(defmethod database-output-sql-as-type ((type (eql 'simple-string)) - val database) - (declare (ignore database)) - val) - -(defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) - val database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val type database) - (declare (ignore type database)) - (read-from-string val)) - -(defmethod read-sql-value (val (type (eql 'string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'simple-string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'raw-string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'keyword)) database) - (declare (ignore database)) - (when (< 0 (length val)) - (intern (string-upcase val) "KEYWORD"))) - -(defmethod read-sql-value (val (type (eql 'symbol)) database) - (declare (ignore database)) - (when (< 0 (length val)) - (unless (string= val "NIL") - (intern (string-upcase val) - (symbol-package *update-context*))))) - -(defmethod read-sql-value (val (type (eql 'integer)) database) - (declare (ignore database)) - (etypecase val - (string - (read-from-string val)) - (number val))) - -(defmethod read-sql-value (val (type (eql 'float)) database) - (declare (ignore database)) - ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) - (float (read-from-string val))) - -(defmethod read-sql-value (val (type (eql 't)) database) - (declare (ignore database)) - (equal "t" val)) - -(defmethod read-sql-value (val (type (eql 'wall-time)) database) - (declare (ignore database)) - (unless (eq 'NULL val) - (parse-timestring val))) - -(defmethod read-sql-value (val (type (eql 'duration)) database) - (declare (ignore database)) - (unless (or (eq 'NULL val) - (equal "NIL" val)) - (parse-timestring val))) - -(defmethod read-sql-value (val (type (eql 'money)) database) - (unless (eq 'NULL val) - (make-instance 'money :units (read-sql-value val 'integer database)))) - -;; ------------------------------------------------------------ -;; Logic for 'faulting in' :join slots - -(defun fault-join-slot-raw (class object slot-def) - (let* ((dbi (view-class-slot-db-info slot-def)) - (jc (gethash :join-class dbi))) - (let ((jq (join-qualifier class object slot-def))) - (when jq - (select jc :where jq))))) - -(defun fault-join-slot (class object slot-def) - (let* ((dbi (view-class-slot-db-info slot-def)) - (ts (gethash :target-slot dbi)) - (res (fault-join-slot-raw class object slot-def))) - (when res - (cond - ((and ts (gethash :set dbi)) - (mapcar (lambda (obj) - (cons obj (slot-value obj ts))) res)) - ((and ts (not (gethash :set dbi))) - (mapcar (lambda (obj) (slot-value obj ts)) res)) - ((and (not ts) (not (gethash :set dbi))) - (car res)) - ((and (not ts) (gethash :set dbi)) - res))))) - -(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))) - ;;(ts (gethash :target-slot dbi)) - ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc))) - (foreign-keys (gethash :foreign-key dbi)) - (home-keys (gethash :home-key dbi))) - (when (every #'(lambda (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) - (let ((fksd (slotdef-for-slot-with-class fk jc))) - (sql-operation '== - (typecase fk - (symbol - (sql-expression - :attribute (view-class-slot-column fksd) - :table (view-table jc))) - (t fk)) - (typecase hk - (symbol - (slot-value object hk)) - (t - hk))))) - (if (listp home-keys) home-keys (list home-keys)) - (if (listp foreign-keys) foreign-keys (list foreign-keys))))) - (when jc - (if (> (length jc) 1) - (apply #'sql-and jc) - jc)))))) - -(defmethod postinitialize ((self t)) - ) - -(defun find-all (view-classes &rest args &key all set-operation distinct from - where group-by having order-by order-by-descending offset limit - (database *default-database*)) - "tweeze me apart someone pleeze" - (declare (ignore all set-operation group-by having - offset limit) - (optimize (debug 3) (speed 1))) - ;; (cmsg "Args = ~s" args) - (remf args :from) - (let* ((*db-deserializing* t) - (*default-database* (or database - (error 'clsql-no-database-error nil)))) - (flet ((table-sql-expr (table) - (sql-expression :table (view-table table))) - (ref-equal (ref1 ref2) - (equal (sql ref1) - (sql ref2))) - (tables-equal (table-a table-b) - (string= (string (slot-value table-a 'name)) - (string (slot-value table-b 'name))))) - - (let* ((sclasses (mapcar #'find-class view-classes)) - (sels (mapcar #'generate-selection-list sclasses)) - (fullsels (apply #'append sels)) - (sel-tables (collect-table-refs where)) - (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables) - :test #'tables-equal)) - (res nil)) - (dolist (ob (listify order-by)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (dolist (ob (listify order-by-descending)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (dolist (ob (listify distinct)) - (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - ;; (cmsg "Tables = ~s" tables) - ;; (cmsg "From = ~s" from) - (setq res (apply #'select (append (mapcar #'cdr fullsels) - (cons :from (list (append (when from (listify from)) (listify tables)))) args))) - (flet ((build-object (vals) - (flet ((%build-object (vclass selects) - (let ((class-name (class-name vclass)) - (db-vals (butlast vals (- (list-length vals) - (list-length selects))))) - ;; (setf vals (nthcdr (list-length selects) vals)) - (%make-fresh-object class-name (mapcar #'car selects) db-vals)))) - (let ((objects (mapcar #'%build-object sclasses sels))) - (if (= (length sclasses) 1) - (car objects) - objects))))) - (mapcar #'build-object res)))))) - -(defun %make-fresh-object (class-name slots values) - (let* ((*db-initializing* t) - (obj (make-instance class-name - :stored t))) - (setf obj (get-slot-values-from-view obj slots values)) - (postinitialize obj) - obj)) - -(defun select (&rest select-all-args) - "Selects data from database given the constraints specified. Returns -a list of lists of record values as specified by select-all-args. By -default, the records are each represented as lists of attribute -values. The selections argument may be either db-identifiers, literal -strings or view classes. If the argument consists solely of view -classes, the return value will be instances of objects rather than raw -tuples." - (flet ((select-objects (target-args) - (and target-args - (every #'(lambda (arg) - (and (symbolp arg) - (find-class arg nil))) - 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))) - (destructuring-bind (&key (flatp nil) - (database *default-database*) - &allow-other-keys) - qualifier-args - (let ((res (query expr :database database))) - (if (and flatp - (= (length (slot-value expr 'selections)) 1)) - (mapcar #'car res) - res)))))))) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index d6cd8fe..39d7eea 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -289,7 +289,7 @@ (deftest :oodml/iteration/3 (loop for (e) being the records in - [select 'employee :where [married] :order-by [emplid]] + [select 'employee :where [< [emplid] 4] :order-by [emplid]] collect (slot-value e 'last-name)) ("Lenin" "Stalin" "Trotsky"))