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