sql/objects.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; The CLSQL Object Oriented Data Definitional Language (OODDL)
   7 ;;;; and Object Oriented Data Manipulation Language (OODML).
   8 ;;;;
   9 ;;;; This file is part of CLSQL.
  10 ;;;;
  11 ;;;; CLSQL users are granted the rights to distribute and use this software
  12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  14 ;;;; *************************************************************************
  15
  16 (in-package #:clsql-sys)
  17
  18 (defclass standard-db-object ()
  19   ((view-database :initform nil :initarg :view-database :reader view-database
  20     :db-kind :virtual))
  21   (:metaclass standard-db-class)
  22   (:documentation "Superclass for all CLSQL View Classes."))
  23
  24 (defvar *db-deserializing* nil)
  25 (defvar *db-initializing* nil)
  26
  27 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
  28   (declare (optimize (speed 3)))
  29   (unless *db-deserializing*
  30     (let* ((slot-name (%svuc-slot-name slot-def))
  31            (slot-object (%svuc-slot-object slot-def class))
  32            (slot-kind (view-class-slot-db-kind slot-object)))
  33       (when (and (eql slot-kind :join)
  34                  (not (slot-boundp instance slot-name)))
  35         (let ((*db-deserializing* t))
  36           (if (view-database instance)
  37               (setf (slot-value instance slot-name)
  38                     (fault-join-slot class instance slot-object))
  39               (setf (slot-value instance slot-name) nil))))))
  40   (call-next-method))
  41
  42 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
  43                                           instance slot)
  44   (declare (ignore new-value instance slot))
  45   (call-next-method))
  46
  47 (defmethod initialize-instance :around ((object standard-db-object)
  48                                         &rest all-keys &key &allow-other-keys)
  49   (declare (ignore all-keys))
  50   (let ((*db-initializing* t))
  51     (call-next-method)
  52     (unless *db-deserializing*
  53       #+nil (created-object object)
  54       (update-records-from-instance object))))
  55
  56 ;;
  57 ;; Build the database tables required to store the given view class
  58 ;;
  59
  60 (defun create-view-from-class (view-class-name
  61                                &key (database *default-database*))
  62   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
  63 the view. The argument DATABASE has a default value of
  64 *DEFAULT-DATABASE*."
  65   (let ((tclass (find-class view-class-name)))
  66     (if tclass
  67         (let ((*default-database* database))
  68           (%install-class tclass database))
  69         (error "Class ~s not found." view-class-name)))
  70   (values))
  71
  72 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
  73   (dolist (slotdef (ordered-class-slots self))
  74     (let ((res (database-generate-column-definition (class-name self)
  75                                                     slotdef database)))
  76       (when res
  77         (push res schemadef))))
  78   (unless schemadef
  79     (error "Class ~s has no :base slots" self))
  80   (create-table (sql-expression :table (view-table self)) schemadef
  81                 :database database
  82                 :constraints (database-pkey-constraint self database))
  83   (push self (database-view-classes database))
  84   t)
  85
  86 (defmethod database-pkey-constraint ((class standard-db-class) database)
  87   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
  88     (when keylist
  89       (convert-to-db-default-case
  90        (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
  91                (database-output-sql (view-table class) database)
  92                (database-output-sql keylist database))
  93        database))))
  94
  95 (defmethod database-generate-column-definition (class slotdef database)
  96   (declare (ignore database class))
  97   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
  98     (let ((cdef
  99            (list (sql-expression :attribute (view-class-slot-column slotdef))
 100                  (specified-type slotdef))))
 101       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
 102       (let ((const (view-class-slot-db-constraints slotdef)))
 103         (when const
 104           (setq cdef (append cdef (list const)))))
 105       cdef)))
 106
 107
 108 ;;
 109 ;; Drop the tables which store the given view class
 110 ;;
 111
 112 (defun drop-view-from-class (view-class-name &key (database *default-database*))
 113   "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
 114 which defines that view. The argument DATABASE has a default value of
 115 *DEFAULT-DATABASE*."
 116   (let ((tclass (find-class view-class-name)))
 117     (if tclass
 118         (let ((*default-database* database))
 119           (%uninstall-class tclass))
 120         (error "Class ~s not found." view-class-name)))
 121   (values))
 122
 123 (defun %uninstall-class (self &key (database *default-database*))
 124   (drop-table (sql-expression :table (view-table self))
 125               :if-does-not-exist :ignore
 126               :database database)
 127   (setf (database-view-classes database)
 128         (remove self (database-view-classes database))))
 129
 130
 131 ;;
 132 ;; List all known view classes
 133 ;;
 134
 135 (defun list-classes (&key (test #'identity)
 136                      (root-class (find-class 'standard-db-object))
 137                      (database *default-database*))
 138   "The LIST-CLASSES function collects all the classes below
 139 ROOT-CLASS, which defaults to standard-db-object, that are connected
 140 to the supplied DATABASE and which satisfy the TEST function. The
 141 default for the TEST argument is identity. By default, LIST-CLASSES
 142 returns a list of all the classes connected to the default database,
 143 *DEFAULT-DATABASE*."
 144   (flet ((find-superclass (class)
 145            (member root-class (class-precedence-list class))))
 146     (let ((view-classes (and database (database-view-classes database))))
 147       (when view-classes
 148         (remove-if #'(lambda (c) (or (not (funcall test c))
 149                                      (not (find-superclass c))))
 150                    view-classes)))))
 151
 152 ;;
 153 ;; Define a new view class
 154 ;;
 155
 156 (defmacro def-view-class (class supers slots &rest cl-options)
 157   "Extends the syntax of defclass to allow special slots to be mapped
 158 onto the attributes of database views. The macro DEF-VIEW-CLASS
 159 creates a class called CLASS which maps onto a database view. Such a
 160 class is called a View Class. The macro DEF-VIEW-CLASS extends the
 161 syntax of DEFCLASS to allow special base slots to be mapped onto the
 162 attributes of database views (presently single tables). When a select
 163 query that names a View Class is submitted, then the corresponding
 164 database view is queried, and the slots in the resulting View Class
 165 instances are filled with attribute values from the database. If
 166 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
 167 superclass of the newly-defined View Class."
 168   `(progn
 169     (defclass ,class ,supers ,slots
 170       ,@(if (find :metaclass `,cl-options :key #'car)
 171             `,cl-options
 172             (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
 173     (finalize-inheritance (find-class ',class))))
 174
 175 (defun keyslots-for-class (class)
 176   (slot-value class 'key-slots))
 177
 178 (defun key-qualifier-for-instance (obj &key (database *default-database*))
 179   (let ((tb (view-table (class-of obj))))
 180     (flet ((qfk (k)
 181              (sql-operation '==
 182                             (sql-expression :attribute
 183                                             (view-class-slot-column k)
 184                                             :table tb)
 185                             (db-value-from-slot
 186                              k
 187                              (slot-value obj (slot-definition-name k))
 188                              database))))
 189       (let* ((keys (keyslots-for-class (class-of obj)))
 190              (keyxprs (mapcar #'qfk (reverse keys))))
 191         (cond
 192           ((= (length keyxprs) 0) nil)
 193           ((= (length keyxprs) 1) (car keyxprs))
 194           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
 195
 196 ;;
 197 ;; Function used by 'generate-selection-list'
 198 ;;
 199
 200 (defun generate-attribute-reference (vclass slotdef)
 201   (cond
 202    ((eq (view-class-slot-db-kind slotdef) :base)
 203     (sql-expression :attribute (view-class-slot-column slotdef)
 204                     :table (view-table vclass)))
 205    ((eq (view-class-slot-db-kind slotdef) :key)
 206     (sql-expression :attribute (view-class-slot-column slotdef)
 207                     :table (view-table vclass)))
 208    (t nil)))
 209
 210 ;;
 211 ;; Function used by 'find-all'
 212 ;;
 213
 214 (defun generate-selection-list (vclass)
 215   (let ((sels nil))
 216     (dolist (slotdef (ordered-class-slots vclass))
 217       (let ((res (generate-attribute-reference vclass slotdef)))
 218         (when res
 219           (push (cons slotdef res) sels))))
 220     (if sels
 221         sels
 222         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 223
 224
 225 ;;
 226 ;; Called by 'get-slot-values-from-view'
 227 ;;
 228
 229 (declaim (inline delistify))
 230 (defun delistify (list)
 231   (if (listp list)
 232       (car list)
 233       list))
 234
 235 (defvar *update-context* nil)
 236
 237 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
 238   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 239   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 240          (slot-name   (slot-definition-name slotdef))
 241          (slot-type   (specified-type slotdef))
 242          (*update-context* (cons (type-of instance) slot-name)))
 243     (cond ((and value (null slot-reader))
 244            (setf (slot-value instance slot-name)
 245                  (read-sql-value value (delistify slot-type)
 246                                  (view-database instance))))
 247           ((null value)
 248            (update-slot-with-null instance slot-name slotdef))
 249           ((typep slot-reader 'string)
 250            (setf (slot-value instance slot-name)
 251                  (format nil slot-reader value)))
 252           ((typep slot-reader 'function)
 253            (setf (slot-value instance slot-name)
 254                  (apply slot-reader (list value))))
 255           (t
 256            (error "Slot reader is of an unusual type.")))))
 257
 258 (defmethod key-value-from-db (slotdef value database)
 259   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 260   (let ((slot-reader (view-class-slot-db-reader slotdef))
 261         (slot-type (specified-type slotdef)))
 262     (cond ((and value (null slot-reader))
 263            (read-sql-value value (delistify slot-type) database))
 264           ((null value)
 265            nil)
 266           ((typep slot-reader 'string)
 267            (format nil slot-reader value))
 268           ((typep slot-reader 'function)
 269            (apply slot-reader (list value)))
 270           (t
 271            (error "Slot reader is of an unusual type.")))))
 272
 273 (defun db-value-from-slot (slotdef val database)
 274   (let ((dbwriter (view-class-slot-db-writer slotdef))
 275         (dbtype (specified-type slotdef)))
 276     (typecase dbwriter
 277       (string (format nil dbwriter val))
 278       (function (apply dbwriter (list val)))
 279       (t
 280        (typecase dbtype
 281          (cons
 282           (database-output-sql-as-type (car dbtype) val database))
 283          (t
 284           (database-output-sql-as-type dbtype val database)))))))
 285
 286 (defun check-slot-type (slotdef val)
 287   (let* ((slot-type (specified-type slotdef))
 288          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 289     (when (and slot-type val)
 290       (unless (typep val basetype)
 291         (error 'clsql-type-error
 292                :slotname (slot-definition-name slotdef)
 293                :typespec slot-type
 294                :value val)))))
 295
 296 ;;
 297 ;; Called by find-all
 298 ;;
 299
 300 (defmethod get-slot-values-from-view (obj slotdeflist values)
 301     (flet ((update-slot (slot-def values)
 302              (update-slot-from-db obj slot-def values)))
 303       (mapc #'update-slot slotdeflist values)
 304       obj))
 305
 306 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 307                                     (database *default-database*))
 308   (let* ((database (or (view-database obj) database))
 309          (vct (view-table (class-of obj)))
 310          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 311     (check-slot-type sd (slot-value obj slot))
 312     (let* ((att (view-class-slot-column sd))
 313            (val (db-value-from-slot sd (slot-value obj slot) database)))
 314       (cond ((and vct sd (view-database obj))
 315              (update-records (sql-expression :table vct)
 316                              :attributes (list (sql-expression :attribute att))
 317                              :values (list val)
 318                              :where (key-qualifier-for-instance
 319                                      obj :database database)
 320                              :database database))
 321             ((and vct sd (not (view-database obj)))
 322              (insert-records :into (sql-expression :table vct)
 323                              :attributes (list (sql-expression :attribute att))
 324                              :values (list val)
 325                              :database database)
 326              (setf (slot-value obj 'view-database) database))
 327             (t
 328              (error "Unable to update record.")))))
 329   (values))
 330
 331 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 332                                      (database *default-database*))
 333   (let* ((database (or (view-database obj) database))
 334          (vct (view-table (class-of obj)))
 335          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 336          (avps (mapcar #'(lambda (s)
 337                            (let ((val (slot-value
 338                                        obj (slot-definition-name s))))
 339                              (check-slot-type s val)
 340                              (list (sql-expression
 341                                     :attribute (view-class-slot-column s))
 342                                    (db-value-from-slot s val database))))
 343                        sds)))
 344     (cond ((and avps (view-database obj))
 345            (update-records (sql-expression :table vct)
 346                            :av-pairs avps
 347                            :where (key-qualifier-for-instance
 348                                    obj :database database)
 349                            :database database))
 350           ((and avps (not (view-database obj)))
 351            (insert-records :into (sql-expression :table vct)
 352                            :av-pairs avps
 353                            :database database)
 354            (setf (slot-value obj 'view-database) database))
 355           (t
 356            (error "Unable to update records"))))
 357   (values))
 358
 359 (defmethod update-records-from-instance ((obj standard-db-object)
 360                                          &key (database *default-database*))
 361   (let ((database (or (view-database obj) database)))
 362     (labels ((slot-storedp (slot)
 363                (and (member (view-class-slot-db-kind slot) '(:base :key))
 364                     (slot-boundp obj (slot-definition-name slot))))
 365              (slot-value-list (slot)
 366                (let ((value (slot-value obj (slot-definition-name slot))))
 367                  (check-slot-type slot value)
 368                  (list (sql-expression :attribute (view-class-slot-column slot))
 369                        (db-value-from-slot slot value database)))))
 370       (let* ((view-class (class-of obj))
 371              (view-class-table (view-table view-class))
 372              (slots (remove-if-not #'slot-storedp
 373                                    (ordered-class-slots view-class)))
 374              (record-values (mapcar #'slot-value-list slots)))
 375         (unless record-values
 376           (error "No settable slots."))
 377         (if (view-database obj)
 378             (update-records (sql-expression :table view-class-table)
 379                             :av-pairs record-values
 380                             :where (key-qualifier-for-instance
 381                                     obj :database database)
 382                             :database database)
 383             (progn
 384               (insert-records :into (sql-expression :table view-class-table)
 385                               :av-pairs record-values
 386                               :database database)
 387               (setf (slot-value obj 'view-database) database))))))
 388   (values))
 389
 390 (defmethod delete-instance-records ((instance standard-db-object))
 391   (let ((vt (sql-expression :table (view-table (class-of instance))))
 392         (vd (view-database instance)))
 393     (if vd
 394         (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 395           (delete-records :from vt :where qualifier :database vd)
 396           (setf (slot-value instance 'view-database) nil))
 397         (error 'clsql-base::clsql-no-database-error :database nil))))
 398
 399 (defmethod update-instance-from-records ((instance standard-db-object)
 400                                          &key (database *default-database*))
 401   (let* ((view-class (find-class (class-name (class-of instance))))
 402          (view-table (sql-expression :table (view-table view-class)))
 403          (vd (or (view-database instance) database))
 404          (view-qual (key-qualifier-for-instance instance :database vd))
 405          (sels (generate-selection-list view-class))
 406          (res (apply #'select (append (mapcar #'cdr sels)
 407                                       (list :from  view-table
 408                                             :where view-qual)
 409                                       (list :result-types nil)))))
 410     (when res
 411       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 412
 413 (defmethod update-slot-from-record ((instance standard-db-object)
 414                                     slot &key (database *default-database*))
 415   (let* ((view-class (find-class (class-name (class-of instance))))
 416          (view-table (sql-expression :table (view-table view-class)))
 417          (vd (or (view-database instance) database))
 418          (view-qual (key-qualifier-for-instance instance :database vd))
 419          (slot-def (slotdef-for-slot-with-class slot view-class))
 420          (att-ref (generate-attribute-reference view-class slot-def))
 421          (res (select att-ref :from  view-table :where view-qual
 422                       :result-types nil)))
 423     (when res
 424       (get-slot-values-from-view instance (list slot-def) (car res)))))
 425
 426
 427 (defmethod update-slot-with-null ((object standard-db-object)
 428                                   slotname
 429                                   slotdef)
 430   (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 431
 432 (defvar +no-slot-value+ '+no-slot-value+)
 433
 434 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 435   (let* ((class (find-class classname))
 436          (sld (slotdef-for-slot-with-class slot class)))
 437     (if sld
 438         (if (eq value +no-slot-value+)
 439             (sql-expression :attribute (view-class-slot-column sld)
 440                             :table (view-table class))
 441             (db-value-from-slot
 442              sld
 443              value
 444              database))
 445         (error "Unknown slot ~A for class ~A" slot classname))))
 446
 447 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 448         (declare (ignore database))
 449         (let* ((class (find-class classname)))
 450           (unless (view-table class)
 451             (error "No view-table for class ~A"  classname))
 452           (sql-expression :table (view-table class))))
 453
 454 (defmethod database-get-type-specifier (type args database)
 455   (declare (ignore type args))
 456   (if (clsql-base::in (database-underlying-type database)
 457                           :postgresql :postgresql-socket)
 458           "VARCHAR"
 459           "VARCHAR(255)"))
 460
 461 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 462   (declare (ignore database))
 463   ;;"INT8")
 464   (if args
 465       (format nil "INT(~A)" (car args))
 466       "INT"))
 467
 468 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
 469   (declare (ignore args database))
 470   "BIGINT")
 471
 472 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 473                                         database)
 474   (if args
 475       (format nil "VARCHAR(~A)" (car args))
 476     (if (clsql-base::in (database-underlying-type database)
 477                             :postgresql :postgresql-socket)
 478         "VARCHAR"
 479       "VARCHAR(255)")))
 480
 481 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 482                                         database)
 483   (if args
 484       (format nil "VARCHAR(~A)" (car args))
 485     (if (clsql-base::in (database-underlying-type database)
 486                             :postgresql :postgresql-socket)
 487         "VARCHAR"
 488       "VARCHAR(255)")))
 489
 490 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 491   (if args
 492       (format nil "VARCHAR(~A)" (car args))
 493     (if (clsql-base::in (database-underlying-type database)
 494                             :postgresql :postgresql-socket)
 495         "VARCHAR"
 496       "VARCHAR(255)")))
 497
 498 (deftype universal-time ()
 499   "A positive integer as returned by GET-UNIVERSAL-TIME."
 500   '(integer 1 *))
 501
 502 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
 503   (declare (ignore args database))
 504   "BIGINT")
 505
 506 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 507   (declare (ignore args))
 508   (case (database-underlying-type database)
 509     ((:postgresql :postgresql-socket)
 510      "TIMESTAMP WITHOUT TIME ZONE")
 511     (:mysql
 512      "DATETIME")
 513     (t "TIMESTAMP")))
 514
 515 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 516   (declare (ignore database args))
 517   "VARCHAR")
 518
 519 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
 520   (declare (ignore database args))
 521   "INT8")
 522
 523 (deftype raw-string (&optional len)
 524   "A string which is not trimmed when retrieved from the database"
 525   `(string ,len))
 526
 527 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 528   (declare (ignore database))
 529   (if args
 530       (format nil "VARCHAR(~A)" (car args))
 531       "VARCHAR"))
 532
 533 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 534   (declare (ignore database))
 535   (if args
 536       (format nil "FLOAT(~A)" (car args))
 537       "FLOAT"))
 538
 539 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 540   (declare (ignore database))
 541   (if args
 542       (format nil "FLOAT(~A)" (car args))
 543       "FLOAT"))
 544
 545 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
 546   (declare (ignore args database))
 547   "BOOL")
 548
 549 (defmethod database-output-sql-as-type (type val database)
 550   (declare (ignore type database))
 551   val)
 552
 553 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 554   (declare (ignore database))
 555   (progv '(*print-circle* *print-array*) '(t t)
 556     (let ((escaped (prin1-to-string val)))
 557       (clsql-base::substitute-char-string
 558        escaped #\Null " "))))
 559
 560 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 561   (declare (ignore database))
 562   (if (keywordp val)
 563       (symbol-name val)
 564       (if val
 565           (concatenate 'string
 566                        (package-name (symbol-package val))
 567                        "::"
 568                        (symbol-name val))
 569           "")))
 570
 571 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 572   (declare (ignore database))
 573   (if val
 574       (symbol-name val)
 575       ""))
 576
 577 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
 578   (declare (ignore database))
 579   (progv '(*print-circle* *print-array*) '(t t)
 580     (prin1-to-string val)))
 581
 582 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
 583   (declare (ignore database))
 584   (progv '(*print-circle* *print-array*) '(t t)
 585     (prin1-to-string val)))
 586
 587 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
 588   (case (database-underlying-type database)
 589     (:mysql
 590      (if val 1 0))
 591     (t
 592      (if val "t" "f"))))
 593
 594 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 595   (declare (ignore database))
 596   val)
 597
 598 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 599                                         val database)
 600   (declare (ignore database))
 601   val)
 602
 603 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 604                                         val database)
 605   (declare (ignore database))
 606   val)
 607
 608 (defmethod read-sql-value (val type database)
 609   (declare (ignore type database))
 610   (read-from-string val))
 611
 612 (defmethod read-sql-value (val (type (eql 'string)) database)
 613   (declare (ignore database))
 614   val)
 615
 616 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 617   (declare (ignore database))
 618   val)
 619
 620 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 621   (declare (ignore database))
 622   val)
 623
 624 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 625   (declare (ignore database))
 626   val)
 627
 628 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 629   (declare (ignore database))
 630   (when (< 0 (length val))
 631     (intern (symbol-name-default-case val)
 632             (find-package '#:keyword))))
 633
 634 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 635   (declare (ignore database))
 636   (when (< 0 (length val))
 637     (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
 638       (intern (clsql-base:symbol-name-default-case val)
 639               (symbol-package *update-context*)))))
 640
 641 (defmethod read-sql-value (val (type (eql 'integer)) database)
 642   (declare (ignore database))
 643   (etypecase val
 644     (string
 645      (unless (string-equal "NIL" val)
 646        (parse-integer val)))
 647     (number val)))
 648
 649 (defmethod read-sql-value (val (type (eql 'bigint)) database)
 650   (declare (ignore database))
 651   (etypecase val
 652     (string
 653      (unless (string-equal "NIL" val)
 654        (parse-integer val)))
 655     (number val)))
 656
 657 (defmethod read-sql-value (val (type (eql 'float)) database)
 658   (declare (ignore database))
 659   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 660   (float (read-from-string val)))
 661
 662 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 663   (case (database-underlying-type database)
 664     (:mysql
 665      (etypecase val
 666        (string (if (string= "0" val) nil t))
 667        (integer (if (zerop val) nil t))))
 668     (:postgresql
 669      (if (eq :odbc (database-type database))
 670          (if (string= "0" val) nil t)
 671        (equal "t" val)))
 672     (t
 673      (equal "t" val))))
 674
 675 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
 676   (declare (ignore database))
 677   (unless (eq 'NULL val)
 678     (etypecase val
 679       (string
 680        (parse-integer val))
 681       (number val))))
 682
 683 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 684   (declare (ignore database))
 685   (unless (eq 'NULL val)
 686     (parse-timestring val)))
 687
 688 (defmethod read-sql-value (val (type (eql 'duration)) database)
 689   (declare (ignore database))
 690   (unless (or (eq 'NULL val)
 691               (equal "NIL" val))
 692     (parse-timestring val)))
 693
 694 ;; ------------------------------------------------------------
 695 ;; Logic for 'faulting in' :join slots
 696
 697 (defun fault-join-slot-raw (class object slot-def)
 698   (let* ((dbi (view-class-slot-db-info slot-def))
 699          (jc (gethash :join-class dbi)))
 700     (let ((jq (join-qualifier class object slot-def)))
 701       (when jq
 702         (select jc :where jq :flatp t :result-types nil)))))
 703
 704 (defun fault-join-slot (class object slot-def)
 705   (let* ((dbi (view-class-slot-db-info slot-def))
 706          (ts (gethash :target-slot dbi))
 707          (res (fault-join-slot-raw class object slot-def)))
 708     (when res
 709       (cond
 710         ((and ts (gethash :set dbi))
 711          (mapcar (lambda (obj)
 712                    (cons obj (slot-value obj ts))) res))
 713         ((and ts (not (gethash :set dbi)))
 714          (mapcar (lambda (obj) (slot-value obj ts)) res))
 715         ((and (not ts) (not (gethash :set dbi)))
 716          (car res))
 717         ((and (not ts) (gethash :set dbi))
 718          res)))))
 719
 720 (defun join-qualifier (class object slot-def)
 721     (declare (ignore class))
 722     (let* ((dbi (view-class-slot-db-info slot-def))
 723            (jc (find-class (gethash :join-class dbi)))
 724            ;;(ts (gethash :target-slot dbi))
 725            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 726            (foreign-keys (gethash :foreign-key dbi))
 727            (home-keys (gethash :home-key dbi)))
 728       (when (every #'(lambda (slt)
 729                        (and (slot-boundp object slt)
 730                             (not (null (slot-value object slt)))))
 731                    (if (listp home-keys) home-keys (list home-keys)))
 732         (let ((jc
 733                (mapcar #'(lambda (hk fk)
 734                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 735                              (sql-operation '==
 736                                             (typecase fk
 737                                               (symbol
 738                                                (sql-expression
 739                                                 :attribute
 740                                                 (view-class-slot-column fksd)
 741                                                 :table (view-table jc)))
 742                                               (t fk))
 743                                             (typecase hk
 744                                               (symbol
 745                                                (slot-value object hk))
 746                                               (t
 747                                                hk)))))
 748                        (if (listp home-keys)
 749                            home-keys
 750                            (list home-keys))
 751                        (if (listp foreign-keys)
 752                            foreign-keys
 753                            (list foreign-keys)))))
 754           (when jc
 755             (if (> (length jc) 1)
 756                 (apply #'sql-and jc)
 757                 jc))))))
 758
 759 (defun find-all (view-classes &rest args &key all set-operation distinct from
 760                  where group-by having order-by order-by-descending offset limit
 761                  refresh flatp (database *default-database*))
 762   "Called by SELECT to generate object query results when the
 763   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 764   (declare (ignore all set-operation group-by having offset limit)
 765            (optimize (debug 3) (speed 1)))
 766   (remf args :from)
 767   (remf args :flatp)
 768   (remf args :result-types)
 769   (labels ((table-sql-expr (table)
 770              (sql-expression :table (view-table table)))
 771            (ref-equal (ref1 ref2)
 772              (equal (sql ref1)
 773                     (sql ref2)))
 774            (tables-equal (table-a table-b)
 775              (string= (string (slot-value table-a 'name))
 776                       (string (slot-value table-b 'name))))
 777            (build-object (vals vclass selects)
 778              (let* ((class-name (class-name vclass))
 779                     (db-vals (butlast vals (- (list-length vals)
 780                                               (list-length selects))))
 781                     (*db-initializing* t)
 782                     (obj (make-instance class-name :view-database database)))
 783                ;; use refresh keyword here
 784                (setf obj (get-slot-values-from-view obj (mapcar #'car selects)
 785                                                     db-vals))
 786                (when refresh (instance-refreshed obj))
 787                obj))
 788            (build-objects (vals sclasses sels)
 789              (let ((objects (mapcar #'(lambda (sclass sel)
 790                                         (prog1 (build-object vals sclass sel)
 791                                           (setf vals (nthcdr (list-length sel)
 792                                                              vals))))
 793                                     sclasses sels)))
 794                (if (and flatp (= (length sclasses) 1))
 795                    (car objects)
 796                    objects))))
 797     (let* ((*db-deserializing* t)
 798            (*default-database* (or database
 799                                    (error 'clsql-base::clsql-no-database-error :database nil)))
 800            (sclasses (mapcar #'find-class view-classes))
 801            (sels (mapcar #'generate-selection-list sclasses))
 802            (fullsels (apply #'append sels))
 803            (sel-tables (collect-table-refs where))
 804            (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
 805                                               sel-tables)
 806                                       :test #'tables-equal))
 807            (res nil))
 808         (dolist (ob (listify order-by))
 809           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 810                                      :test #'ref-equal)))
 811             (setq fullsels
 812                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 813                                            (listify ob))))))
 814         (dolist (ob (listify order-by-descending))
 815           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 816                                      :test #'ref-equal)))
 817             (setq fullsels
 818                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 819                                            (listify ob))))))
 820         (dolist (ob (listify distinct))
 821           (when (and (typep ob 'sql-ident)
 822                      (not (member ob (mapcar #'cdr fullsels)
 823                                   :test #'ref-equal)))
 824             (setq fullsels
 825                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 826                                            (listify ob))))))
 827         (setq res
 828               (apply #'select
 829                      (append (mapcar #'cdr fullsels)
 830                              (cons :from
 831                                    (list (append (when from (listify from))
 832                                                  (listify tables))))
 833                              (list :result-types nil)
 834                              args)))
 835         (mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
 836
 837 (defmethod instance-refreshed ((instance standard-db-object)))
 838
 839 (defmethod select (&rest select-all-args)
 840   "Selects data from database given the constraints specified. Returns
 841 a list of lists of record values as specified by select-all-args. By
 842 default, the records are each represented as lists of attribute
 843 values. The selections argument may be either db-identifiers, literal
 844 strings or view classes.  If the argument consists solely of view
 845 classes, the return value will be instances of objects rather than raw
 846 tuples."
 847   (flet ((select-objects (target-args)
 848            (and target-args
 849                 (every #'(lambda (arg)
 850                            (and (symbolp arg)
 851                                 (find-class arg nil)))
 852                        target-args))))
 853     (multiple-value-bind (target-args qualifier-args)
 854         (query-get-selections select-all-args)
 855       (if (select-objects target-args)
 856           (apply #'find-all target-args qualifier-args)
 857           (let ((expr (apply #'make-query select-all-args)))
 858             (destructuring-bind (&key (flatp nil)
 859                                       (result-types :auto)
 860                                       (field-names t)
 861                                       (database *default-database*)
 862                                       &allow-other-keys)
 863                 qualifier-args
 864               (query expr :flatp flatp :result-types result-types
 865                      :field-names field-names :database database)))))))
 866