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   (float (read-from-string val)))
 694
 695 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 696   (case (database-underlying-type database)
 697     (:mysql
 698      (etypecase val
 699        (string (if (string= "0" val) nil t))
 700        (integer (if (zerop val) nil t))))
 701     (:postgresql
 702      (if (eq :odbc (database-type database))
 703          (if (string= "0" val) nil t)
 704        (equal "t" val)))
 705     (t
 706      (equal "t" val))))
 707
 708 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
 709   (declare (ignore database))
 710   (unless (eq 'NULL val)
 711     (etypecase val
 712       (string
 713        (parse-integer val))
 714       (number val))))
 715
 716 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 717   (declare (ignore database))
 718   (unless (eq 'NULL val)
 719     (parse-timestring val)))
 720
 721 (defmethod read-sql-value (val (type (eql 'duration)) database)
 722   (declare (ignore database))
 723   (unless (or (eq 'NULL val)
 724               (equal "NIL" val))
 725     (parse-timestring val)))
 726
 727 ;; ------------------------------------------------------------
 728 ;; Logic for 'faulting in' :join slots
 729
 730 ;; this works, but is inefficient requiring (+ 1 n-rows)
 731 ;; SQL queries
 732 #+ignore
 733 (defun fault-join-target-slot (class object slot-def)
 734   (let* ((res (fault-join-slot-raw class object slot-def))
 735          (dbi (view-class-slot-db-info slot-def))
 736          (target-name (gethash :target-slot dbi))
 737          (target-class (find-class target-name)))
 738     (when res
 739       (mapcar (lambda (obj)
 740                 (list
 741                  (car
 742                   (fault-join-slot-raw
 743                    target-class
 744                    obj
 745                    (find target-name (class-slots (class-of obj))
 746                          :key #'slot-definition-name)))
 747                  obj))
 748               res)
 749       #+ignore ;; this doesn't work when attempting to call slot-value
 750       (mapcar (lambda (obj)
 751                 (cons obj (slot-value obj ts))) res))))
 752
 753 (defun fault-join-target-slot (class object slot-def)
 754   (let* ((dbi (view-class-slot-db-info slot-def))
 755          (ts (gethash :target-slot dbi))
 756          (jc (gethash :join-class dbi))
 757          (ts-view-table (view-table (find-class ts)))
 758          (jc-view-table (view-table (find-class jc)))
 759          (tdbi (view-class-slot-db-info
 760                 (find ts (class-slots (find-class jc))
 761                       :key #'slot-definition-name)))
 762          (retrieval (gethash :retrieval tdbi))
 763          (jq (join-qualifier class object slot-def))
 764          (key (slot-value object (gethash :home-key dbi))))
 765     (when jq
 766       (ecase retrieval
 767         (:immediate
 768          (let ((res
 769                 (find-all (list ts)
 770                           :inner-join (sql-expression :table jc-view-table)
 771                           :on (sql-operation
 772                                '==
 773                                (sql-expression
 774                                 :attribute (gethash :foreign-key tdbi)
 775                                 :table ts-view-table)
 776                                (sql-expression
 777                                 :attribute (gethash :home-key tdbi)
 778                                 :table jc-view-table))
 779                           :where jq
 780                           :result-types :auto)))
 781            (mapcar #'(lambda (i)
 782                        (let* ((instance (car i))
 783                               (jcc (make-instance jc :view-database (view-database instance))))
 784                          (setf (slot-value jcc (gethash :foreign-key dbi))
 785                                key)
 786                          (setf (slot-value jcc (gethash :home-key tdbi))
 787                                (slot-value instance (gethash :foreign-key tdbi)))
 788                       (list instance jcc)))
 789                    res)))
 790         (:deferred
 791             ;; just fill in minimal slots
 792             (mapcar
 793              #'(lambda (k)
 794                  (let ((instance (make-instance ts :view-database (view-database object)))
 795                        (jcc (make-instance jc :view-database (view-database object)))
 796                        (fk (car k)))
 797                    (setf (slot-value instance (gethash :home-key tdbi)) fk)
 798                    (setf (slot-value jcc (gethash :foreign-key dbi))
 799                          key)
 800                    (setf (slot-value jcc (gethash :home-key tdbi))
 801                          fk)
 802                    (list instance jcc)))
 803              (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
 804                      :from (sql-expression :table jc-view-table)
 805                      :where jq)))))))
 806
 807 (defun update-object-joins (objects &key (slots t) (force-p t)
 808                             class-name (max-len *default-update-objects-max-len*))
 809   "Updates the remote join slots, that is those slots defined without
 810 :retrieval :immediate."
 811   (assert (or (null max-len) (plusp max-len)))
 812   (when objects
 813     (unless class-name
 814       (setq class-name (class-name (class-of (first objects)))))
 815     (let* ((class (find-class class-name))
 816            (class-slots (ordered-class-slots class))
 817            (slotdefs
 818             (if (eq t slots)
 819                 (generate-retrieval-joins-list class :deferred)
 820               (remove-if #'null
 821                          (mapcar #'(lambda (name)
 822                                      (let ((slotdef (find name class-slots :key #'slot-definition-name)))
 823                                        (unless slotdef
 824                                          (warn "Unable to find slot named ~S in class ~S." name class))
 825                                        slotdef))
 826                                  slots)))))
 827       (dolist (slotdef slotdefs)
 828         (let* ((dbi (view-class-slot-db-info slotdef))
 829                (slotdef-name (slot-definition-name slotdef))
 830                (foreign-key (gethash :foreign-key dbi))
 831                (home-key (gethash :home-key dbi))
 832                (object-keys
 833                 (remove-duplicates
 834                  (if force-p
 835                      (mapcar #'(lambda (o) (slot-value o home-key)) objects)
 836                    (remove-if #'null
 837                               (mapcar
 838                                #'(lambda (o) (if (slot-boundp o slotdef-name)
 839                                                  nil
 840                                                (slot-value o home-key)))
 841                                objects)))))
 842                (n-object-keys (length object-keys))
 843                (query-len (or max-len n-object-keys)))
 844
 845           (do ((i 0 (+ i query-len)))
 846               ((>= i n-object-keys))
 847             (let* ((keys (if max-len
 848                              (subseq object-keys i (min (+ i query-len) n-object-keys))
 849                            object-keys))
 850                    (results (find-all (list (gethash :join-class dbi))
 851                                       :where (make-instance 'sql-relational-exp
 852                                                :operator 'in
 853                                                :sub-expressions (list (sql-expression :attribute foreign-key)
 854                                                                       keys))
 855                                       :flatp t)))
 856               (dolist (object objects)
 857                 (when (or force-p (not (slot-boundp object slotdef-name)))
 858                   (let ((res (find (slot-value object home-key) results
 859                                    :key #'(lambda (res) (slot-value res foreign-key))
 860                                    :test #'equal)))
 861                     (when res
 862                       (setf (slot-value object slotdef-name) res)))))))))))
 863   (values))
 864
 865 (defun fault-join-slot-raw (class object slot-def)
 866   (let* ((dbi (view-class-slot-db-info slot-def))
 867          (jc (gethash :join-class dbi)))
 868     (let ((jq (join-qualifier class object slot-def)))
 869       (when jq
 870         (select jc :where jq :flatp t :result-types nil)))))
 871
 872 (defun fault-join-slot (class object slot-def)
 873   (let* ((dbi (view-class-slot-db-info slot-def))
 874          (ts (gethash :target-slot dbi)))
 875     (if (and ts (gethash :set dbi))
 876         (fault-join-target-slot class object slot-def)
 877         (let ((res (fault-join-slot-raw class object slot-def)))
 878           (when res
 879             (cond
 880               ((and ts (not (gethash :set dbi)))
 881                (mapcar (lambda (obj) (slot-value obj ts)) res))
 882               ((and (not ts) (not (gethash :set dbi)))
 883                (car res))
 884               ((and (not ts) (gethash :set dbi))
 885                res)))))))
 886
 887 (defun join-qualifier (class object slot-def)
 888     (declare (ignore class))
 889     (let* ((dbi (view-class-slot-db-info slot-def))
 890            (jc (find-class (gethash :join-class dbi)))
 891            ;;(ts (gethash :target-slot dbi))
 892            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 893            (foreign-keys (gethash :foreign-key dbi))
 894            (home-keys (gethash :home-key dbi)))
 895       (when (every #'(lambda (slt)
 896                        (and (slot-boundp object slt)
 897                             (not (null (slot-value object slt)))))
 898                    (if (listp home-keys) home-keys (list home-keys)))
 899         (let ((jc
 900                (mapcar #'(lambda (hk fk)
 901                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 902                              (sql-operation '==
 903                                             (typecase fk
 904                                               (symbol
 905                                                (sql-expression
 906                                                 :attribute
 907                                                 (view-class-slot-column fksd)
 908                                                 :table (view-table jc)))
 909                                               (t fk))
 910                                             (typecase hk
 911                                               (symbol
 912                                                (slot-value object hk))
 913                                               (t
 914                                                hk)))))
 915                        (if (listp home-keys)
 916                            home-keys
 917                            (list home-keys))
 918                        (if (listp foreign-keys)
 919                            foreign-keys
 920                            (list foreign-keys)))))
 921           (when jc
 922             (if (> (length jc) 1)
 923                 (apply #'sql-and jc)
 924                 jc))))))
 925
 926 ;; FIXME: add retrieval immediate for efficiency
 927 ;; For example, for (select 'employee-address) in test suite =>
 928 ;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
 929
 930 (defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances)
 931   "Used by find-all to build objects."
 932   (labels ((build-object (vals vclass jclasses selects immediate-selects instance)
 933              (let* ((db-vals (butlast vals (- (list-length vals)
 934                                               (list-length selects))))
 935                     (obj (if instance instance (make-instance (class-name vclass) :view-database database)))
 936                     (join-vals (subseq vals (list-length selects)))
 937                     (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
 938                                    jclasses)))
 939                ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals)
 940                ;; use refresh keyword here
 941                (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals))
 942                (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals))
 943                      joins)
 944                (mapc
 945                 #'(lambda (jc)
 946                     (let ((slot (find (class-name (class-of jc)) (class-slots vclass)
 947                                       :key #'(lambda (slot)
 948                                                (when (and (eq :join (view-class-slot-db-kind slot))
 949                                                           (eq (slot-definition-name slot)
 950                                                               (gethash :join-class (view-class-slot-db-info slot))))
 951                                                  (slot-definition-name slot))))))
 952                       (when slot
 953                         (setf (slot-value obj (slot-definition-name slot)) jc))))
 954                 joins)
 955                (when refresh (instance-refreshed obj))
 956                obj)))
 957     (let* ((objects
 958             (mapcar #'(lambda (sclass jclass sel immediate-join instance)
 959                         (prog1
 960                             (build-object vals sclass jclass sel immediate-join instance)
 961                           (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
 962                                              vals))))
 963                     sclasses immediate-join-classes sels immediate-joins instances)))
 964       (if (and flatp (= (length sclasses) 1))
 965           (car objects)
 966         objects))))
 967
 968 (defun find-all (view-classes
 969                  &rest args
 970                  &key all set-operation distinct from where group-by having
 971                       order-by offset limit refresh flatp result-types
 972                       inner-join on
 973                       (database *default-database*)
 974                       instances)
 975   "Called by SELECT to generate object query results when the
 976   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 977   (declare (ignore all set-operation group-by having offset limit inner-join on)
 978            (optimize (debug 3) (speed 1)))
 979   (labels ((ref-equal (ref1 ref2)
 980              (equal (sql ref1)
 981                     (sql ref2)))
 982            (table-sql-expr (table)
 983              (sql-expression :table (view-table table)))
 984            (tables-equal (table-a table-b)
 985              (when (and table-a table-b)
 986                (string= (string (slot-value table-a 'name))
 987                         (string (slot-value table-b 'name))))))
 988     (remf args :from)
 989     (remf args :where)
 990     (remf args :flatp)
 991     (remf args :additional-fields)
 992     (remf args :result-types)
 993     (remf args :instances)
 994     (let* ((*db-deserializing* t)
 995            (sclasses (mapcar #'find-class view-classes))
 996            (immediate-join-slots
 997             (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
 998            (immediate-join-classes
 999             (mapcar #'(lambda (jcs)
1000                         (mapcar #'(lambda (slotdef)
1001                                     (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
1002                                 jcs))
1003                     immediate-join-slots))
1004            (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
1005            (sels (mapcar #'generate-selection-list sclasses))
1006            (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
1007            (sel-tables (collect-table-refs where))
1008            (tables (remove-if #'null
1009                               (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
1010                                                          (mapcar #'(lambda (jcs)
1011                                                                      (mapcan #'(lambda (jc)
1012                                                                                  (when jc (table-sql-expr jc)))
1013                                                                              jcs))
1014                                                                  immediate-join-classes)
1015                                                          sel-tables)
1016                                                  :test #'tables-equal))))
1017       (dolist (ob (listify order-by))
1018         (when (and ob (not (member ob (mapcar #'cdr fullsels)
1019                                    :test #'ref-equal)))
1020           (setq fullsels
1021                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
1022                                            (listify ob))))))
1023       (dolist (ob (listify distinct))
1024         (when (and (typep ob 'sql-ident)
1025                    (not (member ob (mapcar #'cdr fullsels)
1026                                 :test #'ref-equal)))
1027           (setq fullsels
1028               (append fullsels (mapcar #'(lambda (att) (cons nil att))
1029                                        (listify ob))))))
1030       (mapcar #'(lambda (vclass jclasses jslots)
1031                   (when jclasses
1032                     (mapcar
1033                      #'(lambda (jclass jslot)
1034                          (let ((dbi (view-class-slot-db-info jslot)))
1035                            (setq where
1036                                  (append
1037                                   (list (sql-operation '==
1038                                                       (sql-expression
1039                                                        :attribute (gethash :foreign-key dbi)
1040                                                        :table (view-table jclass))
1041                                                       (sql-expression
1042                                                        :attribute (gethash :home-key dbi)
1043                                                        :table (view-table vclass))))
1044                                   (when where (listify where))))))
1045                      jclasses jslots)))
1046               sclasses immediate-join-classes immediate-join-slots)
1047       (let* ((rows (apply #'select
1048                           (append (mapcar #'cdr fullsels)
1049                                   (cons :from
1050                                         (list (append (when from (listify from))
1051                                                       (listify tables))))
1052                                   (list :result-types result-types)
1053                                   (when where (list :where where))
1054                                   args)))
1055              (instances-to-add (- (length rows) (length instances)))
1056              (perhaps-extended-instances
1057               (if (plusp instances-to-add)
1058                   (append instances (do ((i 0 (1+ i))
1059                                          (res nil))
1060                                         ((= i instances-to-add) res)
1061                                       (push (make-list (length sclasses) :initial-element nil) res)))
1062                 instances))
1063              (objects (mapcar
1064                        #'(lambda (row instance)
1065                            (build-objects row sclasses immediate-join-classes sels
1066                                           immediate-join-sels database refresh flatp
1067                                           (if (and flatp (atom instance))
1068                                               (list instance)
1069                                             instance)))
1070                        rows perhaps-extended-instances)))
1071         objects))))
1072
1073 (defmethod instance-refreshed ((instance standard-db-object)))
1074
1075 (defun select (&rest select-all-args)
1076    "The function SELECT selects data from DATABASE, which has a
1077 default value of *DEFAULT-DATABASE*, given the constraints
1078 specified by the rest of the ARGS. It returns a list of objects
1079 as specified by SELECTIONS. By default, the objects will each be
1080 represented as lists of attribute values. The argument SELECTIONS
1081 consists either of database identifiers, type-modified database
1082 identifiers or literal strings. A type-modifed database
1083 identifier is an expression such as [foo :string] which means
1084 that the values in column foo are returned as Lisp strings.  The
1085 FLATP argument, which has a default value of nil, specifies if
1086 full bracketed results should be returned for each matched
1087 entry. If FLATP is nil, the results are returned as a list of
1088 lists. If FLATP is t, the results are returned as elements of a
1089 list, only if there is only one result per row. The arguments
1090 ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
1091 ORDER-by have the same function as the equivalent SQL expression.
1092 The SELECT function is common across both the functional and
1093 object-oriented SQL interfaces. If selections refers to View
1094 Classes then the select operation becomes object-oriented. This
1095 means that SELECT returns a list of View Class instances, and
1096 SLOT-VALUE becomes a valid SQL operator for use within the where
1097 clause. In the View Class case, a second equivalent select call
1098 will return the same View Class instance objects. If REFRESH is
1099 true, then existing instances are updated if necessary, and in
1100 this case you might need to extend the hook INSTANCE-REFRESHED.
1101 The default value of REFRESH is nil. SQL expressions used in the
1102 SELECT function are specified using the square bracket syntax,
1103 once this syntax has been enabled using
1104 ENABLE-SQL-READER-SYNTAX."
1105
1106   (flet ((select-objects (target-args)
1107            (and target-args
1108                 (every #'(lambda (arg)
1109                            (and (symbolp arg)
1110                                 (find-class arg nil)))
1111                        target-args))))
1112     (multiple-value-bind (target-args qualifier-args)
1113         (query-get-selections select-all-args)
1114         (cond
1115           ((select-objects target-args)
1116            (let ((caching (getf qualifier-args :caching t))
1117                  (refresh (getf qualifier-args :refresh nil))
1118                  (database (or (getf qualifier-args :database) *default-database*)))
1119              (remf qualifier-args :caching)
1120              (remf qualifier-args :refresh)
1121              (cond
1122                ((null caching)
1123                 (apply #'find-all target-args qualifier-args))
1124                (t
1125                 (let ((cached (records-cache-results target-args qualifier-args database)))
1126                   (cond
1127                     ((and cached (not refresh))
1128                      cached)
1129                     ((and cached refresh)
1130                      (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached)))))
1131                        (setf (records-cache-results target-args qualifier-args database) results)
1132                        results))
1133                     (t
1134                      (let ((results (apply #'find-all target-args qualifier-args)))
1135                        (setf (records-cache-results target-args qualifier-args database) results)
1136                        results))))))))
1137           (t
1138            (let* ((expr (apply #'make-query select-all-args))
1139                   (specified-types
1140                    (mapcar #'(lambda (attrib)
1141                                (if (typep attrib 'sql-ident-attribute)
1142                                    (let ((type (slot-value attrib 'type)))
1143                                      (if type
1144                                          type
1145                                          t))
1146                                    t))
1147                            (slot-value expr 'selections))))
1148              (destructuring-bind (&key (flatp nil)
1149                                        (result-types :auto)
1150                                        (field-names t)
1151                                        (database *default-database*)
1152                                        &allow-other-keys)
1153                  qualifier-args
1154                (query expr :flatp flatp
1155                       :result-types
1156                       ;; specifying a type for an attribute overrides result-types
1157                       (if (some #'(lambda (x) (not (eq t x))) specified-types)
1158                           specified-types
1159                           result-types)
1160                       :field-names field-names
1161                       :database database))))))))
1162
1163 (defun compute-records-cache-key (targets qualifiers)
1164   (list targets
1165         (do ((args *select-arguments* (cdr args))
1166              (results nil))
1167             ((null args) results)
1168           (let* ((arg (car args))
1169                  (value (getf qualifiers arg)))
1170             (when value
1171               (push (list arg
1172                           (typecase value
1173                             (%sql-expression (sql value))
1174                             (t value)))
1175                     results))))))
1176
1177 (defun records-cache-results (targets qualifiers database)
1178   (when (record-caches database)
1179     (gethash (compute-records-cache-key targets qualifiers) (record-caches database))))
1180
1181 (defun (setf records-cache-results) (results targets qualifiers database)
1182   (unless (record-caches database)
1183     (setf (record-caches database)
1184           (make-hash-table :test 'equal
1185                            #+allegro :values #+allegro :weak)))
1186   (setf (gethash (compute-records-cache-key targets qualifiers)
1187                  (record-caches database)) results)
1188   results)
1189
1190 (defun update-cached-results (targets qualifiers database)
1191   ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached
1192   ;; for now, dump cache entry and perform fresh search
1193   (let ((res (apply #'find-all targets qualifiers)))
1194     (setf (gethash (compute-records-cache-key targets qualifiers)
1195                    (record-caches database)) res)
1196     res))
1197