sql/oodml.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
   5 ;;;;
   6 ;;;; This file is part of CLSQL.
   7 ;;;;
   8 ;;;; CLSQL users are granted the rights to distribute and use this software
   9 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  10 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  11 ;;;; *************************************************************************
  12
  13 (in-package #:clsql-sys)
  14
  15 (defun find-normalized-key (obj)
  16   "Find the first / primary key of a normalized object"
  17   (find-slot-if obj #'key-slot-p T T))
  18
  19 (defun normalized-key-value (obj)
  20   "Normalized classes share a single key for all their key slots"
  21   (when (normalizedp (class-of obj))
  22     (easy-slot-value obj (find-normalized-key obj))))
  23
  24 (defun key-qualifier-for-instance (obj &key (database *default-database*) this-class)
  25   "Generate a boolean sql-expression that identifies an object by its keys"
  26   (let* ((obj-class (or this-class (class-of obj)))
  27          (keys (keyslots-for-class obj-class))
  28          (normal-db-value (normalized-key-value obj)))
  29     (when keys
  30       (labels ((db-value (k)
  31                  (or normal-db-value
  32                      (db-value-from-slot
  33                       k
  34                       (easy-slot-value obj k)
  35                       database)))
  36                (key-equal-exp (k)
  37                  (sql-operation '== (generate-attribute-reference obj-class k database)
  38                                 (db-value k))))
  39         (clsql-ands (mapcar #'key-equal-exp keys))))))
  40
  41 (defun generate-attribute-reference (vclass slotdef &optional (database *default-database*))
  42   "Turns key class and slot-def into a sql-expression representing the
  43    table and column it comes from
  44
  45    used by things like generate-selection-list, update-slot-from-record"
  46   (when (key-or-base-slot-p slotdef)
  47     (sql-expression :attribute (database-identifier slotdef database)
  48                     :table (database-identifier vclass database))))
  49
  50 ;;
  51 ;; Function used by 'find-all'
  52 ;;
  53
  54 (defun generate-selection-list (vclass)
  55   (let* ((sels nil)
  56          (this-class vclass)
  57          (slots (if (normalizedp vclass)
  58                     (labels ((getdslots ()
  59                                (let ((sl (ordered-class-direct-slots this-class)))
  60                                  (cond (sl)
  61                                        (t
  62                                         (setf this-class
  63                                               (car (class-direct-superclasses this-class)))
  64                                         (getdslots))))))
  65                       (getdslots))
  66                     (ordered-class-slots this-class))))
  67     (dolist (slotdef slots)
  68       (let ((res (generate-attribute-reference this-class slotdef)))
  69         (when res
  70           (push (cons slotdef res) sels))))
  71     (if sels
  72         sels
  73         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
  74
  75
  76
  77 (defun generate-retrieval-joins-list (vclass retrieval-method)
  78   "Returns list of immediate join slots for a class."
  79   (let ((join-slotdefs nil))
  80     (dolist (slotdef (ordered-class-slots vclass) join-slotdefs)
  81       (when (and (eq :join (view-class-slot-db-kind slotdef))
  82                  (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
  83         (push slotdef join-slotdefs)))))
  84
  85 (defun generate-immediate-joins-selection-list (vclass)
  86   "Returns list of immediate join slots for a class."
  87   (let (sels)
  88     (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels)
  89       (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot)))
  90              (join-class (when join-class-name (find-class join-class-name))))
  91         (dolist (slotdef (ordered-class-slots join-class))
  92           (let ((res (generate-attribute-reference join-class slotdef)))
  93             (when res
  94               (push (cons slotdef res) sels))))))
  95     sels))
  96
  97 (defun immediate-join-slots (class)
  98   (generate-retrieval-joins-list class :immediate))
  99
 100 (defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
 101   "Determine which database connection to use for a standard-db-object.
 102         Errs if none is available."
 103   (or (find-if #'(lambda (db)
 104                    (and db (is-database-open db)))
 105                (list (view-database obj)
 106                      database
 107                      *default-database*))
 108       (signal-no-database-error nil)))
 109
 110
 111
 112 (defmethod update-slot-with-null ((object standard-db-object) slotdef)
 113   "sets a slot to the void value of the slot-def (usually nil)"
 114   (setf (easy-slot-value object slotdef)
 115         (slot-value slotdef 'void-value)))
 116
 117 (defmethod update-slot-from-db-value ((instance standard-db-object) slotdef value)
 118   "This gets a value from the database and turns it itno a lisp value
 119    based on the slot's slot-db-reader or baring that read-sql-value"
 120   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 121   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 122          (slot-type   (specified-type slotdef)))
 123     (cond
 124       ((null value) (update-slot-with-null instance slotdef))
 125       ((null slot-reader)
 126        (setf (easy-slot-value instance slotdef)
 127              (read-sql-value value (delistify slot-type)
 128                              (choose-database-for-instance instance)
 129                              (database-underlying-type
 130                               (choose-database-for-instance instance)))))
 131       (t (etypecase slot-reader
 132            ((or symbol function)
 133             (setf (easy-slot-value instance slotdef)
 134                   (apply slot-reader (list value))))
 135            (string
 136             (setf (easy-slot-value instance slotdef)
 137                   (format nil slot-reader value))))))))
 138
 139 (defmethod key-value-from-db (slotdef value database)
 140   "TODO: is this deprecated? there are no uses anywhere in clsql"
 141   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 142   (let ((slot-reader (view-class-slot-db-reader slotdef))
 143         (slot-type (specified-type slotdef)))
 144     (cond ((and value (null slot-reader))
 145            (read-sql-value value (delistify slot-type) database
 146                            (database-underlying-type database)))
 147           ((null value)
 148            nil)
 149           ((typep slot-reader 'string)
 150            (format nil slot-reader value))
 151           ((typep slot-reader '(or symbol function))
 152            (apply slot-reader (list value)))
 153           (t
 154            (error "Slot reader is of an unusual type.")))))
 155
 156 (defun db-value-from-slot (slotdef val database)
 157   (let ((dbwriter (view-class-slot-db-writer slotdef))
 158         (dbtype (specified-type slotdef)))
 159     (typecase dbwriter
 160       (string (format nil dbwriter val))
 161       ((and (or symbol function) (not null)) (apply dbwriter (list val)))
 162       (t
 163        (database-output-sql-as-type
 164         (typecase dbtype
 165           (cons (car dbtype))
 166           (t dbtype))
 167         val database (database-underlying-type database))))))
 168
 169 (defun check-slot-type (slotdef val)
 170   (let* ((slot-type (specified-type slotdef))
 171          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 172     (when (and slot-type val)
 173       (unless (typep val basetype)
 174         (error 'sql-user-error
 175                :message
 176                (format nil "Invalid value ~A in slot ~A, not of type ~A."
 177                        val (slot-definition-name slotdef) slot-type))))))
 178
 179 (defmethod get-slot-values-from-view (obj slotdeflist values)
 180   "Used to copy values from the database into the object
 181    used by things like find-all and select"
 182   (loop for slot in slotdeflist
 183         for value in values
 184         do (update-slot-from-db-value obj slot value))
 185   obj)
 186
 187 (defclass class-and-slots ()
 188   ((view-class :accessor view-class :initarg :view-class :initform nil)
 189    (slot-defs :accessor slot-defs :initarg :slot-defs :initform nil))
 190   (:documentation "A helper class to keep track of which slot-defs from a
 191    table need to be updated, a normalized class might have many of these
 192    because each of its parent classes might represent some other table and we
 193    need to match which slots came from which parent class/table"))
 194
 195 (defun make-class-and-slots (c &optional s)
 196   "Create a new class-and-slots object"
 197   (make-instance 'class-and-slots :view-class c :slot-defs (listify s) ))
 198
 199 (defmethod view-table ((o class-and-slots))
 200   "get the view-table of the view-class of o"
 201   (view-table (view-class o)))
 202
 203 (defmethod view-table-exp ((o class-and-slots))
 204   (sql-expression :table (view-table o)))
 205
 206 (defmethod view-table-exp ((o standard-db-class))
 207   (sql-expression :table (view-table o)))
 208
 209 (defmethod attribute-references ((o class-and-slots))
 210   "build sql-ident-attributes for a given class-and-slots"
 211   (loop
 212     with class = (view-class o)
 213     for sd in (slot-defs o)
 214     collect (generate-attribute-reference class sd)))
 215
 216 (defmethod attribute-value-pairs ((def class-and-slots) (o standard-db-object)
 217                                   database)
 218   "for a given class-and-slots and object, create the sql-expression & value pairs
 219    that need to be sent to the database"
 220   (loop for s in (slot-defs def)
 221         for n = (to-slot-name s)
 222         when (slot-boundp o n)
 223         collect (make-attribute-value-pair s (slot-value o n) database)))
 224
 225 (defmethod view-classes-and-slots-by-name ((obj standard-db-object) slots-to-match)
 226   "If it's normalized, find the class that actually contains
 227    the slot that's tied to the db,
 228
 229    otherwise just search the current class
 230   "
 231   (let* ((view-class (class-of obj))
 232          (normalizedp (normalizedp view-class))
 233          rtns)
 234     (labels ((get-c&s-obj (class)
 235                (or (find class rtns :key #'view-class)
 236                    (first (push (make-class-and-slots class) rtns))))
 237              (associate-slot-with-class (class slot)
 238                "Find the best class to associate with the slot. If it is
 239                 normalized then it needs to be a direct slot otherwise it just
 240                 needs to be on the class."
 241                (let ((sd (find-slot-by-name class slot normalizedp nil)))
 242                  (if sd
 243                      ;;we found it directly or it's (not normalized)
 244                      (pushnew sd (slot-defs (get-c&s-obj class)))
 245                      (when normalizedp
 246                        (loop for parent in (class-direct-superclasses class)
 247                              until (associate-slot-with-class parent slot))))
 248                  sd)))
 249       (loop
 250         for in-slot in (listify slots-to-match)
 251         do (associate-slot-with-class view-class in-slot)))
 252     rtns))
 253
 254 (defun update-auto-increments-keys (class obj database)
 255   " handle pulling any autoincrement values into the object
 256    if normalized and we now that all the "
 257   (let ((pk-slots (keyslots-for-class class))
 258         (table (view-table class))
 259         new-pk-value)
 260     (labels ((do-update (slot)
 261                (when (and (null (easy-slot-value obj slot))
 262                           (auto-increment-column-p slot database))
 263                  (update-slot-from-db-value
 264                   obj slot
 265                   (or new-pk-value
 266                       (setf new-pk-value
 267                             (database-last-auto-increment-id
 268                              database table slot))))))
 269              (chain-primary-keys (in-class)
 270                "This seems kindof wrong, but this is mostly how it was working, so
 271                   its here to keep the normalized code path working"
 272                (when (typep in-class 'standard-db-class)
 273                  (loop for slot in (ordered-class-slots in-class)
 274                        when (key-slot-p slot)
 275                        do (do-update slot)))))
 276       (loop for slot in pk-slots do (do-update slot))
 277       (let ((direct-class (to-class obj)))
 278         (when (and new-pk-value (normalizedp direct-class))
 279           (chain-primary-keys direct-class)))
 280       new-pk-value)))
 281
 282 (defmethod %update-instance-helper
 283     (class-and-slots obj database
 284      &aux (avps (attribute-value-pairs class-and-slots obj database)))
 285   "A function to help us update a given table (based on class-and-slots)
 286    with values from an object"
 287   ;; we dont actually need to update anything on this particular
 288   ;; class / parent class
 289   (unless avps (return-from %update-instance-helper))
 290
 291   (let* ((view-class (view-class class-and-slots))
 292          (table (view-table view-class))
 293          (table-sql (sql-expression :table table)))
 294
 295     ;; view database is the flag we use to tell it was pulled from a database
 296     ;; and thus probably needs an update instead of an insert
 297     (cond ((view-database obj)
 298            (let ((where (key-qualifier-for-instance
 299                          obj :database database :this-class view-class)))
 300              (unless where
 301                (error "update-record-from-*: could not generate a where clause for ~a using ~A"
 302                       obj view-class))
 303              (update-records table-sql
 304                              :av-pairs avps
 305                              :where where
 306                              :database database)))
 307           (T ;; was not pulled from the db so insert it
 308            ;; avps MUST contain any primary key slots set
 309            ;; by previous inserts of the same object into different
 310            ;; tables (ie: normalized stuff)
 311            (insert-records :into table-sql
 312                            :av-pairs avps
 313                            :database database)
 314            (update-auto-increments-keys view-class obj database)
 315            ;; we dont set view database here, because there could be
 316            ;; N of these for each call to update-record-from-* because
 317            ;; of normalized classes
 318            ))
 319     (update-slot-default-values obj class-and-slots)))
 320
 321 (defmethod update-record-from-slots ((obj standard-db-object) slots
 322                                      &key (database *default-database*))
 323   "For a given list of slots, update all records associated with those slots
 324    and classes.
 325
 326    Generally this will update the single record associated with this object,
 327    but for normalized classes might update as many records as there are
 328    inheritances "
 329   (setf slots (listify slots))
 330   (let* ((classes-and-slots (view-classes-and-slots-by-name obj slots))
 331          (database (choose-database-for-instance obj database)))
 332     (loop for class-and-slots in classes-and-slots
 333           do (%update-instance-helper class-and-slots obj database))
 334     (setf (slot-value obj 'view-database) database))
 335   (values))
 336
 337 (defmethod update-record-from-slot
 338     ((obj standard-db-object) slot &key (database *default-database*))
 339   "just call update-records-from-slots which now handles this.
 340
 341    This function is only here to maintain backwards compatibility in
 342    the public api"
 343   (update-record-from-slots obj slot :database database))
 344
 345 (defun view-classes-and-storable-slots (class)
 346   "Get a list of all the tables we need to update and the slots on them
 347
 348    for non normalized classes we return the class and all its storable slots
 349
 350    for normalized classes we return a list of direct slots and the class they
 351    came from for each normalized view class
 352   "
 353   (setf class (to-class class))
 354   (let* (rtns)
 355     (labels ((storable-slots (class)
 356                (loop for sd in (slots-for-possibly-normalized-class class)
 357                      when (key-or-base-slot-p sd)
 358                      collect sd))
 359              (get-classes-and-slots (class &aux (normalizedp (normalizedp class)))
 360                (let ((slots (storable-slots class)))
 361                  (when slots
 362                    (push (make-class-and-slots class slots) rtns)))
 363                (when normalizedp
 364                  (loop for new-class in (class-direct-superclasses class)
 365                        do (when (typep new-class 'standard-db-class)
 366                             (get-classes-and-slots new-class))))))
 367       (get-classes-and-slots class))
 368     rtns))
 369
 370 (defmethod primary-key-slot-values ((obj standard-db-object)
 371                                     &key class slots )
 372   "Returns the values of all key-slots for a given class"
 373   (defaulting class (class-of obj)
 374               slots (keyslots-for-class class))
 375   (loop for slot in slots
 376         collect (easy-slot-value obj slot)))
 377
 378 (defmethod update-slot-default-values ((obj standard-db-object)
 379                                        classes-and-slots)
 380   "Makes sure that if a class has unfilled slots that claim to have a default,
 381    that we retrieve those defaults from the database
 382
 383    TODO: use update slots-from-record instead to batch this!"
 384   (loop for class-and-slots in (listify classes-and-slots)
 385         do (loop for slot in (slot-defs class-and-slots)
 386                  do (when (and (slot-has-default-p slot)
 387                                (not (easy-slot-value obj slot)))
 388                       (update-slot-from-record obj (to-slot-name slot))))))
 389
 390 (defmethod update-records-from-instance ((obj standard-db-object)
 391                                          &key (database *default-database*))
 392   "Updates the records in the database associated with this object if
 393    view-database slot on the object is nil then the object is assumed to be
 394    new and is inserted"
 395   (let ((database (choose-database-for-instance obj database))
 396         (classes-and-slots (view-classes-and-storable-slots obj)))
 397     (loop for class-and-slots in classes-and-slots
 398           do (%update-instance-helper class-and-slots obj database))
 399     (setf (slot-value obj 'view-database) database)
 400     (primary-key-slot-values obj)))
 401
 402 (defmethod delete-instance-records ((instance standard-db-object) &key database)
 403   "Removes the records associated with a given instance
 404    (as determined by key-qualifier-for-instance)
 405
 406    TODO: Doesnt handle normalized classes at all afaict"
 407   (let ((database (choose-database-for-instance instance database))
 408         (vt (sql-expression :table (view-table (class-of instance)))))
 409     (if database
 410         (let ((qualifier (key-qualifier-for-instance instance :database database)))
 411           (delete-records :from vt :where qualifier :database database)
 412           (setf (record-caches database) nil)
 413           (setf (slot-value instance 'view-database) nil)
 414           (values))
 415         (signal-no-database-error database))))
 416
 417 (defmethod update-instance-from-records ((instance standard-db-object)
 418                                          &key (database *default-database*)
 419                                          this-class)
 420   (let* ((view-class (or this-class (class-of instance)))
 421          (pclass (car (class-direct-superclasses view-class)))
 422          (pres nil))
 423     (when (normalizedp view-class)
 424       (setf pres (update-instance-from-records instance :database database
 425                                                :this-class pclass)))
 426     (let* ((view-table (sql-expression :table (view-table view-class)))
 427            (vd (choose-database-for-instance instance database))
 428            (view-qual (key-qualifier-for-instance instance :database vd
 429                                                            :this-class view-class))
 430            (sels (generate-selection-list view-class))
 431            (res nil))
 432       (cond (view-qual
 433              (setf res (apply #'select (append (mapcar #'cdr sels)
 434                                                (list :from  view-table
 435                                                      :where view-qual
 436                                                      :result-types nil
 437                                                      :database vd))))
 438              (when res
 439                (setf (slot-value instance 'view-database) vd)
 440                (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
 441             (pres)
 442             (t nil)))))
 443
 444
 445 (defmethod get-slot-value-from-record ((instance standard-db-object)
 446                                        slot &key (database *default-database*))
 447   (let* ((class-and-slot
 448            (first
 449             (view-classes-and-slots-by-name instance slot)))
 450          (view-class (view-class class-and-slot))
 451          (slot-def (first (slot-defs class-and-slot)))
 452          (vd (choose-database-for-instance instance database))
 453          (att-ref (first (attribute-references class-and-slot)))
 454          (res (first
 455                (select att-ref
 456                  :from (view-table-exp class-and-slot)
 457                  :where (key-qualifier-for-instance
 458                          instance
 459                          :database vd
 460                          :this-class view-class)
 461                  :result-types nil
 462                  :flatp T))))
 463     (values res slot-def)))
 464
 465 (defmethod update-slot-from-record ((instance standard-db-object)
 466                                     slot &key (database *default-database*))
 467   "Pulls the value of a given slot form the database and stores that in the
 468    appropriate slot on instance"
 469   (multiple-value-bind (res slot-def)
 470       (get-slot-value-from-record instance slot :database database)
 471     (let ((vd (choose-database-for-instance instance database)))
 472       (setf (slot-value instance 'view-database) vd)
 473       (update-slot-from-db-value instance slot-def res))))
 474
 475
 476 (defvar +no-slot-value+ '+no-slot-value+)
 477
 478 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 479         (let* ((class (find-class classname))
 480                (sld (slotdef-for-slot-with-class slot class)))
 481           (if sld
 482               (if (eq value +no-slot-value+)
 483                   (sql-expression :attribute (database-identifier sld database)
 484                                   :table (view-table class))
 485                   (db-value-from-slot
 486                    sld
 487                    value
 488                    database))
 489               (error "Unknown slot ~A for class ~A" slot classname))))
 490
 491 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 492         (declare (ignore database))
 493         (let* ((class (find-class classname)))
 494           (unless (view-table class)
 495             (error "No view-table for class ~A"  classname))
 496           (sql-expression :table (view-table class))))
 497
 498
 499 (defmethod database-get-type-specifier (type args database db-type)
 500   (declare (ignore type args database db-type))
 501   (format nil "VARCHAR(~D)" *default-string-length*))
 502
 503 (defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
 504   (declare (ignore database db-type))
 505   (if args
 506       (format nil "INT(~A)" (car args))
 507       "INT"))
 508
 509 (deftype tinyint ()
 510   "An 8-bit integer, this width may vary by SQL implementation."
 511   'integer)
 512
 513 (defmethod database-get-type-specifier ((type (eql 'tinyint)) args database db-type)
 514   (declare (ignore args database db-type))
 515   "INT")
 516
 517 (deftype smallint ()
 518   "An integer smaller than a 32-bit integer. this width may vary by SQL implementation."
 519   'integer)
 520
 521 (defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type)
 522   (declare (ignore args database db-type))
 523   "INT")
 524
 525 (deftype mediumint ()
 526   "An integer smaller than a 32-bit integer, but may be larger than a smallint. This width may vary by SQL implementation."
 527   'integer)
 528
 529 (defmethod database-get-type-specifier ((type (eql 'mediumint)) args database db-type)
 530   (declare (ignore args database db-type))
 531   "INT")
 532
 533 (deftype bigint ()
 534   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
 535   'integer)
 536
 537 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
 538   (declare (ignore args database db-type))
 539   "BIGINT")
 540
 541 (deftype varchar (&optional size)
 542   "A variable length string for the SQL varchar type."
 543   (declare (ignore size))
 544   'string)
 545
 546 (defmethod database-get-type-specifier ((type (eql 'varchar)) args
 547                                         database db-type)
 548   (declare (ignore database db-type))
 549   (if args
 550       (format nil "VARCHAR(~A)" (car args))
 551       (format nil "VARCHAR(~D)" *default-string-length*)))
 552
 553 (defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
 554   (declare (ignore database db-type))
 555   (if args
 556       (format nil "CHAR(~A)" (car args))
 557       (format nil "VARCHAR(~D)" *default-string-length*)))
 558
 559 (deftype universal-time ()
 560   "A positive integer as returned by GET-UNIVERSAL-TIME."
 561   '(integer 1 *))
 562
 563 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
 564   (declare (ignore args database db-type))
 565   "BIGINT")
 566
 567 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
 568   (declare (ignore args database db-type))
 569   "TIMESTAMP")
 570
 571 (defmethod database-get-type-specifier ((type (eql 'date)) args database db-type)
 572   (declare (ignore args database db-type))
 573   "DATE")
 574
 575 (defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
 576   (declare (ignore database args db-type))
 577   "VARCHAR")
 578
 579 (defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
 580   (declare (ignore database args db-type))
 581   "INT8")
 582
 583 #+ignore
 584 (deftype char (&optional len)
 585   "A lisp type for the SQL CHAR type."
 586   `(string ,len))
 587
 588 (defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
 589   (declare (ignore database db-type))
 590   (if args
 591       (format nil "FLOAT(~A)" (car args))
 592       "FLOAT"))
 593
 594 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
 595   (declare (ignore database db-type))
 596   (if args
 597       (format nil "FLOAT(~A)" (car args))
 598       "FLOAT"))
 599
 600 (deftype generalized-boolean ()
 601   "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot."
 602   t)
 603
 604 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
 605   (declare (ignore args database db-type))
 606   "BOOL")
 607
 608 (defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database db-type)
 609   (declare (ignore args database db-type))
 610   "BOOL")
 611
 612 (defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
 613   (declare (ignore database db-type))
 614   (cond
 615     ((and (consp args) (= (length args) 2))
 616      (format nil "NUMBER(~D,~D)" (first args) (second args)))
 617     ((and (consp args) (= (length args) 1))
 618      (format nil "NUMBER(~D)" (first args)))
 619     (t
 620      "NUMBER")))
 621
 622 (defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
 623   (declare (ignore database db-type))
 624   (if args
 625       (format nil "CHAR(~D)" (first args))
 626       "CHAR(1)"))
 627
 628
 629 (defmethod database-output-sql-as-type (type val database db-type)
 630   (declare (ignore type database db-type))
 631   val)
 632
 633 (defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
 634   (declare (ignore database db-type))
 635   (progv '(*print-circle* *print-array*) '(t t)
 636     (let ((escaped (prin1-to-string val)))
 637       (substitute-char-string
 638        escaped #\Null " "))))
 639
 640 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
 641   (declare (ignore database db-type))
 642   (if val
 643       (concatenate 'string
 644                    (package-name (symbol-package val))
 645                    "::"
 646                    (symbol-name val))
 647       ""))
 648
 649 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
 650   (declare (ignore database db-type))
 651   (if val
 652       (symbol-name val)
 653       ""))
 654
 655 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
 656   (declare (ignore database db-type))
 657   (progv '(*print-circle* *print-array*) '(t t)
 658     (prin1-to-string val)))
 659
 660 (defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
 661   (declare (ignore database db-type))
 662   (progv '(*print-circle* *print-array*) '(t t)
 663     (prin1-to-string val)))
 664
 665 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
 666   (declare (ignore database db-type))
 667   (if val "t" "f"))
 668
 669 (defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type)
 670   (declare (ignore database db-type))
 671   (if val "t" "f"))
 672
 673 (defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
 674   (declare (ignore database db-type))
 675   val)
 676
 677 (defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type)
 678   (declare (ignore database db-type))
 679   (etypecase val
 680     (character (write-to-string val))
 681     (string val)))
 682
 683 (defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type)
 684   (declare (ignore database db-type))
 685   (if (eq (type-of val) 'null)
 686       nil
 687       (let ((*read-default-float-format* (type-of val)))
 688        (format nil "~F" val))))
 689
 690 (defmethod read-sql-value (val type database db-type)
 691   (declare (ignore database db-type))
 692   (cond
 693     ((null type) val) ;;we have no desired type, just give the value
 694     ((typep val type) val) ;;check that it hasn't already been converted.
 695     ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it?
 696     (T (error "Unable to read-sql-value ~a as type ~a" val type))))
 697
 698 (defmethod read-sql-value (val (type (eql 'string)) database db-type)
 699   (declare (ignore database db-type))
 700   val)
 701
 702 (defmethod read-sql-value (val (type (eql 'varchar)) database db-type)
 703   (declare (ignore database db-type))
 704   val)
 705
 706 (defmethod read-sql-value (val (type (eql 'char)) database db-type)
 707   (declare (ignore database db-type))
 708   (schar val 0))
 709
 710 (defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
 711   (declare (ignore database db-type))
 712   (when (< 0 (length val))
 713     (intern (symbol-name-default-case val)
 714             (find-package '#:keyword))))
 715
 716 (defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
 717   (declare (ignore database db-type))
 718   (when (< 0 (length val))
 719     (unless (string= val (symbol-name-default-case "NIL"))
 720       (read-from-string val))))
 721
 722 (defmethod read-sql-value (val (type (eql 'integer)) database db-type)
 723   (declare (ignore database db-type))
 724   (etypecase val
 725     (string
 726      (unless (string-equal "NIL" val)
 727        (parse-integer val)))
 728     (number val)))
 729
 730 (defmethod read-sql-value (val (type (eql 'smallint)) database db-type)
 731   (declare (ignore database db-type))
 732   (etypecase val
 733     (string
 734      (unless (string-equal "NIL" val)
 735        (parse-integer val)))
 736     (number val)))
 737
 738 (defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
 739   (declare (ignore database db-type))
 740   (etypecase val
 741     (string
 742      (unless (string-equal "NIL" val)
 743        (parse-integer val)))
 744     (number val)))
 745
 746 (defmethod read-sql-value (val (type (eql 'float)) database db-type)
 747   (declare (ignore database db-type))
 748   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 749   (etypecase val
 750     (string (float (read-from-string val)))
 751     (float val)))
 752
 753 (defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
 754   (declare (ignore database db-type))
 755   ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
 756   (etypecase val
 757     (string (float
 758              (let ((*read-default-float-format* 'double-float))
 759                (read-from-string val))
 760              1.0d0))
 761     (double-float val)
 762     (float (coerce val 'double-float))))
 763
 764 (defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
 765   (declare (ignore database db-type))
 766   (equal "t" val))
 767
 768 (defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type)
 769   (declare (ignore database db-type))
 770   (equal "t" val))
 771
 772 (defmethod read-sql-value (val (type (eql 'number)) database db-type)
 773   (declare (ignore database db-type))
 774   (etypecase val
 775     (string
 776      (unless (string-equal "NIL" val)
 777        (read-from-string val)))
 778     (number val)))
 779
 780 (defmethod read-sql-value (val (type (eql 'universal-time)) database db-type)
 781   (declare (ignore database db-type))
 782   (unless (eq 'NULL val)
 783     (etypecase val
 784       (string
 785        (parse-integer val))
 786       (number val))))
 787
 788 (defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
 789   (declare (ignore database db-type))
 790   (unless (eq 'NULL val)
 791     (parse-timestring val)))
 792
 793 (defmethod read-sql-value (val (type (eql 'date)) database db-type)
 794   (declare (ignore database db-type))
 795   (unless (eq 'NULL val)
 796     (parse-datestring val)))
 797
 798 (defmethod read-sql-value (val (type (eql 'duration)) database db-type)
 799   (declare (ignore database db-type))
 800   (unless (or (eq 'NULL val)
 801               (equal "NIL" val))
 802     (parse-timestring val)))
 803
 804 ;; ------------------------------------------------------------
 805 ;; Logic for 'faulting in' :join slots
 806
 807 ;; this works, but is inefficient requiring (+ 1 n-rows)
 808 ;; SQL queries
 809 #+ignore
 810 (defun fault-join-target-slot (class object slot-def)
 811   (let* ((res (fault-join-slot-raw class object slot-def))
 812          (dbi (view-class-slot-db-info slot-def))
 813          (target-name (gethash :target-slot dbi))
 814          (target-class (find-class target-name)))
 815     (when res
 816       (mapcar (lambda (obj)
 817                 (list
 818                  (car
 819                   (fault-join-slot-raw
 820                    target-class
 821                    obj
 822                    (find target-name (class-slots (class-of obj))
 823                          :key #'slot-definition-name)))
 824                  obj))
 825               res)
 826       #+ignore ;; this doesn't work when attempting to call slot-value
 827       (mapcar (lambda (obj)
 828                 (cons obj (slot-value obj ts))) res))))
 829
 830 (defun fault-join-target-slot (class object slot-def)
 831   (let* ((dbi (view-class-slot-db-info slot-def))
 832          (ts (gethash :target-slot dbi))
 833          (jc  (gethash :join-class dbi))
 834          (jc-view-table (view-table (find-class jc)))
 835          (tdbi (view-class-slot-db-info
 836                 (find ts (class-slots (find-class jc))
 837                       :key #'slot-definition-name)))
 838          (retrieval (gethash :retrieval tdbi))
 839          (tsc (gethash :join-class tdbi))
 840          (ts-view-table (view-table (find-class tsc)))
 841          (jq (join-qualifier class object slot-def))
 842          (key (slot-value object (gethash :home-key dbi))))
 843
 844     (when jq
 845       (ecase retrieval
 846         (:immediate
 847          (let ((res
 848                 (find-all (list tsc)
 849                           :inner-join (sql-expression :table jc-view-table)
 850                           :on (sql-operation
 851                                '==
 852                                (sql-expression
 853                                 :attribute (gethash :foreign-key tdbi)
 854                                 :table ts-view-table)
 855                                (sql-expression
 856                                 :attribute (gethash :home-key tdbi)
 857                                 :table jc-view-table))
 858                           :where jq
 859                           :result-types :auto
 860                           :database (choose-database-for-instance object))))
 861            (mapcar #'(lambda (i)
 862                        (let* ((instance (car i))
 863                               (jcc (make-instance jc :view-database (choose-database-for-instance instance))))
 864                          (setf (slot-value jcc (gethash :foreign-key dbi))
 865                                key)
 866                          (setf (slot-value jcc (gethash :home-key tdbi))
 867                                (slot-value instance (gethash :foreign-key tdbi)))
 868                          (list instance jcc)))
 869                    res)))
 870         (:deferred
 871          ;; just fill in minimal slots
 872          (mapcar
 873           #'(lambda (k)
 874               (let ((instance (make-instance tsc :view-database (choose-database-for-instance object)))
 875                     (jcc (make-instance jc :view-database (choose-database-for-instance object)))
 876                     (fk (car k)))
 877                 (setf (slot-value instance (gethash :home-key tdbi)) fk)
 878                 (setf (slot-value jcc (gethash :foreign-key dbi))
 879                       key)
 880                 (setf (slot-value jcc (gethash :home-key tdbi))
 881                       fk)
 882                 (list instance jcc)))
 883           (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
 884                   :from (sql-expression :table jc-view-table)
 885                   :where jq
 886                   :database (choose-database-for-instance object))))))))
 887
 888
 889 ;;; Remote Joins
 890
 891 (defvar *default-update-objects-max-len* nil
 892   "The default value to use for the MAX-LEN keyword argument to
 893   UPDATE-OBJECT-JOINS.")
 894
 895 (defun update-objects-joins (objects &key (slots t) (force-p t)
 896                              class-name (max-len
 897                                          *default-update-objects-max-len*))
 898   "Updates from the records of the appropriate database tables
 899 the join slots specified by SLOTS in the supplied list of View
 900 Class instances OBJECTS.  SLOTS is t by default which means that
 901 all join slots with :retrieval :immediate are updated. CLASS-NAME
 902 is used to specify the View Class of all instance in OBJECTS and
 903 default to nil which means that the class of the first instance
 904 in OBJECTS is used. FORCE-P is t by default which means that all
 905 join slots are updated whereas a value of nil means that only
 906 unbound join slots are updated. MAX-LEN defaults to
 907 *DEFAULT-UPDATE-OBJECTS-MAX-LEN* and when non-nil specifies that
 908 UPDATE-OBJECT-JOINS may issue multiple database queries with a
 909 maximum of MAX-LEN instances updated in each query."
 910   (assert (or (null max-len) (plusp max-len)))
 911   (when objects
 912     (unless class-name
 913       (setq class-name (class-name (class-of (first objects)))))
 914     (let* ((class (find-class class-name))
 915            (class-slots (ordered-class-slots class))
 916            (slotdefs
 917             (if (eq t slots)
 918                 (generate-retrieval-joins-list class :deferred)
 919                 (remove-if #'null
 920                            (mapcar #'(lambda (name)
 921                                        (let ((slotdef (find name class-slots :key #'slot-definition-name)))
 922                                          (unless slotdef
 923                                            (warn "Unable to find slot named ~S in class ~S." name class))
 924                                          slotdef))
 925                                    slots)))))
 926       (dolist (slotdef slotdefs)
 927         (let* ((dbi (view-class-slot-db-info slotdef))
 928                (slotdef-name (slot-definition-name slotdef))
 929                (foreign-key (gethash :foreign-key dbi))
 930                (home-key (gethash :home-key dbi))
 931                (object-keys
 932                 (remove-duplicates
 933                  (if force-p
 934                      (mapcar #'(lambda (o) (slot-value o home-key)) objects)
 935                      (remove-if #'null
 936                                 (mapcar
 937                                  #'(lambda (o) (if (slot-boundp o slotdef-name)
 938                                                    nil
 939                                                    (slot-value o home-key)))
 940                                  objects)))))
 941                (n-object-keys (length object-keys))
 942                (query-len (or max-len n-object-keys)))
 943
 944           (do ((i 0 (+ i query-len)))
 945               ((>= i n-object-keys))
 946             (let* ((keys (if max-len
 947                              (subseq object-keys i (min (+ i query-len) n-object-keys))
 948                              object-keys))
 949                    (results (unless (gethash :target-slot dbi)
 950                               (find-all (list (gethash :join-class dbi))
 951                                         :where (make-instance 'sql-relational-exp
 952                                                               :operator 'in
 953                                                               :sub-expressions (list (sql-expression :attribute foreign-key)
 954                                                                                      keys))
 955                                         :result-types :auto
 956                                         :flatp t)) ))
 957
 958               (dolist (object objects)
 959                 (when (or force-p (not (slot-boundp object slotdef-name)))
 960                   (let ((res (if results
 961                                  (remove-if-not #'(lambda (obj)
 962                                                     (equal obj (slot-value
 963                                                                 object
 964                                                                 home-key)))
 965                                                 results
 966                                                 :key #'(lambda (res)
 967                                                          (slot-value res
 968                                                                      foreign-key)))
 969
 970                                  (progn
 971                                    (when (gethash :target-slot dbi)
 972                                      (fault-join-target-slot class object slotdef))))))
 973                     (when res
 974                       (setf (slot-value object slotdef-name)
 975                             (if (gethash :set dbi) res (car res)))))))))))))
 976   (values))
 977
 978 (defun fault-join-slot-raw (class object slot-def)
 979   (let* ((dbi (view-class-slot-db-info slot-def))
 980          (jc (gethash :join-class dbi)))
 981     (let ((jq (join-qualifier class object slot-def)))
 982       (when jq
 983         (select jc :where jq :flatp t :result-types nil
 984                 :database (choose-database-for-instance object))))))
 985
 986
 987
 988 (defun fault-join-slot (class object slot-def)
 989   (let* ((dbi (view-class-slot-db-info slot-def))
 990          (ts (gethash :target-slot dbi))
 991          (dbi-set (gethash :set dbi)))
 992     (if (and ts dbi-set)
 993         (fault-join-target-slot class object slot-def)
 994         (let ((res (fault-join-slot-raw class object slot-def)))
 995           (when res
 996             (cond
 997               ((and ts (not dbi-set))
 998                (mapcar (lambda (obj) (slot-value obj ts)) res))
 999               ((and (not ts) (not dbi-set))
1000                (car res))
1001               ((and (not ts) dbi-set)
1002                res)))))))
1003
1004 (defun update-fault-join-normalized-slot (class object slot-def)
1005   (if (and (normalizedp class) (key-slot-p slot-def))
1006       (setf (easy-slot-value object slot-def)
1007             (normalized-key-value object))
1008       (update-slot-from-record object slot-def)))
1009
1010 (defun all-home-keys-have-values-p (object slot-def)
1011   "Do all of the home-keys have values ?"
1012   (let ((home-keys (join-slot-info-value slot-def :home-key)))
1013     (loop for key in (listify home-keys)
1014           always (easy-slot-value object key))))
1015
1016 (defun join-qualifier (class object slot-def)
1017   "Builds the join where clause based on the keys of the join slot and values
1018    of the object"
1019   (declare (ignore class))
1020   (let* ((jc (join-slot-class slot-def))
1021          ;;(ts (gethash :target-slot dbi))
1022          ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
1023          (foreign-keys (listify (join-slot-info-value slot-def :foreign-key)))
1024          (home-keys (listify (join-slot-info-value slot-def :home-key))))
1025     (when (all-home-keys-have-values-p object slot-def)
1026       (clsql-ands
1027        (loop for hk in home-keys
1028              for fk in foreign-keys
1029              for fksd = (slotdef-for-slot-with-class fk jc)
1030              for fk-sql = (typecase fk
1031                             (symbol
1032                              (sql-expression
1033                               :attribute (database-identifier fksd nil)
1034                               :table (database-identifier jc nil)))
1035                             (t fk))
1036              for hk-val = (typecase hk
1037                             ((or symbol
1038                                  view-class-effective-slot-definition
1039                                  view-class-direct-slot-definition)
1040                              (easy-slot-value object hk))
1041                             (t hk))
1042              collect (sql-operation '== fk-sql hk-val))))))
1043
1044 (defmethod select-table-sql-expr ((table T))
1045   "Turns an object representing a table into the :from part of the sql expression that will be executed "
1046   (sql-expression :table (view-table table)))
1047
1048 (defun select-reference-equal (r1 r2)
1049   "determines if two sql select references are equal
1050    using database identifier equal"
1051   (flet ((id-of (r)
1052            (etypecase r
1053              (cons (cdr r))
1054              (sql-ident-attribute r))))
1055     (database-identifier-equal (id-of r1) (id-of r2))))
1056
1057 (defun join-slot-qualifier (class join-slot)
1058   "Creates a sql-expression expressing the join between the home-key on the table
1059    and its respective key on the joined-to-table"
1060   (sql-operation
1061    '==
1062    (sql-expression
1063     :attribute (join-slot-info-value join-slot :foreign-key)
1064     :table (view-table (join-slot-class join-slot)))
1065    (sql-expression
1066     :attribute (join-slot-info-value join-slot :home-key)
1067     :table (view-table class))))
1068
1069 (defun all-immediate-join-classes-for (classes)
1070   "returns a list of all join-classes needed for a list of classes"
1071   (loop for class in (listify classes)
1072         appending (loop for slot in (immediate-join-slots class)
1073                         collect (join-slot-class slot))))
1074
1075 (defun %tables-for-query (classes from where inner-joins)
1076   "Given lists of classes froms wheres and inner-join compile a list
1077    of tables that should appear in the FROM section of the query.
1078
1079    This includes any immediate join classes from each of the classes"
1080   (let ((inner-join-tables (collect-table-refs (listify inner-joins))))
1081     (loop for tbl in (append
1082                       (mapcar #'select-table-sql-expr classes)
1083                       (mapcar #'select-table-sql-expr
1084                               (all-immediate-join-classes-for classes))
1085                       (collect-table-refs (listify where))
1086                       (collect-table-refs (listify from)))
1087           when (and tbl
1088                     (not (find tbl rtn :test #'database-identifier-equal))
1089                     ;; TODO: inner-join is currently hacky as can be
1090                     (not (find tbl inner-join-tables :test #'database-identifier-equal)))
1091           collect tbl into rtn
1092           finally (return rtn))))
1093
1094 (defun full-select-list ( classes )
1095   "Returns a list of sql-ref of things to select for the given classes
1096
1097    THIS NEEDS TO MATCH THE ORDER OF build-objects
1098
1099    TODO: this used to include order-by and distinct as more things to select.
1100     distinct seems to always be used in a boolean context, so it doesnt seem
1101     like appending it to the select makes any sense
1102
1103     We also used to remove duplicates, but that seems like it would make
1104     filling/building objects much more difficult so skipping for now...
1105   "
1106   (setf classes (mapcar #'to-class (listify classes)))
1107   (mapcar
1108    #'cdr
1109    (loop for class in classes
1110          appending (generate-selection-list class)
1111          appending
1112             (loop for join-slot in (immediate-join-slots class)
1113                   for join-class = (join-slot-class-name join-slot)
1114                   appending (generate-selection-list join-class)))))
1115
1116 (defun build-objects (classes row database &optional existing-instances)
1117   "Used by find-all to build objects.
1118
1119    THIS NEEDS TO MATCH THE ORDER OF FULL-SELECT-LIST
1120
1121    TODO: this caching scheme seems bad for a number of reasons
1122     * order is not guaranteed so references being held by one object
1123       might change to represent a different database row (seems HIGHLY
1124       suspect)
1125     * also join objects are overwritten rather than refreshed
1126
1127    TODO: the way we handle immediate joins seems only valid if it is a single
1128       object.  I suspect that making a :set :immediate join column would result
1129       in an invalid number of objects returned from the database, because there
1130       would be multiple rows per object, but we would return an object per row
1131    "
1132   (setf existing-instances (listify existing-instances))
1133   (loop for class in classes
1134         for existing = (pop existing-instances)
1135         for object = (or existing
1136                          (make-instance class :view-database database))
1137         do (loop for (slot . _) in (generate-selection-list class)
1138                  do (update-slot-from-db-value object slot (pop row)))
1139         do (loop for join-slot in (immediate-join-slots class)
1140                  for join-class = (join-slot-class-name join-slot)
1141                  for join-object =
1142                      (setf
1143                       (easy-slot-value object join-slot)
1144                       (make-instance join-class))
1145                  do (loop for (slot . _) in (generate-selection-list join-class)
1146                           do (update-slot-from-db-value join-object slot (pop row))))
1147         do (when existing (instance-refreshed object))
1148         collect object))
1149
1150 (defun find-all (view-classes
1151                  &rest args
1152                  &key all set-operation distinct from where group-by having
1153                  order-by offset limit refresh flatp result-types
1154                  inner-join on
1155                  (database *default-database*)
1156                  instances parameters)
1157   "Called by SELECT to generate object query results when the
1158   View Classes VIEW-CLASSES are passed as arguments to SELECT.
1159
1160    TODO: the caching scheme of passing in instances and overwriting their
1161          values seems bad for a number of reasons
1162     * order is not guaranteed so references being held by one object
1163       might change to represent a different database row (seems HIGHLY
1164       suspect)
1165
1166    TODO: the way we handle immediate joins seems only valid if it is a single
1167       object.  I suspect that making a :set :immediate join column would result
1168       in an invalid number of objects returned from the database, because there
1169       would be multiple objects returned from the database
1170   "
1171   (declare (ignore all set-operation group-by having offset limit on parameters
1172                    distinct order-by)
1173            (dynamic-extent args))
1174   (let* ((args (filter-plist
1175                 args :from :where :flatp :additional-fields :result-types :instances))
1176          (*db-deserializing* t)
1177          (sclasses (mapcar #'to-class view-classes))
1178          (tables (%tables-for-query sclasses from where inner-join))
1179          (join-where
1180            (loop for class in sclasses
1181                  appending (loop for slot in (immediate-join-slots class)
1182                                  collect (join-slot-qualifier class slot))))
1183          (full-select-list (full-select-list sclasses))
1184          (where (clsql-ands (append (listify where) (listify join-where))))
1185          #|
1186           (_ (format t "~&sclasses: ~W~%ijc: ~W~%tables: ~W~%"
1187                     sclasses immediate-join-classes tables))
1188          |#
1189          (rows (apply #'select
1190                       (append full-select-list
1191                               (list :from tables
1192                                     :result-types result-types
1193                                     :where where)
1194                               args)))
1195          (return-objects
1196            (loop for row in rows
1197                  for old-objs = (pop instances)
1198                  for objs = (build-objects sclasses row database
1199                                            (when refresh old-objs))
1200                  collecting (if flatp
1201                                 (delist-if-single objs)
1202                                 objs))))
1203     return-objects))
1204
1205 (defmethod instance-refreshed ((instance standard-db-object)))
1206
1207 (defvar *default-caching* t
1208   "Controls whether SELECT caches objects by default. The CommonSQL
1209 specification states caching is on by default.")
1210
1211 (defun select (&rest select-all-args)
1212   "Executes a query on DATABASE, which has a default value of
1213 *DEFAULT-DATABASE*, specified by the SQL expressions supplied
1214 using the remaining arguments in SELECT-ALL-ARGS. The SELECT
1215 argument can be used to generate queries in both functional and
1216 object oriented contexts.
1217
1218 In the functional case, the required arguments specify the
1219 columns selected by the query and may be symbolic SQL expressions
1220 or strings representing attribute identifiers. Type modified
1221 identifiers indicate that the values selected from the specified
1222 column are converted to the specified lisp type. The keyword
1223 arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY,
1224 SET-OPERATION and WHERE are used to specify, using the symbolic
1225 SQL syntax, the corresponding components of the SQL query
1226 generated by the call to SELECT. RESULT-TYPES is a list of
1227 symbols which specifies the lisp type for each field returned by
1228 the query. If RESULT-TYPES is nil all results are returned as
1229 strings whereas the default value of :auto means that the lisp
1230 types are automatically computed for each field. FIELD-NAMES is t
1231 by default which means that the second value returned is a list
1232 of strings representing the columns selected by the query. If
1233 FIELD-NAMES is nil, the list of column names is not returned as a
1234 second value.
1235
1236 In the object oriented case, the required arguments to SELECT are
1237 symbols denoting View Classes which specify the database tables
1238 to query. In this case, SELECT returns a list of View Class
1239 instances whose slots are set from the attribute values of the
1240 records in the specified table. Slot-value is a legal operator
1241 which can be employed as part of the symbolic SQL syntax used in
1242 the WHERE keyword argument to SELECT. REFRESH is nil by default
1243 which means that the View Class instances returned are retrieved
1244 from a cache if an equivalent call to SELECT has previously been
1245 issued. If REFRESH is true, the View Class instances returned are
1246 updated as necessary from the database and the generic function
1247 INSTANCE-REFRESHED is called to perform any necessary operations
1248 on the updated instances.
1249
1250 In both object oriented and functional contexts, FLATP has a
1251 default value of nil which means that the results are returned as
1252 a list of lists. If FLATP is t and only one result is returned
1253 for each record selected in the query, the results are returned
1254 as elements of a list."
1255   (multiple-value-bind (target-args qualifier-args)
1256       (query-get-selections select-all-args)
1257     (unless (or *default-database* (getf qualifier-args :database))
1258       (signal-no-database-error nil))
1259
1260     (let ((caching (getf qualifier-args :caching *default-caching*))
1261           (result-types (getf qualifier-args :result-types :auto))
1262           (refresh (getf qualifier-args :refresh nil))
1263           (database (getf qualifier-args :database *default-database*)))
1264
1265       (cond
1266         ((and target-args
1267               (every #'(lambda (arg)
1268                          (and (symbolp arg)
1269                               (find-class arg nil)))
1270                      target-args))
1271
1272          (setf qualifier-args (filter-plist qualifier-args :caching :refresh :result-types))
1273
1274          ;; Add explicity table name to order-by if not specified and only
1275          ;; one selected table. This is required so FIND-ALL won't duplicate
1276          ;; the field
1277          (let ((order-by (getf qualifier-args :order-by)))
1278            (when (and order-by (= 1 (length target-args)))
1279              (let ((table-name (view-table (find-class (car target-args))))
1280                    (order-by-list (copy-seq (listify order-by))))
1281                (labels ((sv (val name) (ignore-errors (slot-value val name)))
1282                         (set-table-if-needed (val)
1283                           (typecase val
1284                             (sql-ident-attribute
1285                              (handler-case
1286                                  (if (sv val 'qualifier)
1287                                      val
1288                                      (make-instance 'sql-ident-attribute
1289                                                     :name (sv val 'name)
1290                                                     :qualifier table-name))
1291                                (simple-error ()
1292                                  ;; TODO: Check for a specific error we expect
1293                                  )))
1294                             (cons (cons (set-table-if-needed (car val))
1295                                         (cdr val)))
1296                             (t val))))
1297                  (setf order-by-list
1298                        (loop for i from 0 below (length order-by-list)
1299                              for id in order-by-list
1300                              collect (set-table-if-needed id))))
1301                (setf (getf qualifier-args :order-by) order-by-list))))
1302
1303          (cond
1304            ((null caching)
1305             (apply #'find-all target-args :result-types result-types :refresh refresh qualifier-args))
1306            (t
1307             (let ((cached (records-cache-results target-args qualifier-args database)))
1308               (if (and cached (not refresh))
1309                   cached
1310                   (let ((results (apply #'find-all target-args
1311                                         :result-types :auto :refresh refresh
1312                                         :instances cached
1313                                         qualifier-args)))
1314                     (setf (records-cache-results target-args qualifier-args database) results)
1315
1316                     results))))))
1317         (t
1318          (let* ((expr (apply #'make-query select-all-args))
1319                 (parameters (second (member :parameters select-all-args)))
1320                 (specified-types
1321                   (mapcar #'(lambda (attrib)
1322                               (if (typep attrib 'sql-ident-attribute)
1323                                   (let ((type (slot-value attrib 'type)))
1324                                     (if type
1325                                         type
1326                                         t))
1327                                   t))
1328                           (slot-value expr 'selections)))
1329                 (flatp (getf qualifier-args :flatp))
1330                 (field-names (getf qualifier-args :field-names t)))
1331
1332            (when parameters
1333              (setf expr (command-object (sql-output expr database) parameters)))
1334            (query expr :flatp flatp
1335                        :result-types
1336                        ;; specifying a type for an attribute overrides result-types
1337                        (if (some #'(lambda (x) (not (eq t x))) specified-types)
1338                            specified-types
1339                            result-types)
1340                        :field-names field-names
1341                        :database database)))))))
1342
1343 (defun compute-records-cache-key (targets qualifiers)
1344   (list targets
1345         (do ((args *select-arguments* (cdr args))
1346              (results nil))
1347             ((null args) results)
1348           (let* ((arg (car args))
1349                  (value (getf qualifiers arg)))
1350             (when value
1351               (push (list arg
1352                           (typecase value
1353                             (cons (cons (sql (car value)) (cdr value)))
1354                             (%sql-expression (sql value))
1355                             (t value)))
1356                     results))))))
1357
1358 (defun records-cache-results (targets qualifiers database)
1359   (when (record-caches database)
1360     (gethash (compute-records-cache-key targets qualifiers) (record-caches database))))
1361
1362 (defun (setf records-cache-results) (results targets qualifiers database)
1363   (unless (record-caches database)
1364     (setf (record-caches database)
1365           (make-weak-hash-table :test 'equal)))
1366   (setf (gethash (compute-records-cache-key (copy-list targets) qualifiers)
1367                  (record-caches database)) results)
1368   results)
1369
1370
1371
1372 ;;; Serialization functions
1373
1374 (defun write-instance-to-stream (obj stream)
1375   "Writes an instance to a stream where it can be later be read.
1376 NOTE: an error will occur if a slot holds a value which can not be written readably."
1377   (let* ((class (class-of obj))
1378          (alist '()))
1379     (dolist (slot (ordered-class-slots (class-of obj)))
1380       (let ((name (slot-definition-name slot)))
1381         (when (and (not (eq 'view-database name))
1382                    (slot-boundp obj name))
1383           (push (cons name (slot-value obj name)) alist))))
1384     (setq alist (reverse alist))
1385     (write (cons (class-name class) alist) :stream stream :readably t))
1386   obj)
1387
1388 (defun read-instance-from-stream (stream)
1389   (let ((raw (read stream nil nil)))
1390     (when raw
1391       (let ((obj (make-instance (car raw))))
1392         (dolist (pair (cdr raw))
1393           (setf (slot-value obj (car pair)) (cdr pair)))
1394         obj))))