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