sql/objects.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
   7 ;;;; and Object Oriented Data Manipulation Language (OODML).
   8 ;;;;
   9 ;;;; This file is part of CLSQL.
  10 ;;;;
  11 ;;;; CLSQL users are granted the rights to distribute and use this software
  12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  14 ;;;; *************************************************************************
  15
  16 (in-package #:clsql-sys)
  17
  18 (defclass standard-db-object ()
  19   ((view-database :initform nil :initarg :view-database :reader view-database
  20     :db-kind :virtual))
  21   (:metaclass standard-db-class)
  22   (:documentation "Superclass for all CLSQL View Classes."))
  23
  24 (defvar *db-auto-sync* nil
  25   "A non-nil value means that creating View Class instances or
  26   setting their slots automatically creates/updates the
  27   corresponding records in the underlying database.")
  28
  29 (defvar *db-deserializing* nil)
  30 (defvar *db-initializing* nil)
  31
  32 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
  33   (declare (optimize (speed 3)))
  34   (unless *db-deserializing*
  35     (let* ((slot-name (%svuc-slot-name slot-def))
  36            (slot-object (%svuc-slot-object slot-def class))
  37            (slot-kind (view-class-slot-db-kind slot-object)))
  38       (when (and (eql slot-kind :join)
  39                  (not (slot-boundp instance slot-name)))
  40         (let ((*db-deserializing* t))
  41           (if (view-database instance)
  42               (setf (slot-value instance slot-name)
  43                     (fault-join-slot class instance slot-object))
  44               (setf (slot-value instance slot-name) nil))))))
  45   (call-next-method))
  46
  47 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
  48                                           instance slot-def)
  49   (declare (ignore new-value))
  50   (let* ((slot-name (%svuc-slot-name slot-def))
  51          (slot-object (%svuc-slot-object slot-def class))
  52          (slot-kind (view-class-slot-db-kind slot-object)))
  53     (call-next-method)
  54     (when (and *db-auto-sync*
  55                (not *db-initializing*)
  56                (not *db-deserializing*)
  57                (not (eql slot-kind :virtual)))
  58       (update-record-from-slot instance slot-name))))
  59
  60 (defmethod initialize-instance ((object standard-db-object)
  61                                         &rest all-keys &key &allow-other-keys)
  62   (declare (ignore all-keys))
  63   (let ((*db-initializing* t))
  64     (call-next-method)
  65     (when (and *db-auto-sync*
  66                (not *db-deserializing*))
  67       (update-records-from-instance object))))
  68
  69 ;;
  70 ;; Build the database tables required to store the given view class
  71 ;;
  72
  73 (defun create-view-from-class (view-class-name
  74                                &key (database *default-database*))
  75   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
  76 the view. The argument DATABASE has a default value of
  77 *DEFAULT-DATABASE*."
  78   (let ((tclass (find-class view-class-name)))
  79     (if tclass
  80         (let ((*default-database* database))
  81           (%install-class tclass database))
  82         (error "Class ~s not found." view-class-name)))
  83   (values))
  84
  85 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
  86   (dolist (slotdef (ordered-class-slots self))
  87     (let ((res (database-generate-column-definition (class-name self)
  88                                                     slotdef database)))
  89       (when res
  90         (push res schemadef))))
  91   (unless schemadef
  92     (error "Class ~s has no :base slots" self))
  93   (create-table (sql-expression :table (view-table self)) schemadef
  94                 :database database
  95                 :constraints (database-pkey-constraint self database))
  96   (push self (database-view-classes database))
  97   t)
  98
  99 (defmethod database-pkey-constraint ((class standard-db-class) database)
 100   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
 101     (when keylist
 102       (convert-to-db-default-case
 103        (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
 104                (database-output-sql (view-table class) database)
 105                (database-output-sql keylist database))
 106        database))))
 107
 108 (defmethod database-generate-column-definition (class slotdef database)
 109   (declare (ignore database class))
 110   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
 111     (let ((cdef
 112            (list (sql-expression :attribute (view-class-slot-column slotdef))
 113                  (specified-type slotdef))))
 114       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
 115       (let ((const (view-class-slot-db-constraints slotdef)))
 116         (when const
 117           (setq cdef (append cdef (list const)))))
 118       cdef)))
 119
 120
 121 ;;
 122 ;; Drop the tables which store the given view class
 123 ;;
 124
 125 (defun drop-view-from-class (view-class-name &key (database *default-database*))
 126   "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
 127 which defines that view. The argument DATABASE has a default value of
 128 *DEFAULT-DATABASE*."
 129   (let ((tclass (find-class view-class-name)))
 130     (if tclass
 131         (let ((*default-database* database))
 132           (%uninstall-class tclass))
 133         (error "Class ~s not found." view-class-name)))
 134   (values))
 135
 136 (defun %uninstall-class (self &key (database *default-database*))
 137   (drop-table (sql-expression :table (view-table self))
 138               :if-does-not-exist :ignore
 139               :database database)
 140   (setf (database-view-classes database)
 141         (remove self (database-view-classes database))))
 142
 143
 144 ;;
 145 ;; List all known view classes
 146 ;;
 147
 148 (defun list-classes (&key (test #'identity)
 149                      (root-class (find-class 'standard-db-object))
 150                      (database *default-database*))
 151   "The LIST-CLASSES function collects all the classes below
 152 ROOT-CLASS, which defaults to standard-db-object, that are connected
 153 to the supplied DATABASE and which satisfy the TEST function. The
 154 default for the TEST argument is identity. By default, LIST-CLASSES
 155 returns a list of all the classes connected to the default database,
 156 *DEFAULT-DATABASE*."
 157   (flet ((find-superclass (class)
 158            (member root-class (class-precedence-list class))))
 159     (let ((view-classes (and database (database-view-classes database))))
 160       (when view-classes
 161         (remove-if #'(lambda (c) (or (not (funcall test c))
 162                                      (not (find-superclass c))))
 163                    view-classes)))))
 164
 165 ;;
 166 ;; Define a new view class
 167 ;;
 168
 169 (defmacro def-view-class (class supers slots &rest cl-options)
 170   "Extends the syntax of defclass to allow special slots to be mapped
 171 onto the attributes of database views. The macro DEF-VIEW-CLASS
 172 creates a class called CLASS which maps onto a database view. Such a
 173 class is called a View Class. The macro DEF-VIEW-CLASS extends the
 174 syntax of DEFCLASS to allow special base slots to be mapped onto the
 175 attributes of database views (presently single tables). When a select
 176 query that names a View Class is submitted, then the corresponding
 177 database view is queried, and the slots in the resulting View Class
 178 instances are filled with attribute values from the database. If
 179 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
 180 superclass of the newly-defined View Class."
 181   `(progn
 182     (defclass ,class ,supers ,slots
 183       ,@(if (find :metaclass `,cl-options :key #'car)
 184             `,cl-options
 185             (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
 186     (finalize-inheritance (find-class ',class))
 187     (find-class ',class)))
 188
 189 (defun keyslots-for-class (class)
 190   (slot-value class 'key-slots))
 191
 192 (defun key-qualifier-for-instance (obj &key (database *default-database*))
 193   (let ((tb (view-table (class-of obj))))
 194     (flet ((qfk (k)
 195              (sql-operation '==
 196                             (sql-expression :attribute
 197                                             (view-class-slot-column k)
 198                                             :table tb)
 199                             (db-value-from-slot
 200                              k
 201                              (slot-value obj (slot-definition-name k))
 202                              database))))
 203       (let* ((keys (keyslots-for-class (class-of obj)))
 204              (keyxprs (mapcar #'qfk (reverse keys))))
 205         (cond
 206           ((= (length keyxprs) 0) nil)
 207           ((= (length keyxprs) 1) (car keyxprs))
 208           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
 209
 210 ;;
 211 ;; Function used by 'generate-selection-list'
 212 ;;
 213
 214 (defun generate-attribute-reference (vclass slotdef)
 215   (cond
 216    ((eq (view-class-slot-db-kind slotdef) :base)
 217     (sql-expression :attribute (view-class-slot-column slotdef)
 218                     :table (view-table vclass)))
 219    ((eq (view-class-slot-db-kind slotdef) :key)
 220     (sql-expression :attribute (view-class-slot-column slotdef)
 221                     :table (view-table vclass)))
 222    (t nil)))
 223
 224 ;;
 225 ;; Function used by 'find-all'
 226 ;;
 227
 228 (defun generate-selection-list (vclass)
 229   (let ((sels nil))
 230     (dolist (slotdef (ordered-class-slots vclass))
 231       (let ((res (generate-attribute-reference vclass slotdef)))
 232         (when res
 233           (push (cons slotdef res) sels))))
 234     (if sels
 235         sels
 236         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 237
 238
 239
 240 (defun generate-retrieval-joins-list (vclass retrieval-method)
 241   "Returns list of immediate join slots for a class."
 242   (let ((join-slotdefs nil))
 243     (dolist (slotdef (ordered-class-slots vclass) join-slotdefs)
 244       (when (and (eq :join (view-class-slot-db-kind slotdef))
 245                  (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
 246         (push slotdef join-slotdefs)))))
 247
 248 (defun generate-immediate-joins-selection-list (vclass)
 249   "Returns list of immediate join slots for a class."
 250   (let (sels)
 251     (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels)
 252       (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot)))
 253              (join-class (when join-class-name (find-class join-class-name))))
 254         (dolist (slotdef (ordered-class-slots join-class))
 255           (let ((res (generate-attribute-reference join-class slotdef)))
 256             (when res
 257               (push (cons slotdef res) sels))))))
 258     sels))
 259
 260
 261 ;; Called by 'get-slot-values-from-view'
 262 ;;
 263
 264 (defvar *update-context* nil)
 265
 266 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
 267   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 268   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 269          (slot-name   (slot-definition-name slotdef))
 270          (slot-type   (specified-type slotdef))
 271          (*update-context* (cons (type-of instance) slot-name)))
 272     (cond ((and value (null slot-reader))
 273            (setf (slot-value instance slot-name)
 274                  (read-sql-value value (delistify slot-type)
 275                                  (view-database instance))))
 276           ((null value)
 277            (update-slot-with-null instance slot-name slotdef))
 278           ((typep slot-reader 'string)
 279            (setf (slot-value instance slot-name)
 280                  (format nil slot-reader value)))
 281           ((typep slot-reader 'function)
 282            (setf (slot-value instance slot-name)
 283                  (apply slot-reader (list value))))
 284           (t
 285            (error "Slot reader is of an unusual type.")))))
 286
 287 (defmethod key-value-from-db (slotdef value database)
 288   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 289   (let ((slot-reader (view-class-slot-db-reader slotdef))
 290         (slot-type (specified-type slotdef)))
 291     (cond ((and value (null slot-reader))
 292            (read-sql-value value (delistify slot-type) database))
 293           ((null value)
 294            nil)
 295           ((typep slot-reader 'string)
 296            (format nil slot-reader value))
 297           ((typep slot-reader 'function)
 298            (apply slot-reader (list value)))
 299           (t
 300            (error "Slot reader is of an unusual type.")))))
 301
 302 (defun db-value-from-slot (slotdef val database)
 303   (let ((dbwriter (view-class-slot-db-writer slotdef))
 304         (dbtype (specified-type slotdef)))
 305     (typecase dbwriter
 306       (string (format nil dbwriter val))
 307       (function (apply dbwriter (list val)))
 308       (t
 309        (typecase dbtype
 310          (cons
 311           (database-output-sql-as-type (car dbtype) val database))
 312          (t
 313           (database-output-sql-as-type dbtype val database)))))))
 314
 315 (defun check-slot-type (slotdef val)
 316   (let* ((slot-type (specified-type slotdef))
 317          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 318     (when (and slot-type val)
 319       (unless (typep val basetype)
 320         (error 'sql-user-error
 321                :message
 322                (format nil "Invalid value ~A in slot ~A, not of type ~A."
 323                        val (slot-definition-name slotdef) slot-type))))))
 324
 325 ;;
 326 ;; Called by find-all
 327 ;;
 328
 329 (defmethod get-slot-values-from-view (obj slotdeflist values)
 330     (flet ((update-slot (slot-def values)
 331              (update-slot-from-db obj slot-def values)))
 332       (mapc #'update-slot slotdeflist values)
 333       obj))
 334
 335 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 336                                     (database *default-database*))
 337   (let* ((database (or (view-database obj) database))
 338          (vct (view-table (class-of obj)))
 339          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 340     (check-slot-type sd (slot-value obj slot))
 341     (let* ((att (view-class-slot-column sd))
 342            (val (db-value-from-slot sd (slot-value obj slot) database)))
 343       (cond ((and vct sd (view-database obj))
 344              (update-records (sql-expression :table vct)
 345                              :attributes (list (sql-expression :attribute att))
 346                              :values (list val)
 347                              :where (key-qualifier-for-instance
 348                                      obj :database database)
 349                              :database database))
 350             ((and vct sd (not (view-database obj)))
 351              (insert-records :into (sql-expression :table vct)
 352                              :attributes (list (sql-expression :attribute att))
 353                              :values (list val)
 354                              :database database)
 355              (setf (slot-value obj 'view-database) database))
 356             (t
 357              (error "Unable to update record.")))))
 358   (values))
 359
 360 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 361                                      (database *default-database*))
 362   (let* ((database (or (view-database obj) database))
 363          (vct (view-table (class-of obj)))
 364          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 365          (avps (mapcar #'(lambda (s)
 366                            (let ((val (slot-value
 367                                        obj (slot-definition-name s))))
 368                              (check-slot-type s val)
 369                              (list (sql-expression
 370                                     :attribute (view-class-slot-column s))
 371                                    (db-value-from-slot s val database))))
 372                        sds)))
 373     (cond ((and avps (view-database obj))
 374            (update-records (sql-expression :table vct)
 375                            :av-pairs avps
 376                            :where (key-qualifier-for-instance
 377                                    obj :database database)
 378                            :database database))
 379           ((and avps (not (view-database obj)))
 380            (insert-records :into (sql-expression :table vct)
 381                            :av-pairs avps
 382                            :database database)
 383            (setf (slot-value obj 'view-database) database))
 384           (t
 385            (error "Unable to update records"))))
 386   (values))
 387
 388 (defmethod update-records-from-instance ((obj standard-db-object)
 389                                          &key (database *default-database*))
 390   (let ((database (or (view-database obj) database)))
 391     (labels ((slot-storedp (slot)
 392                (and (member (view-class-slot-db-kind slot) '(:base :key))
 393                     (slot-boundp obj (slot-definition-name slot))))
 394              (slot-value-list (slot)
 395                (let ((value (slot-value obj (slot-definition-name slot))))
 396                  (check-slot-type slot value)
 397                  (list (sql-expression :attribute (view-class-slot-column slot))
 398                        (db-value-from-slot slot value database)))))
 399       (let* ((view-class (class-of obj))
 400              (view-class-table (view-table view-class))
 401              (slots (remove-if-not #'slot-storedp
 402                                    (ordered-class-slots view-class)))
 403              (record-values (mapcar #'slot-value-list slots)))
 404         (unless record-values
 405           (error "No settable slots."))
 406         (if (view-database obj)
 407             (update-records (sql-expression :table view-class-table)
 408                             :av-pairs record-values
 409                             :where (key-qualifier-for-instance
 410                                     obj :database database)
 411                             :database database)
 412             (progn
 413               (insert-records :into (sql-expression :table view-class-table)
 414                               :av-pairs record-values
 415                               :database database)
 416               (setf (slot-value obj 'view-database) database))))))
 417   (values))
 418
 419 (defmethod delete-instance-records ((instance standard-db-object))
 420   (let ((vt (sql-expression :table (view-table (class-of instance))))
 421         (vd (view-database instance)))
 422     (if vd
 423         (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 424           (delete-records :from vt :where qualifier :database vd)
 425           (setf (slot-value instance 'view-database) nil))
 426         (signal-no-database-error vd))))
 427
 428 (defmethod update-instance-from-records ((instance standard-db-object)
 429                                          &key (database *default-database*))
 430   (let* ((view-class (find-class (class-name (class-of instance))))
 431          (view-table (sql-expression :table (view-table view-class)))
 432          (vd (or (view-database instance) database))
 433          (view-qual (key-qualifier-for-instance instance :database vd))
 434          (sels (generate-selection-list view-class))
 435          (res (apply #'select (append (mapcar #'cdr sels)
 436                                       (list :from  view-table
 437                                             :where view-qual)
 438                                       (list :result-types nil)))))
 439     (when res
 440       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 441
 442 (defmethod update-slot-from-record ((instance standard-db-object)
 443                                     slot &key (database *default-database*))
 444   (let* ((view-class (find-class (class-name (class-of instance))))
 445          (view-table (sql-expression :table (view-table view-class)))
 446          (vd (or (view-database instance) database))
 447          (view-qual (key-qualifier-for-instance instance :database vd))
 448          (slot-def (slotdef-for-slot-with-class slot view-class))
 449          (att-ref (generate-attribute-reference view-class slot-def))
 450          (res (select att-ref :from  view-table :where view-qual
 451                       :result-types nil)))
 452     (when res
 453       (get-slot-values-from-view instance (list slot-def) (car res)))))
 454
 455
 456 (defmethod update-slot-with-null ((object standard-db-object)
 457                                   slotname
 458                                   slotdef)
 459   (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 460
 461 (defvar +no-slot-value+ '+no-slot-value+)
 462
 463 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 464   (let* ((class (find-class classname))
 465          (sld (slotdef-for-slot-with-class slot class)))
 466     (if sld
 467         (if (eq value +no-slot-value+)
 468             (sql-expression :attribute (view-class-slot-column sld)
 469                             :table (view-table class))
 470             (db-value-from-slot
 471              sld
 472              value
 473              database))
 474         (error "Unknown slot ~A for class ~A" slot classname))))
 475
 476 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 477         (declare (ignore database))
 478         (let* ((class (find-class classname)))
 479           (unless (view-table class)
 480             (error "No view-table for class ~A"  classname))
 481           (sql-expression :table (view-table class))))
 482
 483 (defmethod database-get-type-specifier (type args database)
 484   (declare (ignore type args))
 485   (if (in (database-underlying-type database)
 486                           :postgresql :postgresql-socket)
 487           "VARCHAR"
 488           "VARCHAR(255)"))
 489
 490 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 491   (declare (ignore database))
 492   ;;"INT8")
 493   (if args
 494       (format nil "INT(~A)" (car args))
 495       "INT"))
 496
 497 (deftype bigint ()
 498   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
 499   'integer)
 500
 501 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
 502   (declare (ignore args database))
 503   "BIGINT")
 504
 505 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 506                                         database)
 507   (if args
 508       (format nil "VARCHAR(~A)" (car args))
 509     (if (in (database-underlying-type database)
 510                             :postgresql :postgresql-socket)
 511         "VARCHAR"
 512       "VARCHAR(255)")))
 513
 514 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 515                                         database)
 516   (if args
 517       (format nil "VARCHAR(~A)" (car args))
 518     (if (in (database-underlying-type database)
 519                             :postgresql :postgresql-socket)
 520         "VARCHAR"
 521       "VARCHAR(255)")))
 522
 523 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 524   (if args
 525       (format nil "VARCHAR(~A)" (car args))
 526     (if (in (database-underlying-type database)
 527                             :postgresql :postgresql-socket)
 528         "VARCHAR"
 529       "VARCHAR(255)")))
 530
 531 (deftype universal-time ()
 532   "A positive integer as returned by GET-UNIVERSAL-TIME."
 533   '(integer 1 *))
 534
 535 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
 536   (declare (ignore args database))
 537   "BIGINT")
 538
 539 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 540   (declare (ignore args))
 541   (case (database-underlying-type database)
 542     ((:postgresql :postgresql-socket)
 543      "TIMESTAMP WITHOUT TIME ZONE")
 544     (:mysql
 545      "DATETIME")
 546     (t "TIMESTAMP")))
 547
 548 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 549   (declare (ignore database args))
 550   "VARCHAR")
 551
 552 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
 553   (declare (ignore database args))
 554   "INT8")
 555
 556 (deftype raw-string (&optional len)
 557   "A string which is not trimmed when retrieved from the database"
 558   `(string ,len))
 559
 560 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 561   (declare (ignore database))
 562   (if args
 563       (format nil "VARCHAR(~A)" (car args))
 564       "VARCHAR"))
 565
 566 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 567   (declare (ignore database))
 568   (if args
 569       (format nil "FLOAT(~A)" (car args))
 570       "FLOAT"))
 571
 572 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 573   (declare (ignore database))
 574   (if args
 575       (format nil "FLOAT(~A)" (car args))
 576       "FLOAT"))
 577
 578 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
 579   (declare (ignore args database))
 580   "BOOL")
 581
 582 (defmethod database-output-sql-as-type (type val database)
 583   (declare (ignore type database))
 584   val)
 585
 586 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 587   (declare (ignore database))
 588   (progv '(*print-circle* *print-array*) '(t t)
 589     (let ((escaped (prin1-to-string val)))
 590       (substitute-char-string
 591        escaped #\Null " "))))
 592
 593 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 594   (declare (ignore database))
 595   (if (keywordp val)
 596       (symbol-name val)
 597       (if val
 598           (concatenate 'string
 599                        (package-name (symbol-package val))
 600                        "::"
 601                        (symbol-name val))
 602           "")))
 603
 604 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 605   (declare (ignore database))
 606   (if val
 607       (symbol-name val)
 608       ""))
 609
 610 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
 611   (declare (ignore database))
 612   (progv '(*print-circle* *print-array*) '(t t)
 613     (prin1-to-string val)))
 614
 615 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
 616   (declare (ignore database))
 617   (progv '(*print-circle* *print-array*) '(t t)
 618     (prin1-to-string val)))
 619
 620 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
 621   (case (database-underlying-type database)
 622     (:mysql
 623      (if val 1 0))
 624     (t
 625      (if val "t" "f"))))
 626
 627 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 628   (declare (ignore database))
 629   val)
 630
 631 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 632                                         val database)
 633   (declare (ignore database))
 634   val)
 635
 636 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 637                                         val database)
 638   (declare (ignore database))
 639   val)
 640
 641 (defmethod read-sql-value (val type database)
 642   (declare (ignore type database))
 643   (read-from-string val))
 644
 645 (defmethod read-sql-value (val (type (eql 'string)) database)
 646   (declare (ignore database))
 647   val)
 648
 649 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 650   (declare (ignore database))
 651   val)
 652
 653 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 654   (declare (ignore database))
 655   val)
 656
 657 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 658   (declare (ignore database))
 659   val)
 660
 661 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 662   (declare (ignore database))
 663   (when (< 0 (length val))
 664     (intern (symbol-name-default-case val)
 665             (find-package '#:keyword))))
 666
 667 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 668   (declare (ignore database))
 669   (when (< 0 (length val))
 670     (unless (string= val (symbol-name-default-case "NIL"))
 671       (intern (symbol-name-default-case val)
 672               (symbol-package *update-context*)))))
 673
 674 (defmethod read-sql-value (val (type (eql 'integer)) database)
 675   (declare (ignore database))
 676   (etypecase val
 677     (string
 678      (unless (string-equal "NIL" val)
 679        (parse-integer val)))
 680     (number val)))
 681
 682 (defmethod read-sql-value (val (type (eql 'bigint)) database)
 683   (declare (ignore database))
 684   (etypecase val
 685     (string
 686      (unless (string-equal "NIL" val)
 687        (parse-integer val)))
 688     (number val)))
 689
 690 (defmethod read-sql-value (val (type (eql 'float)) database)
 691   (declare (ignore database))
 692   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 693   (etypecase val
 694     (string
 695      (float (read-from-string val)))
 696     (float
 697      val)))
 698
 699 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 700   (case (database-underlying-type database)
 701     (:mysql
 702      (etypecase val
 703        (string (if (string= "0" val) nil t))
 704        (integer (if (zerop val) nil t))))
 705     (:postgresql
 706      (if (eq :odbc (database-type database))
 707          (if (string= "0" val) nil t)
 708        (equal "t" val)))
 709     (t
 710      (equal "t" val))))
 711
 712 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
 713   (declare (ignore database))
 714   (unless (eq 'NULL val)
 715     (etypecase val
 716       (string
 717        (parse-integer val))
 718       (number val))))
 719
 720 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 721   (declare (ignore database))
 722   (unless (eq 'NULL val)
 723     (parse-timestring val)))
 724
 725 (defmethod read-sql-value (val (type (eql 'duration)) database)
 726   (declare (ignore database))
 727   (unless (or (eq 'NULL val)
 728               (equal "NIL" val))
 729     (parse-timestring val)))
 730
 731 ;; ------------------------------------------------------------
 732 ;; Logic for 'faulting in' :join slots
 733
 734 ;; this works, but is inefficient requiring (+ 1 n-rows)
 735 ;; SQL queries
 736 #+ignore
 737 (defun fault-join-target-slot (class object slot-def)
 738   (let* ((res (fault-join-slot-raw class object slot-def))
 739          (dbi (view-class-slot-db-info slot-def))
 740          (target-name (gethash :target-slot dbi))
 741          (target-class (find-class target-name)))
 742     (when res
 743       (mapcar (lambda (obj)
 744                 (list
 745                  (car
 746                   (fault-join-slot-raw
 747                    target-class
 748                    obj
 749                    (find target-name (class-slots (class-of obj))
 750                          :key #'slot-definition-name)))
 751                  obj))
 752               res)
 753       #+ignore ;; this doesn't work when attempting to call slot-value
 754       (mapcar (lambda (obj)
 755                 (cons obj (slot-value obj ts))) res))))
 756
 757 (defun fault-join-target-slot (class object slot-def)
 758   (let* ((dbi (view-class-slot-db-info slot-def))
 759          (ts (gethash :target-slot dbi))
 760          (jc (gethash :join-class dbi))
 761          (ts-view-table (view-table (find-class ts)))
 762          (jc-view-table (view-table (find-class jc)))
 763          (tdbi (view-class-slot-db-info
 764                 (find ts (class-slots (find-class jc))
 765                       :key #'slot-definition-name)))
 766          (retrieval (gethash :retrieval tdbi))
 767          (jq (join-qualifier class object slot-def))
 768          (key (slot-value object (gethash :home-key dbi))))
 769     (when jq
 770       (ecase retrieval
 771         (:immediate
 772          (let ((res
 773                 (find-all (list ts)
 774                           :inner-join (sql-expression :table jc-view-table)
 775                           :on (sql-operation
 776                                '==
 777                                (sql-expression
 778                                 :attribute (gethash :foreign-key tdbi)
 779                                 :table ts-view-table)
 780                                (sql-expression
 781                                 :attribute (gethash :home-key tdbi)
 782                                 :table jc-view-table))
 783                           :where jq
 784                           :result-types :auto)))
 785            (mapcar #'(lambda (i)
 786                        (let* ((instance (car i))
 787                               (jcc (make-instance jc :view-database (view-database instance))))
 788                          (setf (slot-value jcc (gethash :foreign-key dbi))
 789                                key)
 790                          (setf (slot-value jcc (gethash :home-key tdbi))
 791                                (slot-value instance (gethash :foreign-key tdbi)))
 792                       (list instance jcc)))
 793                    res)))
 794         (:deferred
 795             ;; just fill in minimal slots
 796             (mapcar
 797              #'(lambda (k)
 798                  (let ((instance (make-instance ts :view-database (view-database object)))
 799                        (jcc (make-instance jc :view-database (view-database object)))
 800                        (fk (car k)))
 801                    (setf (slot-value instance (gethash :home-key tdbi)) fk)
 802                    (setf (slot-value jcc (gethash :foreign-key dbi))
 803                          key)
 804                    (setf (slot-value jcc (gethash :home-key tdbi))
 805                          fk)
 806                    (list instance jcc)))
 807              (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
 808                      :from (sql-expression :table jc-view-table)
 809                      :where jq)))))))
 810
 811 (defun update-object-joins (objects &key (slots t) (force-p t)
 812                             class-name (max-len *default-update-objects-max-len*))
 813   "Updates the remote join slots, that is those slots defined without
 814 :retrieval :immediate."
 815   (assert (or (null max-len) (plusp max-len)))
 816   (when objects
 817     (unless class-name
 818       (setq class-name (class-name (class-of (first objects)))))
 819     (let* ((class (find-class class-name))
 820            (class-slots (ordered-class-slots class))
 821            (slotdefs
 822             (if (eq t slots)
 823                 (generate-retrieval-joins-list class :deferred)
 824               (remove-if #'null
 825                          (mapcar #'(lambda (name)
 826                                      (let ((slotdef (find name class-slots :key #'slot-definition-name)))
 827                                        (unless slotdef
 828                                          (warn "Unable to find slot named ~S in class ~S." name class))
 829                                        slotdef))
 830                                  slots)))))
 831       (dolist (slotdef slotdefs)
 832         (let* ((dbi (view-class-slot-db-info slotdef))
 833                (slotdef-name (slot-definition-name slotdef))
 834                (foreign-key (gethash :foreign-key dbi))
 835                (home-key (gethash :home-key dbi))
 836                (object-keys
 837                 (remove-duplicates
 838                  (if force-p
 839                      (mapcar #'(lambda (o) (slot-value o home-key)) objects)
 840                    (remove-if #'null
 841                               (mapcar
 842                                #'(lambda (o) (if (slot-boundp o slotdef-name)
 843                                                  nil
 844                                                (slot-value o home-key)))
 845                                objects)))))
 846                (n-object-keys (length object-keys))
 847                (query-len (or max-len n-object-keys)))
 848
 849           (do ((i 0 (+ i query-len)))
 850               ((>= i n-object-keys))
 851             (let* ((keys (if max-len
 852                              (subseq object-keys i (min (+ i query-len) n-object-keys))
 853                            object-keys))
 854                    (results (find-all (list (gethash :join-class dbi))
 855                                       :where (make-instance 'sql-relational-exp
 856                                                :operator 'in
 857                                                :sub-expressions (list (sql-expression :attribute foreign-key)
 858                                                                       keys))
 859                                       :result-types :auto
 860                                       :flatp t)))
 861               (dolist (object objects)
 862                 (when (or force-p (not (slot-boundp object slotdef-name)))
 863                   (let ((res (find (slot-value object home-key) results
 864                                    :key #'(lambda (res) (slot-value res foreign-key))
 865                                    :test #'equal)))
 866                     (when res
 867                       (setf (slot-value object slotdef-name) res)))))))))))
 868   (values))
 869
 870 (defun fault-join-slot-raw (class object slot-def)
 871   (let* ((dbi (view-class-slot-db-info slot-def))
 872          (jc (gethash :join-class dbi)))
 873     (let ((jq (join-qualifier class object slot-def)))
 874       (when jq
 875         (select jc :where jq :flatp t :result-types nil)))))
 876
 877 (defun fault-join-slot (class object slot-def)
 878   (let* ((dbi (view-class-slot-db-info slot-def))
 879          (ts (gethash :target-slot dbi)))
 880     (if (and ts (gethash :set dbi))
 881         (fault-join-target-slot class object slot-def)
 882         (let ((res (fault-join-slot-raw class object slot-def)))
 883           (when res
 884             (cond
 885               ((and ts (not (gethash :set dbi)))
 886                (mapcar (lambda (obj) (slot-value obj ts)) res))
 887               ((and (not ts) (not (gethash :set dbi)))
 888                (car res))
 889               ((and (not ts) (gethash :set dbi))
 890                res)))))))
 891
 892 (defun join-qualifier (class object slot-def)
 893     (declare (ignore class))
 894     (let* ((dbi (view-class-slot-db-info slot-def))
 895            (jc (find-class (gethash :join-class dbi)))
 896            ;;(ts (gethash :target-slot dbi))
 897            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 898            (foreign-keys (gethash :foreign-key dbi))
 899            (home-keys (gethash :home-key dbi)))
 900       (when (every #'(lambda (slt)
 901                        (and (slot-boundp object slt)
 902                             (not (null (slot-value object slt)))))
 903                    (if (listp home-keys) home-keys (list home-keys)))
 904         (let ((jc
 905                (mapcar #'(lambda (hk fk)
 906                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 907                              (sql-operation '==
 908                                             (typecase fk
 909                                               (symbol
 910                                                (sql-expression
 911                                                 :attribute
 912                                                 (view-class-slot-column fksd)
 913                                                 :table (view-table jc)))
 914                                               (t fk))
 915                                             (typecase hk
 916                                               (symbol
 917                                                (slot-value object hk))
 918                                               (t
 919                                                hk)))))
 920                        (if (listp home-keys)
 921                            home-keys
 922                            (list home-keys))
 923                        (if (listp foreign-keys)
 924                            foreign-keys
 925                            (list foreign-keys)))))
 926           (when jc
 927             (if (> (length jc) 1)
 928                 (apply #'sql-and jc)
 929                 jc))))))
 930
 931 ;; FIXME: add retrieval immediate for efficiency
 932 ;; For example, for (select 'employee-address) in test suite =>
 933 ;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
 934
 935 (defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances)
 936   "Used by find-all to build objects."
 937   (labels ((build-object (vals vclass jclasses selects immediate-selects instance)
 938              (let* ((db-vals (butlast vals (- (list-length vals)
 939                                               (list-length selects))))
 940                     (obj (if instance instance (make-instance (class-name vclass) :view-database database)))
 941                     (join-vals (subseq vals (list-length selects)))
 942                     (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
 943                                    jclasses)))
 944                ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals)
 945                ;; use refresh keyword here
 946                (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals))
 947                (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals))
 948                      joins)
 949                (mapc
 950                 #'(lambda (jc)
 951                     (let ((slot (find (class-name (class-of jc)) (class-slots vclass)
 952                                       :key #'(lambda (slot)
 953                                                (when (and (eq :join (view-class-slot-db-kind slot))
 954                                                           (eq (slot-definition-name slot)
 955                                                               (gethash :join-class (view-class-slot-db-info slot))))
 956                                                  (slot-definition-name slot))))))
 957                       (when slot
 958                         (setf (slot-value obj (slot-definition-name slot)) jc))))
 959                 joins)
 960                (when refresh (instance-refreshed obj))
 961                obj)))
 962     (let* ((objects
 963             (mapcar #'(lambda (sclass jclass sel immediate-join instance)
 964                         (prog1
 965                             (build-object vals sclass jclass sel immediate-join instance)
 966                           (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
 967                                              vals))))
 968                     sclasses immediate-join-classes sels immediate-joins instances)))
 969       (if (and flatp (= (length sclasses) 1))
 970           (car objects)
 971         objects))))
 972
 973 (defun find-all (view-classes
 974                  &rest args
 975                  &key all set-operation distinct from where group-by having
 976                       order-by offset limit refresh flatp result-types
 977                       inner-join on
 978                       (database *default-database*)
 979                       instances)
 980   "Called by SELECT to generate object query results when the
 981   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 982   (declare (ignore all set-operation group-by having offset limit inner-join on)
 983            (optimize (debug 3) (speed 1)))
 984   (labels ((ref-equal (ref1 ref2)
 985              (equal (sql ref1)
 986                     (sql ref2)))
 987            (table-sql-expr (table)
 988              (sql-expression :table (view-table table)))
 989            (tables-equal (table-a table-b)
 990              (when (and table-a table-b)
 991                (string= (string (slot-value table-a 'name))
 992                         (string (slot-value table-b 'name))))))
 993     (remf args :from)
 994     (remf args :where)
 995     (remf args :flatp)
 996     (remf args :additional-fields)
 997     (remf args :result-types)
 998     (remf args :instances)
 999     (let* ((*db-deserializing* t)
1000            (sclasses (mapcar #'find-class view-classes))
1001            (immediate-join-slots
1002             (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
1003            (immediate-join-classes
1004             (mapcar #'(lambda (jcs)
1005                         (mapcar #'(lambda (slotdef)
1006                                     (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
1007                                 jcs))
1008                     immediate-join-slots))
1009            (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
1010            (sels (mapcar #'generate-selection-list sclasses))
1011            (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
1012            (sel-tables (collect-table-refs where))
1013            (tables (remove-if #'null
1014                               (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
1015                                                          (mapcar #'(lambda (jcs)
1016                                                                      (mapcan #'(lambda (jc)
1017                                                                                  (when jc (table-sql-expr jc)))
1018                                                                              jcs))
1019                                                                  immediate-join-classes)
1020                                                          sel-tables)
1021                                                  :test #'tables-equal)))
1022            (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
1023                                    (listify order-by))))
1024
1025       (dolist (ob order-by-slots)
1026         (when (and ob (not (member ob (mapcar #'cdr fullsels)
1027                                    :test #'ref-equal)))
1028           (setq fullsels
1029             (append fullsels (mapcar #'(lambda (att) (cons nil att))
1030                                      order-by-slots)))))
1031       (dolist (ob (listify distinct))
1032         (when (and (typep ob 'sql-ident)
1033                    (not (member ob (mapcar #'cdr fullsels)
1034                                 :test #'ref-equal)))
1035           (setq fullsels
1036               (append fullsels (mapcar #'(lambda (att) (cons nil att))
1037                                        (listify ob))))))
1038       (mapcar #'(lambda (vclass jclasses jslots)
1039                   (when jclasses
1040                     (mapcar
1041                      #'(lambda (jclass jslot)
1042                          (let ((dbi (view-class-slot-db-info jslot)))
1043                            (setq where
1044                                  (append
1045                                   (list (sql-operation '==
1046                                                       (sql-expression
1047                                                        :attribute (gethash :foreign-key dbi)
1048                                                        :table (view-table jclass))
1049                                                       (sql-expression
1050                                                        :attribute (gethash :home-key dbi)
1051                                                        :table (view-table vclass))))
1052                                   (when where (listify where))))))
1053                      jclasses jslots)))
1054               sclasses immediate-join-classes immediate-join-slots)
1055       (let* ((rows (apply #'select
1056                           (append (mapcar #'cdr fullsels)
1057                                   (cons :from
1058                                         (list (append (when from (listify from))
1059                                                       (listify tables))))
1060                                   (list :result-types result-types)
1061                                   (when where (list :where where))
1062                                   args)))
1063              (instances-to-add (- (length rows) (length instances)))
1064              (perhaps-extended-instances
1065               (if (plusp instances-to-add)
1066                   (append instances (do ((i 0 (1+ i))
1067                                          (res nil))
1068                                         ((= i instances-to-add) res)
1069                                       (push (make-list (length sclasses) :initial-element nil) res)))
1070                 instances))
1071              (objects (mapcar
1072                        #'(lambda (row instance)
1073                            (build-objects row sclasses immediate-join-classes sels
1074                                           immediate-join-sels database refresh flatp
1075                                           (if (and flatp (atom instance))
1076                                               (list instance)
1077                                             instance)))
1078                        rows perhaps-extended-instances)))
1079         objects))))
1080
1081 (defmethod instance-refreshed ((instance standard-db-object)))
1082
1083 (defun select (&rest select-all-args)
1084    "The function SELECT selects data from DATABASE, which has a
1085 default value of *DEFAULT-DATABASE*, given the constraints
1086 specified by the rest of the ARGS. It returns a list of objects
1087 as specified by SELECTIONS. By default, the objects will each be
1088 represented as lists of attribute values. The argument SELECTIONS
1089 consists either of database identifiers, type-modified database
1090 identifiers or literal strings. A type-modifed database
1091 identifier is an expression such as [foo :string] which means
1092 that the values in column foo are returned as Lisp strings.  The
1093 FLATP argument, which has a default value of nil, specifies if
1094 full bracketed results should be returned for each matched
1095 entry. If FLATP is nil, the results are returned as a list of
1096 lists. If FLATP is t, the results are returned as elements of a
1097 list, only if there is only one result per row. The arguments
1098 ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
1099 ORDER-by have the same function as the equivalent SQL expression.
1100 The SELECT function is common across both the functional and
1101 object-oriented SQL interfaces. If selections refers to View
1102 Classes then the select operation becomes object-oriented. This
1103 means that SELECT returns a list of View Class instances, and
1104 SLOT-VALUE becomes a valid SQL operator for use within the where
1105 clause. In the View Class case, a second equivalent select call
1106 will return the same View Class instance objects. If REFRESH is
1107 true, then existing instances are updated if necessary, and in
1108 this case you might need to extend the hook INSTANCE-REFRESHED.
1109 The default value of REFRESH is nil. SQL expressions used in the
1110 SELECT function are specified using the square bracket syntax,
1111 once this syntax has been enabled using
1112 ENABLE-SQL-READER-SYNTAX."
1113
1114   (flet ((select-objects (target-args)
1115            (and target-args
1116                 (every #'(lambda (arg)
1117                            (and (symbolp arg)
1118                                 (find-class arg nil)))
1119                        target-args))))
1120     (multiple-value-bind (target-args qualifier-args)
1121         (query-get-selections select-all-args)
1122       (unless (or *default-database* (getf qualifier-args :database))
1123         (signal-no-database-error nil))
1124
1125         (cond
1126           ((select-objects target-args)
1127            (let ((caching (getf qualifier-args :caching t))
1128                  (result-types (getf qualifier-args :result-types :auto))
1129                  (refresh (getf qualifier-args :refresh nil))
1130                  (database (or (getf qualifier-args :database) *default-database*))
1131                  (order-by (getf qualifier-args :order-by)))
1132              (remf qualifier-args :caching)
1133              (remf qualifier-args :refresh)
1134              (remf qualifier-args :result-types)
1135
1136
1137              ;; Add explicity table name to order-by if not specified and only
1138              ;; one selected table. This is required so FIND-ALL won't duplicate
1139              ;; the field
1140              (when (and order-by (= 1 (length target-args)))
1141                (let ((table-name  (view-table (find-class (car target-args))))
1142                      (order-by-list (copy-seq (listify order-by))))
1143
1144                  (loop for i from 0 below (length order-by-list)
1145                      do (etypecase (nth i order-by-list)
1146                           (sql-ident-attribute
1147                            (unless (slot-value (nth i order-by-list) 'qualifier)
1148                              (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
1149                           (cons
1150                            (unless (slot-value (car (nth i order-by-list)) 'qualifier)
1151                              (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
1152                  (setf (getf qualifier-args :order-by) order-by-list)))
1153
1154              (cond
1155                ((null caching)
1156                 (apply #'find-all target-args
1157                        (append qualifier-args (list :result-types result-types))))
1158                (t
1159                 (let ((cached (records-cache-results target-args qualifier-args database)))
1160                   (cond
1161                     ((and cached (not refresh))
1162                      cached)
1163                     ((and cached refresh)
1164                      (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto)))))
1165                        (setf (records-cache-results target-args qualifier-args database) results)
1166                        results))
1167                     (t
1168                      (let ((results (apply #'find-all target-args (append qualifier-args
1169                                                                           '(:result-types :auto)))))
1170                        (setf (records-cache-results target-args qualifier-args database) results)
1171                        results))))))))
1172           (t
1173            (let* ((expr (apply #'make-query select-all-args))
1174                   (specified-types
1175                    (mapcar #'(lambda (attrib)
1176                                (if (typep attrib 'sql-ident-attribute)
1177                                    (let ((type (slot-value attrib 'type)))
1178                                      (if type
1179                                          type
1180                                          t))
1181                                    t))
1182                            (slot-value expr 'selections))))
1183              (destructuring-bind (&key (flatp nil)
1184                                        (result-types :auto)
1185                                        (field-names t)
1186                                        (database *default-database*)
1187                                        &allow-other-keys)
1188                  qualifier-args
1189                (query expr :flatp flatp
1190                       :result-types
1191                       ;; specifying a type for an attribute overrides result-types
1192                       (if (some #'(lambda (x) (not (eq t x))) specified-types)
1193                           specified-types
1194                           result-types)
1195                       :field-names field-names
1196                       :database database))))))))
1197
1198 (defun compute-records-cache-key (targets qualifiers)
1199   (list targets
1200         (do ((args *select-arguments* (cdr args))
1201              (results nil))
1202             ((null args) results)
1203           (let* ((arg (car args))
1204                  (value (getf qualifiers arg)))
1205             (when value
1206               (push (list arg
1207                           (typecase value
1208                             (cons (cons (sql (car value)) (cdr value)))
1209                             (%sql-expression (sql value))
1210                             (t value)))
1211                     results))))))
1212
1213 (defun records-cache-results (targets qualifiers database)
1214   (when (record-caches database)
1215     (gethash (compute-records-cache-key targets qualifiers) (record-caches database))))
1216
1217 (defun (setf records-cache-results) (results targets qualifiers database)
1218   (unless (record-caches database)
1219     (setf (record-caches database)
1220           (make-hash-table :test 'equal
1221                            #+allegro :values #+allegro :weak)))
1222   (setf (gethash (compute-records-cache-key targets qualifiers)
1223                  (record-caches database)) results)
1224   results)
1225
1226 (defun update-cached-results (targets qualifiers database)
1227   ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached
1228   ;; for now, dump cache entry and perform fresh search
1229   (let ((res (apply #'find-all targets qualifiers)))
1230     (setf (gethash (compute-records-cache-key targets qualifiers)
1231                    (record-caches database)) res)
1232     res))
1233