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