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