sql/oodml.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
   7 ;;;;
   8 ;;;; This file is part of CLSQL.
   9 ;;;;
  10 ;;;; CLSQL users are granted the rights to distribute and use this software
  11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  13 ;;;; *************************************************************************
  14
  15 (in-package #:clsql-sys)
  16
  17
  18 (defun key-qualifier-for-instance (obj &key (database *default-database*))
  19   (let ((tb (view-table (class-of obj))))
  20     (flet ((qfk (k)
  21              (sql-operation '==
  22                             (sql-expression :attribute
  23                                             (view-class-slot-column k)
  24                                             :table tb)
  25                             (db-value-from-slot
  26                              k
  27                              (slot-value obj (slot-definition-name k))
  28                              database))))
  29       (let* ((keys (keyslots-for-class (class-of obj)))
  30              (keyxprs (mapcar #'qfk (reverse keys))))
  31         (cond
  32           ((= (length keyxprs) 0) nil)
  33           ((= (length keyxprs) 1) (car keyxprs))
  34           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
  35
  36 ;;
  37 ;; Function used by 'generate-selection-list'
  38 ;;
  39
  40 (defun generate-attribute-reference (vclass slotdef)
  41   (cond
  42    ((eq (view-class-slot-db-kind slotdef) :base)
  43     (sql-expression :attribute (view-class-slot-column slotdef)
  44                     :table (view-table vclass)))
  45    ((eq (view-class-slot-db-kind slotdef) :key)
  46     (sql-expression :attribute (view-class-slot-column slotdef)
  47                     :table (view-table vclass)))
  48    (t nil)))
  49
  50 ;;
  51 ;; Function used by 'find-all'
  52 ;;
  53
  54 (defun generate-selection-list (vclass)
  55   (let ((sels nil))
  56     (dolist (slotdef (ordered-class-slots vclass))
  57       (let ((res (generate-attribute-reference vclass slotdef)))
  58         (when res
  59           (push (cons slotdef res) sels))))
  60     (if sels
  61         sels
  62         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
  63
  64
  65
  66 (defun generate-retrieval-joins-list (vclass retrieval-method)
  67   "Returns list of immediate join slots for a class."
  68   (let ((join-slotdefs nil))
  69     (dolist (slotdef (ordered-class-slots vclass) join-slotdefs)
  70       (when (and (eq :join (view-class-slot-db-kind slotdef))
  71                  (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
  72         (push slotdef join-slotdefs)))))
  73
  74 (defun generate-immediate-joins-selection-list (vclass)
  75   "Returns list of immediate join slots for a class."
  76   (let (sels)
  77     (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels)
  78       (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot)))
  79              (join-class (when join-class-name (find-class join-class-name))))
  80         (dolist (slotdef (ordered-class-slots join-class))
  81           (let ((res (generate-attribute-reference join-class slotdef)))
  82             (when res
  83               (push (cons slotdef res) sels))))))
  84     sels))
  85
  86
  87 ;; Called by 'get-slot-values-from-view'
  88 ;;
  89
  90 (defvar *update-context* nil)
  91
  92 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
  93   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
  94   (let* ((slot-reader (view-class-slot-db-reader slotdef))
  95          (slot-name   (slot-definition-name slotdef))
  96          (slot-type   (specified-type slotdef))
  97          (*update-context* (cons (type-of instance) slot-name)))
  98     (cond ((and value (null slot-reader))
  99            (setf (slot-value instance slot-name)
 100                  (read-sql-value value (delistify slot-type)
 101                                  (view-database instance)
 102                                  (database-underlying-type
 103                                   (view-database instance)))))
 104           ((null value)
 105            (update-slot-with-null instance slot-name slotdef))
 106           ((typep slot-reader 'string)
 107            (setf (slot-value instance slot-name)
 108                  (format nil slot-reader value)))
 109           ((typep slot-reader 'function)
 110            (setf (slot-value instance slot-name)
 111                  (apply slot-reader (list value))))
 112           (t
 113            (error "Slot reader is of an unusual type.")))))
 114
 115 (defmethod key-value-from-db (slotdef value database)
 116   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 117   (let ((slot-reader (view-class-slot-db-reader slotdef))
 118         (slot-type (specified-type slotdef)))
 119     (cond ((and value (null slot-reader))
 120            (read-sql-value value (delistify slot-type) database
 121                            (database-underlying-type database)))
 122           ((null value)
 123            nil)
 124           ((typep slot-reader 'string)
 125            (format nil slot-reader value))
 126           ((typep slot-reader 'function)
 127            (apply slot-reader (list value)))
 128           (t
 129            (error "Slot reader is of an unusual type.")))))
 130
 131 (defun db-value-from-slot (slotdef val database)
 132   (let ((dbwriter (view-class-slot-db-writer slotdef))
 133         (dbtype (specified-type slotdef)))
 134     (typecase dbwriter
 135       (string (format nil dbwriter val))
 136       (function (apply dbwriter (list val)))
 137       (t
 138        (database-output-sql-as-type
 139         (typecase dbtype
 140           (cons (car dbtype))
 141           (t dbtype))
 142         val database (database-underlying-type database))))))
 143
 144 (defun check-slot-type (slotdef val)
 145   (let* ((slot-type (specified-type slotdef))
 146          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 147     (when (and slot-type val)
 148       (unless (typep val basetype)
 149         (error 'sql-user-error
 150                :message
 151                (format nil "Invalid value ~A in slot ~A, not of type ~A."
 152                        val (slot-definition-name slotdef) slot-type))))))
 153
 154 ;;
 155 ;; Called by find-all
 156 ;;
 157
 158 (defmethod get-slot-values-from-view (obj slotdeflist values)
 159     (flet ((update-slot (slot-def values)
 160              (update-slot-from-db obj slot-def values)))
 161       (mapc #'update-slot slotdeflist values)
 162       obj))
 163
 164 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 165                                     (database *default-database*))
 166   (let* ((database (or (view-database obj) database))
 167          (vct (view-table (class-of obj)))
 168          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 169     (check-slot-type sd (slot-value obj slot))
 170     (let* ((att (view-class-slot-column sd))
 171            (val (db-value-from-slot sd (slot-value obj slot) database)))
 172       (cond ((and vct sd (view-database obj))
 173              (update-records (sql-expression :table vct)
 174                              :attributes (list (sql-expression :attribute att))
 175                              :values (list val)
 176                              :where (key-qualifier-for-instance
 177                                      obj :database database)
 178                              :database database))
 179             ((and vct sd (not (view-database obj)))
 180              (insert-records :into (sql-expression :table vct)
 181                              :attributes (list (sql-expression :attribute att))
 182                              :values (list val)
 183                              :database database)
 184              (setf (slot-value obj 'view-database) database))
 185             (t
 186              (error "Unable to update record.")))))
 187   (values))
 188
 189 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 190                                      (database *default-database*))
 191   (let* ((database (or (view-database obj) database))
 192          (vct (view-table (class-of obj)))
 193          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 194          (avps (mapcar #'(lambda (s)
 195                            (let ((val (slot-value
 196                                        obj (slot-definition-name s))))
 197                              (check-slot-type s val)
 198                              (list (sql-expression
 199                                     :attribute (view-class-slot-column s))
 200                                    (db-value-from-slot s val database))))
 201                        sds)))
 202     (cond ((and avps (view-database obj))
 203            (update-records (sql-expression :table vct)
 204                            :av-pairs avps
 205                            :where (key-qualifier-for-instance
 206                                    obj :database database)
 207                            :database database))
 208           ((and avps (not (view-database obj)))
 209            (insert-records :into (sql-expression :table vct)
 210                            :av-pairs avps
 211                            :database database)
 212            (setf (slot-value obj 'view-database) database))
 213           (t
 214            (error "Unable to update records"))))
 215   (values))
 216
 217 (defmethod update-records-from-instance ((obj standard-db-object)
 218                                          &key (database *default-database*))
 219   (let ((database (or (view-database obj) database)))
 220     (labels ((slot-storedp (slot)
 221                (and (member (view-class-slot-db-kind slot) '(:base :key))
 222                     (slot-boundp obj (slot-definition-name slot))))
 223              (slot-value-list (slot)
 224                (let ((value (slot-value obj (slot-definition-name slot))))
 225                  (check-slot-type slot value)
 226                  (list (sql-expression :attribute (view-class-slot-column slot))
 227                        (db-value-from-slot slot value database)))))
 228       (let* ((view-class (class-of obj))
 229              (view-class-table (view-table view-class))
 230              (slots (remove-if-not #'slot-storedp
 231                                    (ordered-class-slots view-class)))
 232              (record-values (mapcar #'slot-value-list slots)))
 233         (unless record-values
 234           (error "No settable slots."))
 235         (if (view-database obj)
 236             (update-records (sql-expression :table view-class-table)
 237                             :av-pairs record-values
 238                             :where (key-qualifier-for-instance
 239                                     obj :database database)
 240                             :database database)
 241             (progn
 242               (insert-records :into (sql-expression :table view-class-table)
 243                               :av-pairs record-values
 244                               :database database)
 245               (setf (slot-value obj 'view-database) database))))))
 246   (values))
 247
 248 (defmethod delete-instance-records ((instance standard-db-object))
 249   (let ((vt (sql-expression :table (view-table (class-of instance))))
 250         (vd (view-database instance)))
 251     (if vd
 252         (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 253           (delete-records :from vt :where qualifier :database vd)
 254           (setf (slot-value instance 'view-database) nil))
 255         (signal-no-database-error vd))))
 256
 257 (defmethod update-instance-from-records ((instance standard-db-object)
 258                                          &key (database *default-database*))
 259   (let* ((view-class (find-class (class-name (class-of instance))))
 260          (view-table (sql-expression :table (view-table view-class)))
 261          (vd (or (view-database instance) database))
 262          (view-qual (key-qualifier-for-instance instance :database vd))
 263          (sels (generate-selection-list view-class))
 264          (res (apply #'select (append (mapcar #'cdr sels)
 265                                       (list :from  view-table
 266                                             :where view-qual)
 267                                       (list :result-types nil)))))
 268     (when res
 269       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 270
 271 (defmethod update-slot-from-record ((instance standard-db-object)
 272                                     slot &key (database *default-database*))
 273   (let* ((view-class (find-class (class-name (class-of instance))))
 274          (view-table (sql-expression :table (view-table view-class)))
 275          (vd (or (view-database instance) database))
 276          (view-qual (key-qualifier-for-instance instance :database vd))
 277          (slot-def (slotdef-for-slot-with-class slot view-class))
 278          (att-ref (generate-attribute-reference view-class slot-def))
 279          (res (select att-ref :from  view-table :where view-qual
 280                       :result-types nil)))
 281     (when res
 282       (get-slot-values-from-view instance (list slot-def) (car res)))))
 283
 284
 285 (defmethod update-slot-with-null ((object standard-db-object)
 286                                   slotname
 287                                   slotdef)
 288   (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 289
 290 (defvar +no-slot-value+ '+no-slot-value+)
 291
 292 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 293   (let* ((class (find-class classname))
 294          (sld (slotdef-for-slot-with-class slot class)))
 295     (if sld
 296         (if (eq value +no-slot-value+)
 297             (sql-expression :attribute (view-class-slot-column sld)
 298                             :table (view-table class))
 299             (db-value-from-slot
 300              sld
 301              value
 302              database))
 303         (error "Unknown slot ~A for class ~A" slot classname))))
 304
 305 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 306         (declare (ignore database))
 307         (let* ((class (find-class classname)))
 308           (unless (view-table class)
 309             (error "No view-table for class ~A"  classname))
 310           (sql-expression :table (view-table class))))
 311
 312 (defmethod database-get-type-specifier (type args database db-type)
 313   (declare (ignore type args database db-type))
 314   "VARCHAR(255)")
 315
 316 (defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
 317   (declare (ignore database db-type))
 318   (if args
 319       (format nil "INT(~A)" (car args))
 320       "INT"))
 321
 322 (deftype bigint ()
 323   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
 324   'integer)
 325
 326 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
 327   (declare (ignore args database db-type))
 328   "BIGINT")
 329
 330 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 331                                         database db-type)
 332   (declare (ignore database db-type))
 333   (if args
 334       (format nil "VARCHAR(~A)" (car args))
 335       "VARCHAR(255)"))
 336
 337 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 338                                         database db-type)
 339   (declare (ignore database db-type))
 340   (if args
 341       (format nil "VARCHAR(~A)" (car args))
 342       "VARCHAR(255)"))
 343
 344 (defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
 345   (declare (ignore database db-type))
 346   (if args
 347       (format nil "VARCHAR(~A)" (car args))
 348       "VARCHAR(255)"))
 349
 350 (deftype universal-time ()
 351   "A positive integer as returned by GET-UNIVERSAL-TIME."
 352   '(integer 1 *))
 353
 354 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
 355   (declare (ignore args database db-type))
 356   "BIGINT")
 357
 358 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
 359   (declare (ignore args database db-type))
 360   "TIMESTAMP")
 361
 362 (defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
 363   (declare (ignore database args db-type))
 364   "VARCHAR")
 365
 366 (defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
 367   (declare (ignore database args db-type))
 368   "INT8")
 369
 370 #+ignore
 371 (deftype char (&optional len)
 372   "A lisp type for the SQL CHAR type."
 373   `(string ,len))
 374
 375 (defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
 376   (declare (ignore database db-type))
 377   (if args
 378       (format nil "FLOAT(~A)" (car args))
 379       "FLOAT"))
 380
 381 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
 382   (declare (ignore database db-type))
 383   (if args
 384       (format nil "FLOAT(~A)" (car args))
 385       "FLOAT"))
 386
 387 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
 388   (declare (ignore args database db-type))
 389   "BOOL")
 390
 391 (defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
 392   (declare (ignore database db-type))
 393   (cond
 394    ((and (consp args) (= (length args) 2))
 395     (format nil "NUMBER(~D,~D)" (first args) (second args)))
 396    ((and (consp args) (= (length args) 1))
 397     (format nil "NUMBER(~D)" (first args)))
 398    (t
 399     "NUMBER")))
 400
 401 (defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
 402   (declare (ignore database db-type))
 403   (if args
 404       (format nil "CHAR(~D)" (first args))
 405     "CHAR"))
 406
 407
 408 (defmethod database-output-sql-as-type (type val database db-type)
 409   (declare (ignore type database db-type))
 410   val)
 411
 412 (defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
 413   (declare (ignore database db-type))
 414   (progv '(*print-circle* *print-array*) '(t t)
 415     (let ((escaped (prin1-to-string val)))
 416       (substitute-char-string
 417        escaped #\Null " "))))
 418
 419 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
 420   (declare (ignore database db-type))
 421   (if (keywordp val)
 422       (symbol-name val)
 423       (if val
 424           (concatenate 'string
 425                        (package-name (symbol-package val))
 426                        "::"
 427                        (symbol-name val))
 428           "")))
 429
 430 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
 431   (declare (ignore database db-type))
 432   (if val
 433       (symbol-name val)
 434       ""))
 435
 436 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
 437   (declare (ignore database db-type))
 438   (progv '(*print-circle* *print-array*) '(t t)
 439     (prin1-to-string val)))
 440
 441 (defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
 442   (declare (ignore database db-type))
 443   (progv '(*print-circle* *print-array*) '(t t)
 444     (prin1-to-string val)))
 445
 446 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
 447   (declare (ignore database db-type))
 448   (if val "t" "f"))
 449
 450 (defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
 451   (declare (ignore database db-type))
 452   val)
 453
 454 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 455                                         val database db-type)
 456   (declare (ignore database db-type))
 457   val)
 458
 459 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 460                                         val database db-type)
 461   (declare (ignore database db-type))
 462   val)
 463
 464 (defmethod read-sql-value (val type database db-type)
 465   (declare (ignore type database db-type))
 466   (read-from-string val))
 467
 468 (defmethod read-sql-value (val (type (eql 'string)) database db-type)
 469   (declare (ignore database db-type))
 470   val)
 471
 472 (defmethod read-sql-value (val (type (eql 'simple-string)) database db-type)
 473   (declare (ignore database db-type))
 474   val)
 475
 476 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type)
 477   (declare (ignore database db-type))
 478   val)
 479
 480 (defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
 481   (declare (ignore database db-type))
 482   (when (< 0 (length val))
 483     (intern (symbol-name-default-case val)
 484             (find-package '#:keyword))))
 485
 486 (defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
 487   (declare (ignore database db-type))
 488   (when (< 0 (length val))
 489     (unless (string= val (symbol-name-default-case "NIL"))
 490       (intern (symbol-name-default-case val)
 491               (symbol-package *update-context*)))))
 492
 493 (defmethod read-sql-value (val (type (eql 'integer)) database db-type)
 494   (declare (ignore database db-type))
 495   (etypecase val
 496     (string
 497      (unless (string-equal "NIL" val)
 498        (parse-integer val)))
 499     (number val)))
 500
 501 (defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
 502   (declare (ignore database db-type))
 503   (etypecase val
 504     (string
 505      (unless (string-equal "NIL" val)
 506        (parse-integer val)))
 507     (number val)))
 508
 509 (defmethod read-sql-value (val (type (eql 'float)) database db-type)
 510   (declare (ignore database db-type))
 511   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 512   (etypecase val
 513     (string
 514      (float (read-from-string val)))
 515     (float
 516      val)))
 517
 518 (defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
 519   (declare (ignore database db-type))
 520   (equal "t" val))
 521
 522 (defmethod read-sql-value (val (type (eql 'number)) database db-type)
 523   (declare (ignore database db-type))
 524   (etypecase val
 525     (string
 526      (unless (string-equal "NIL" val)
 527        (read-from-string val)))
 528     (number val)))
 529
 530 (defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type)
 531   (declare (ignore database db-type))
 532   (unless (eq 'NULL val)
 533     (etypecase val
 534       (string
 535        (parse-integer val))
 536       (number val))))
 537
 538 (defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
 539   (declare (ignore database db-type))
 540   (unless (eq 'NULL val)
 541     (parse-timestring val)))
 542
 543 (defmethod read-sql-value (val (type (eql 'duration)) database db-type)
 544   (declare (ignore database db-type))
 545   (unless (or (eq 'NULL val)
 546               (equal "NIL" val))
 547     (parse-timestring val)))
 548
 549 ;; ------------------------------------------------------------
 550 ;; Logic for 'faulting in' :join slots
 551
 552 ;; this works, but is inefficient requiring (+ 1 n-rows)
 553 ;; SQL queries
 554 #+ignore
 555 (defun fault-join-target-slot (class object slot-def)
 556   (let* ((res (fault-join-slot-raw class object slot-def))
 557          (dbi (view-class-slot-db-info slot-def))
 558          (target-name (gethash :target-slot dbi))
 559          (target-class (find-class target-name)))
 560     (when res
 561       (mapcar (lambda (obj)
 562                 (list
 563                  (car
 564                   (fault-join-slot-raw
 565                    target-class
 566                    obj
 567                    (find target-name (class-slots (class-of obj))
 568                          :key #'slot-definition-name)))
 569                  obj))
 570               res)
 571       #+ignore ;; this doesn't work when attempting to call slot-value
 572       (mapcar (lambda (obj)
 573                 (cons obj (slot-value obj ts))) res))))
 574
 575 (defun fault-join-target-slot (class object slot-def)
 576   (let* ((dbi (view-class-slot-db-info slot-def))
 577          (ts (gethash :target-slot dbi))
 578          (jc (gethash :join-class dbi))
 579          (ts-view-table (view-table (find-class ts)))
 580          (jc-view-table (view-table (find-class jc)))
 581          (tdbi (view-class-slot-db-info
 582                 (find ts (class-slots (find-class jc))
 583                       :key #'slot-definition-name)))
 584          (retrieval (gethash :retrieval tdbi))
 585          (jq (join-qualifier class object slot-def))
 586          (key (slot-value object (gethash :home-key dbi))))
 587     (when jq
 588       (ecase retrieval
 589         (:immediate
 590          (let ((res
 591                 (find-all (list ts)
 592                           :inner-join (sql-expression :table jc-view-table)
 593                           :on (sql-operation
 594                                '==
 595                                (sql-expression
 596                                 :attribute (gethash :foreign-key tdbi)
 597                                 :table ts-view-table)
 598                                (sql-expression
 599                                 :attribute (gethash :home-key tdbi)
 600                                 :table jc-view-table))
 601                           :where jq
 602                           :result-types :auto)))
 603            (mapcar #'(lambda (i)
 604                        (let* ((instance (car i))
 605                               (jcc (make-instance jc :view-database (view-database instance))))
 606                          (setf (slot-value jcc (gethash :foreign-key dbi))
 607                                key)
 608                          (setf (slot-value jcc (gethash :home-key tdbi))
 609                                (slot-value instance (gethash :foreign-key tdbi)))
 610                       (list instance jcc)))
 611                    res)))
 612         (:deferred
 613             ;; just fill in minimal slots
 614             (mapcar
 615              #'(lambda (k)
 616                  (let ((instance (make-instance ts :view-database (view-database object)))
 617                        (jcc (make-instance jc :view-database (view-database object)))
 618                        (fk (car k)))
 619                    (setf (slot-value instance (gethash :home-key tdbi)) fk)
 620                    (setf (slot-value jcc (gethash :foreign-key dbi))
 621                          key)
 622                    (setf (slot-value jcc (gethash :home-key tdbi))
 623                          fk)
 624                    (list instance jcc)))
 625              (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
 626                      :from (sql-expression :table jc-view-table)
 627                      :where jq)))))))
 628
 629
 630 ;;; Remote Joins
 631
 632 (defvar *default-update-objects-max-len* nil
 633   "The default value to use for the MAX-LEN keyword argument to
 634   UPDATE-OBJECT-JOINS.")
 635
 636 (defun update-objects-joins (objects &key (slots t) (force-p t)
 637                             class-name (max-len
 638                             *default-update-objects-max-len*))
 639   "Updates from the records of the appropriate database tables
 640 the join slots specified by SLOTS in the supplied list of View
 641 Class instances OBJECTS.  SLOTS is t by default which means that
 642 all join slots with :retrieval :immediate are updated. CLASS-NAME
 643 is used to specify the View Class of all instance in OBJECTS and
 644 default to nil which means that the class of the first instance
 645 in OBJECTS is used. FORCE-P is t by default which means that all
 646 join slots are updated whereas a value of nil means that only
 647 unbound join slots are updated. MAX-LEN defaults to
 648 *DEFAULT-UPDATE-OBJECTS-MAX-LEN* and when non-nil specifies that
 649 UPDATE-OBJECT-JOINS may issue multiple database queries with a
 650 maximum of MAX-LEN instances updated in each query."
 651   (assert (or (null max-len) (plusp max-len)))
 652   (when objects
 653     (unless class-name
 654       (setq class-name (class-name (class-of (first objects)))))
 655     (let* ((class (find-class class-name))
 656            (class-slots (ordered-class-slots class))
 657            (slotdefs
 658             (if (eq t slots)
 659                 (generate-retrieval-joins-list class :deferred)
 660               (remove-if #'null
 661                          (mapcar #'(lambda (name)
 662                                      (let ((slotdef (find name class-slots :key #'slot-definition-name)))
 663                                        (unless slotdef
 664                                          (warn "Unable to find slot named ~S in class ~S." name class))
 665                                        slotdef))
 666                                  slots)))))
 667       (dolist (slotdef slotdefs)
 668         (let* ((dbi (view-class-slot-db-info slotdef))
 669                (slotdef-name (slot-definition-name slotdef))
 670                (foreign-key (gethash :foreign-key dbi))
 671                (home-key (gethash :home-key dbi))
 672                (object-keys
 673                 (remove-duplicates
 674                  (if force-p
 675                      (mapcar #'(lambda (o) (slot-value o home-key)) objects)
 676                    (remove-if #'null
 677                               (mapcar
 678                                #'(lambda (o) (if (slot-boundp o slotdef-name)
 679                                                  nil
 680                                                (slot-value o home-key)))
 681                                objects)))))
 682                (n-object-keys (length object-keys))
 683                (query-len (or max-len n-object-keys)))
 684
 685           (do ((i 0 (+ i query-len)))
 686               ((>= i n-object-keys))
 687             (let* ((keys (if max-len
 688                              (subseq object-keys i (min (+ i query-len) n-object-keys))
 689                            object-keys))
 690                    (results (find-all (list (gethash :join-class dbi))
 691                                       :where (make-instance 'sql-relational-exp
 692                                                :operator 'in
 693                                                :sub-expressions (list (sql-expression :attribute foreign-key)
 694                                                                       keys))
 695                                       :result-types :auto
 696                                       :flatp t)))
 697               (dolist (object objects)
 698                 (when (or force-p (not (slot-boundp object slotdef-name)))
 699                   (let ((res (find (slot-value object home-key) results
 700                                    :key #'(lambda (res) (slot-value res foreign-key))
 701                                    :test #'equal)))
 702                     (when res
 703                       (setf (slot-value object slotdef-name) res)))))))))))
 704   (values))
 705
 706 (defun fault-join-slot-raw (class object slot-def)
 707   (let* ((dbi (view-class-slot-db-info slot-def))
 708          (jc (gethash :join-class dbi)))
 709     (let ((jq (join-qualifier class object slot-def)))
 710       (when jq
 711         (select jc :where jq :flatp t :result-types nil)))))
 712
 713 (defun fault-join-slot (class object slot-def)
 714   (let* ((dbi (view-class-slot-db-info slot-def))
 715          (ts (gethash :target-slot dbi)))
 716     (if (and ts (gethash :set dbi))
 717         (fault-join-target-slot class object slot-def)
 718         (let ((res (fault-join-slot-raw class object slot-def)))
 719           (when res
 720             (cond
 721               ((and ts (not (gethash :set dbi)))
 722                (mapcar (lambda (obj) (slot-value obj ts)) res))
 723               ((and (not ts) (not (gethash :set dbi)))
 724                (car res))
 725               ((and (not ts) (gethash :set dbi))
 726                res)))))))
 727
 728 (defun join-qualifier (class object slot-def)
 729     (declare (ignore class))
 730     (let* ((dbi (view-class-slot-db-info slot-def))
 731            (jc (find-class (gethash :join-class dbi)))
 732            ;;(ts (gethash :target-slot dbi))
 733            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 734            (foreign-keys (gethash :foreign-key dbi))
 735            (home-keys (gethash :home-key dbi)))
 736       (when (every #'(lambda (slt)
 737                        (and (slot-boundp object slt)
 738                             (not (null (slot-value object slt)))))
 739                    (if (listp home-keys) home-keys (list home-keys)))
 740         (let ((jc
 741                (mapcar #'(lambda (hk fk)
 742                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 743                              (sql-operation '==
 744                                             (typecase fk
 745                                               (symbol
 746                                                (sql-expression
 747                                                 :attribute
 748                                                 (view-class-slot-column fksd)
 749                                                 :table (view-table jc)))
 750                                               (t fk))
 751                                             (typecase hk
 752                                               (symbol
 753                                                (slot-value object hk))
 754                                               (t
 755                                                hk)))))
 756                        (if (listp home-keys)
 757                            home-keys
 758                            (list home-keys))
 759                        (if (listp foreign-keys)
 760                            foreign-keys
 761                            (list foreign-keys)))))
 762           (when jc
 763             (if (> (length jc) 1)
 764                 (apply #'sql-and jc)
 765                 jc))))))
 766
 767 ;; FIXME: add retrieval immediate for efficiency
 768 ;; For example, for (select 'employee-address) in test suite =>
 769 ;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
 770
 771 (defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances)
 772   "Used by find-all to build objects."
 773   (labels ((build-object (vals vclass jclasses selects immediate-selects instance)
 774              (let* ((db-vals (butlast vals (- (list-length vals)
 775                                               (list-length selects))))
 776                     (obj (if instance instance (make-instance (class-name vclass) :view-database database)))
 777                     (join-vals (subseq vals (list-length selects)))
 778                     (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
 779                                    jclasses)))
 780                ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals)
 781                ;; use refresh keyword here
 782                (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals))
 783                (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals))
 784                      joins)
 785                (mapc
 786                 #'(lambda (jc)
 787                     (let ((slot (find (class-name (class-of jc)) (class-slots vclass)
 788                                       :key #'(lambda (slot)
 789                                                (when (and (eq :join (view-class-slot-db-kind slot))
 790                                                           (eq (slot-definition-name slot)
 791                                                               (gethash :join-class (view-class-slot-db-info slot))))
 792                                                  (slot-definition-name slot))))))
 793                       (when slot
 794                         (setf (slot-value obj (slot-definition-name slot)) jc))))
 795                 joins)
 796                (when refresh (instance-refreshed obj))
 797                obj)))
 798     (let* ((objects
 799             (mapcar #'(lambda (sclass jclass sel immediate-join instance)
 800                         (prog1
 801                             (build-object vals sclass jclass sel immediate-join instance)
 802                           (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
 803                                              vals))))
 804                     sclasses immediate-join-classes sels immediate-joins instances)))
 805       (if (and flatp (= (length sclasses) 1))
 806           (car objects)
 807         objects))))
 808
 809 (defun find-all (view-classes
 810                  &rest args
 811                  &key all set-operation distinct from where group-by having
 812                       order-by offset limit refresh flatp result-types
 813                       inner-join on
 814                       (database *default-database*)
 815                       instances)
 816   "Called by SELECT to generate object query results when the
 817   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 818   (declare (ignore all set-operation group-by having offset limit inner-join on)
 819            (optimize (debug 3) (speed 1)))
 820   (labels ((ref-equal (ref1 ref2)
 821              (equal (sql ref1)
 822                     (sql ref2)))
 823            (table-sql-expr (table)
 824              (sql-expression :table (view-table table)))
 825            (tables-equal (table-a table-b)
 826              (when (and table-a table-b)
 827                (string= (string (slot-value table-a 'name))
 828                         (string (slot-value table-b 'name))))))
 829     (remf args :from)
 830     (remf args :where)
 831     (remf args :flatp)
 832     (remf args :additional-fields)
 833     (remf args :result-types)
 834     (remf args :instances)
 835     (let* ((*db-deserializing* t)
 836            (sclasses (mapcar #'find-class view-classes))
 837            (immediate-join-slots
 838             (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
 839            (immediate-join-classes
 840             (mapcar #'(lambda (jcs)
 841                         (mapcar #'(lambda (slotdef)
 842                                     (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
 843                                 jcs))
 844                     immediate-join-slots))
 845            (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
 846            (sels (mapcar #'generate-selection-list sclasses))
 847            (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
 848            (sel-tables (collect-table-refs where))
 849            (tables (remove-if #'null
 850                               (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
 851                                                          (mapcar #'(lambda (jcs)
 852                                                                      (mapcan #'(lambda (jc)
 853                                                                                  (when jc (table-sql-expr jc)))
 854                                                                              jcs))
 855                                                                  immediate-join-classes)
 856                                                          sel-tables)
 857                                                  :test #'tables-equal)))
 858            (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
 859                                    (listify order-by))))
 860
 861       (dolist (ob order-by-slots)
 862         (when (and ob (not (member ob (mapcar #'cdr fullsels)
 863                                    :test #'ref-equal)))
 864           (setq fullsels
 865             (append fullsels (mapcar #'(lambda (att) (cons nil att))
 866                                      order-by-slots)))))
 867       (dolist (ob (listify distinct))
 868         (when (and (typep ob 'sql-ident)
 869                    (not (member ob (mapcar #'cdr fullsels)
 870                                 :test #'ref-equal)))
 871           (setq fullsels
 872               (append fullsels (mapcar #'(lambda (att) (cons nil att))
 873                                        (listify ob))))))
 874       (mapcar #'(lambda (vclass jclasses jslots)
 875                   (when jclasses
 876                     (mapcar
 877                      #'(lambda (jclass jslot)
 878                          (let ((dbi (view-class-slot-db-info jslot)))
 879                            (setq where
 880                                  (append
 881                                   (list (sql-operation '==
 882                                                       (sql-expression
 883                                                        :attribute (gethash :foreign-key dbi)
 884                                                        :table (view-table jclass))
 885                                                       (sql-expression
 886                                                        :attribute (gethash :home-key dbi)
 887                                                        :table (view-table vclass))))
 888                                   (when where (listify where))))))
 889                      jclasses jslots)))
 890               sclasses immediate-join-classes immediate-join-slots)
 891       (let* ((rows (apply #'select
 892                           (append (mapcar #'cdr fullsels)
 893                                   (cons :from
 894                                         (list (append (when from (listify from))
 895                                                       (listify tables))))
 896                                   (list :result-types result-types)
 897                                   (when where (list :where where))
 898                                   args)))
 899              (instances-to-add (- (length rows) (length instances)))
 900              (perhaps-extended-instances
 901               (if (plusp instances-to-add)
 902                   (append instances (do ((i 0 (1+ i))
 903                                          (res nil))
 904                                         ((= i instances-to-add) res)
 905                                       (push (make-list (length sclasses) :initial-element nil) res)))
 906                 instances))
 907              (objects (mapcar
 908                        #'(lambda (row instance)
 909                            (build-objects row sclasses immediate-join-classes sels
 910                                           immediate-join-sels database refresh flatp
 911                                           (if (and flatp (atom instance))
 912                                               (list instance)
 913                                             instance)))
 914                        rows perhaps-extended-instances)))
 915         objects))))
 916
 917 (defmethod instance-refreshed ((instance standard-db-object)))
 918
 919 (defun select (&rest select-all-args)
 920    "Executes a query on DATABASE, which has a default value of
 921 *DEFAULT-DATABASE*, specified by the SQL expressions supplied
 922 using the remaining arguments in SELECT-ALL-ARGS. The SELECT
 923 argument can be used to generate queries in both functional and
 924 object oriented contexts.
 925
 926 In the functional case, the required arguments specify the
 927 columns selected by the query and may be symbolic SQL expressions
 928 or strings representing attribute identifiers. Type modified
 929 identifiers indicate that the values selected from the specified
 930 column are converted to the specified lisp type. The keyword
 931 arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY,
 932 SET-OPERATION and WHERE are used to specify, using the symbolic
 933 SQL syntax, the corresponding components of the SQL query
 934 generated by the call to SELECT. RESULT-TYPES is a list of
 935 symbols which specifies the lisp type for each field returned by
 936 the query. If RESULT-TYPES is nil all results are returned as
 937 strings whereas the default value of :auto means that the lisp
 938 types are automatically computed for each field. FIELD-NAMES is t
 939 by default which means that the second value returned is a list
 940 of strings representing the columns selected by the query. If
 941 FIELD-NAMES is nil, the list of column names is not returned as a
 942 second value.
 943
 944 In the object oriented case, the required arguments to SELECT are
 945 symbols denoting View Classes which specify the database tables
 946 to query. In this case, SELECT returns a list of View Class
 947 instances whose slots are set from the attribute values of the
 948 records in the specified table. Slot-value is a legal operator
 949 which can be employed as part of the symbolic SQL syntax used in
 950 the WHERE keyword argument to SELECT. REFRESH is nil by default
 951 which means that the View Class instances returned are retrieved
 952 from a cache if an equivalent call to SELECT has previously been
 953 issued. If REFRESH is true, the View Class instances returned are
 954 updated as necessary from the database and the generic function
 955 INSTANCE-REFRESHED is called to perform any necessary operations
 956 on the updated instances.
 957
 958 In both object oriented and functional contexts, FLATP has a
 959 default value of nil which means that the results are returned as
 960 a list of lists. If FLATP is t and only one result is returned
 961 for each record selected in the query, the results are returned
 962 as elements of a list."
 963
 964   (flet ((select-objects (target-args)
 965            (and target-args
 966                 (every #'(lambda (arg)
 967                            (and (symbolp arg)
 968                                 (find-class arg nil)))
 969                        target-args))))
 970     (multiple-value-bind (target-args qualifier-args)
 971         (query-get-selections select-all-args)
 972       (unless (or *default-database* (getf qualifier-args :database))
 973         (signal-no-database-error nil))
 974
 975         (cond
 976           ((select-objects target-args)
 977            (let ((caching (getf qualifier-args :caching t))
 978                  (result-types (getf qualifier-args :result-types :auto))
 979                  (refresh (getf qualifier-args :refresh nil))
 980                  (database (or (getf qualifier-args :database) *default-database*))
 981                  (order-by (getf qualifier-args :order-by)))
 982              (remf qualifier-args :caching)
 983              (remf qualifier-args :refresh)
 984              (remf qualifier-args :result-types)
 985
 986
 987              ;; Add explicity table name to order-by if not specified and only
 988              ;; one selected table. This is required so FIND-ALL won't duplicate
 989              ;; the field
 990              (when (and order-by (= 1 (length target-args)))
 991                (let ((table-name  (view-table (find-class (car target-args))))
 992                      (order-by-list (copy-seq (listify order-by))))
 993
 994                  (loop for i from 0 below (length order-by-list)
 995                      do (etypecase (nth i order-by-list)
 996                           (sql-ident-attribute
 997                            (unless (slot-value (nth i order-by-list) 'qualifier)
 998                              (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
 999                           (cons
1000                            (unless (slot-value (car (nth i order-by-list)) 'qualifier)
1001                              (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
1002                  (setf (getf qualifier-args :order-by) order-by-list)))
1003
1004              (cond
1005                ((null caching)
1006                 (apply #'find-all target-args
1007                        (append qualifier-args (list :result-types result-types))))
1008                (t
1009                 (let ((cached (records-cache-results target-args qualifier-args database)))
1010                   (cond
1011                     ((and cached (not refresh))
1012                      cached)
1013                     ((and cached refresh)
1014                      (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto)))))
1015                        (setf (records-cache-results target-args qualifier-args database) results)
1016                        results))
1017                     (t
1018                      (let ((results (apply #'find-all target-args (append qualifier-args
1019                                                                           '(:result-types :auto)))))
1020                        (setf (records-cache-results target-args qualifier-args database) results)
1021                        results))))))))
1022           (t
1023            (let* ((expr (apply #'make-query select-all-args))
1024                   (specified-types
1025                    (mapcar #'(lambda (attrib)
1026                                (if (typep attrib 'sql-ident-attribute)
1027                                    (let ((type (slot-value attrib 'type)))
1028                                      (if type
1029                                          type
1030                                          t))
1031                                    t))
1032                            (slot-value expr 'selections))))
1033              (destructuring-bind (&key (flatp nil)
1034                                        (result-types :auto)
1035                                        (field-names t)
1036                                        (database *default-database*)
1037                                        &allow-other-keys)
1038                  qualifier-args
1039                (query expr :flatp flatp
1040                       :result-types
1041                       ;; specifying a type for an attribute overrides result-types
1042                       (if (some #'(lambda (x) (not (eq t x))) specified-types)
1043                           specified-types
1044                           result-types)
1045                       :field-names field-names
1046                       :database database))))))))
1047
1048 (defun compute-records-cache-key (targets qualifiers)
1049   (list targets
1050         (do ((args *select-arguments* (cdr args))
1051              (results nil))
1052             ((null args) results)
1053           (let* ((arg (car args))
1054                  (value (getf qualifiers arg)))
1055             (when value
1056               (push (list arg
1057                           (typecase value
1058                             (cons (cons (sql (car value)) (cdr value)))
1059                             (%sql-expression (sql value))
1060                             (t value)))
1061                     results))))))
1062
1063 (defun records-cache-results (targets qualifiers database)
1064   (when (record-caches database)
1065     (gethash (compute-records-cache-key targets qualifiers) (record-caches database))))
1066
1067 (defun (setf records-cache-results) (results targets qualifiers database)
1068   (unless (record-caches database)
1069     (setf (record-caches database)
1070           (make-hash-table :test 'equal
1071                            #+allegro :values #+allegro :weak)))
1072   (setf (gethash (compute-records-cache-key targets qualifiers)
1073                  (record-caches database)) results)
1074   results)
1075
1076