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