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     (find-class ',class)))
 175
 176 (defun keyslots-for-class (class)
 177   (slot-value class 'key-slots))
 178
 179 (defun key-qualifier-for-instance (obj &key (database *default-database*))
 180   (let ((tb (view-table (class-of obj))))
 181     (flet ((qfk (k)
 182              (sql-operation '==
 183                             (sql-expression :attribute
 184                                             (view-class-slot-column k)
 185                                             :table tb)
 186                             (db-value-from-slot
 187                              k
 188                              (slot-value obj (slot-definition-name k))
 189                              database))))
 190       (let* ((keys (keyslots-for-class (class-of obj)))
 191              (keyxprs (mapcar #'qfk (reverse keys))))
 192         (cond
 193           ((= (length keyxprs) 0) nil)
 194           ((= (length keyxprs) 1) (car keyxprs))
 195           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
 196
 197 ;;
 198 ;; Function used by 'generate-selection-list'
 199 ;;
 200
 201 (defun generate-attribute-reference (vclass slotdef)
 202   (cond
 203    ((eq (view-class-slot-db-kind slotdef) :base)
 204     (sql-expression :attribute (view-class-slot-column slotdef)
 205                     :table (view-table vclass)))
 206    ((eq (view-class-slot-db-kind slotdef) :key)
 207     (sql-expression :attribute (view-class-slot-column slotdef)
 208                     :table (view-table vclass)))
 209    (t nil)))
 210
 211 ;;
 212 ;; Function used by 'find-all'
 213 ;;
 214
 215 (defun generate-selection-list (vclass)
 216   (let ((sels nil))
 217     (dolist (slotdef (ordered-class-slots vclass))
 218       (let ((res (generate-attribute-reference vclass slotdef)))
 219         (when res
 220           (push (cons slotdef res) sels))))
 221     (if sels
 222         sels
 223         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 224
 225
 226 ;;
 227 ;; Called by 'get-slot-values-from-view'
 228 ;;
 229
 230 (declaim (inline delistify))
 231 (defun delistify (list)
 232   (if (listp list)
 233       (car list)
 234       list))
 235
 236 (defvar *update-context* nil)
 237
 238 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
 239   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 240   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 241          (slot-name   (slot-definition-name slotdef))
 242          (slot-type   (specified-type slotdef))
 243          (*update-context* (cons (type-of instance) slot-name)))
 244     (cond ((and value (null slot-reader))
 245            (setf (slot-value instance slot-name)
 246                  (read-sql-value value (delistify slot-type)
 247                                  (view-database instance))))
 248           ((null value)
 249            (update-slot-with-null instance slot-name slotdef))
 250           ((typep slot-reader 'string)
 251            (setf (slot-value instance slot-name)
 252                  (format nil slot-reader value)))
 253           ((typep slot-reader 'function)
 254            (setf (slot-value instance slot-name)
 255                  (apply slot-reader (list value))))
 256           (t
 257            (error "Slot reader is of an unusual type.")))))
 258
 259 (defmethod key-value-from-db (slotdef value database)
 260   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 261   (let ((slot-reader (view-class-slot-db-reader slotdef))
 262         (slot-type (specified-type slotdef)))
 263     (cond ((and value (null slot-reader))
 264            (read-sql-value value (delistify slot-type) database))
 265           ((null value)
 266            nil)
 267           ((typep slot-reader 'string)
 268            (format nil slot-reader value))
 269           ((typep slot-reader 'function)
 270            (apply slot-reader (list value)))
 271           (t
 272            (error "Slot reader is of an unusual type.")))))
 273
 274 (defun db-value-from-slot (slotdef val database)
 275   (let ((dbwriter (view-class-slot-db-writer slotdef))
 276         (dbtype (specified-type slotdef)))
 277     (typecase dbwriter
 278       (string (format nil dbwriter val))
 279       (function (apply dbwriter (list val)))
 280       (t
 281        (typecase dbtype
 282          (cons
 283           (database-output-sql-as-type (car dbtype) val database))
 284          (t
 285           (database-output-sql-as-type dbtype val database)))))))
 286
 287 (defun check-slot-type (slotdef val)
 288   (let* ((slot-type (specified-type slotdef))
 289          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 290     (when (and slot-type val)
 291       (unless (typep val basetype)
 292         (error 'clsql-type-error
 293                :slotname (slot-definition-name slotdef)
 294                :typespec slot-type
 295                :value val)))))
 296
 297 ;;
 298 ;; Called by find-all
 299 ;;
 300
 301 (defmethod get-slot-values-from-view (obj slotdeflist values)
 302     (flet ((update-slot (slot-def values)
 303              (update-slot-from-db obj slot-def values)))
 304       (mapc #'update-slot slotdeflist values)
 305       obj))
 306
 307 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 308                                     (database *default-database*))
 309   (let* ((database (or (view-database obj) database))
 310          (vct (view-table (class-of obj)))
 311          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 312     (check-slot-type sd (slot-value obj slot))
 313     (let* ((att (view-class-slot-column sd))
 314            (val (db-value-from-slot sd (slot-value obj slot) database)))
 315       (cond ((and vct sd (view-database obj))
 316              (update-records (sql-expression :table vct)
 317                              :attributes (list (sql-expression :attribute att))
 318                              :values (list val)
 319                              :where (key-qualifier-for-instance
 320                                      obj :database database)
 321                              :database database))
 322             ((and vct sd (not (view-database obj)))
 323              (insert-records :into (sql-expression :table vct)
 324                              :attributes (list (sql-expression :attribute att))
 325                              :values (list val)
 326                              :database database)
 327              (setf (slot-value obj 'view-database) database))
 328             (t
 329              (error "Unable to update record.")))))
 330   (values))
 331
 332 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 333                                      (database *default-database*))
 334   (let* ((database (or (view-database obj) database))
 335          (vct (view-table (class-of obj)))
 336          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 337          (avps (mapcar #'(lambda (s)
 338                            (let ((val (slot-value
 339                                        obj (slot-definition-name s))))
 340                              (check-slot-type s val)
 341                              (list (sql-expression
 342                                     :attribute (view-class-slot-column s))
 343                                    (db-value-from-slot s val database))))
 344                        sds)))
 345     (cond ((and avps (view-database obj))
 346            (update-records (sql-expression :table vct)
 347                            :av-pairs avps
 348                            :where (key-qualifier-for-instance
 349                                    obj :database database)
 350                            :database database))
 351           ((and avps (not (view-database obj)))
 352            (insert-records :into (sql-expression :table vct)
 353                            :av-pairs avps
 354                            :database database)
 355            (setf (slot-value obj 'view-database) database))
 356           (t
 357            (error "Unable to update records"))))
 358   (values))
 359
 360 (defmethod update-records-from-instance ((obj standard-db-object)
 361                                          &key (database *default-database*))
 362   (let ((database (or (view-database obj) database)))
 363     (labels ((slot-storedp (slot)
 364                (and (member (view-class-slot-db-kind slot) '(:base :key))
 365                     (slot-boundp obj (slot-definition-name slot))))
 366              (slot-value-list (slot)
 367                (let ((value (slot-value obj (slot-definition-name slot))))
 368                  (check-slot-type slot value)
 369                  (list (sql-expression :attribute (view-class-slot-column slot))
 370                        (db-value-from-slot slot value database)))))
 371       (let* ((view-class (class-of obj))
 372              (view-class-table (view-table view-class))
 373              (slots (remove-if-not #'slot-storedp
 374                                    (ordered-class-slots view-class)))
 375              (record-values (mapcar #'slot-value-list slots)))
 376         (unless record-values
 377           (error "No settable slots."))
 378         (if (view-database obj)
 379             (update-records (sql-expression :table view-class-table)
 380                             :av-pairs record-values
 381                             :where (key-qualifier-for-instance
 382                                     obj :database database)
 383                             :database database)
 384             (progn
 385               (insert-records :into (sql-expression :table view-class-table)
 386                               :av-pairs record-values
 387                               :database database)
 388               (setf (slot-value obj 'view-database) database))))))
 389   (values))
 390
 391 (defmethod delete-instance-records ((instance standard-db-object))
 392   (let ((vt (sql-expression :table (view-table (class-of instance))))
 393         (vd (view-database instance)))
 394     (if vd
 395         (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 396           (delete-records :from vt :where qualifier :database vd)
 397           (setf (slot-value instance 'view-database) nil))
 398         (error 'clsql-base::clsql-no-database-error :database nil))))
 399
 400 (defmethod update-instance-from-records ((instance standard-db-object)
 401                                          &key (database *default-database*))
 402   (let* ((view-class (find-class (class-name (class-of instance))))
 403          (view-table (sql-expression :table (view-table view-class)))
 404          (vd (or (view-database instance) database))
 405          (view-qual (key-qualifier-for-instance instance :database vd))
 406          (sels (generate-selection-list view-class))
 407          (res (apply #'select (append (mapcar #'cdr sels)
 408                                       (list :from  view-table
 409                                             :where view-qual)
 410                                       (list :result-types nil)))))
 411     (when res
 412       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 413
 414 (defmethod update-slot-from-record ((instance standard-db-object)
 415                                     slot &key (database *default-database*))
 416   (let* ((view-class (find-class (class-name (class-of instance))))
 417          (view-table (sql-expression :table (view-table view-class)))
 418          (vd (or (view-database instance) database))
 419          (view-qual (key-qualifier-for-instance instance :database vd))
 420          (slot-def (slotdef-for-slot-with-class slot view-class))
 421          (att-ref (generate-attribute-reference view-class slot-def))
 422          (res (select att-ref :from  view-table :where view-qual
 423                       :result-types nil)))
 424     (when res
 425       (get-slot-values-from-view instance (list slot-def) (car res)))))
 426
 427
 428 (defmethod update-slot-with-null ((object standard-db-object)
 429                                   slotname
 430                                   slotdef)
 431   (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 432
 433 (defvar +no-slot-value+ '+no-slot-value+)
 434
 435 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 436   (let* ((class (find-class classname))
 437          (sld (slotdef-for-slot-with-class slot class)))
 438     (if sld
 439         (if (eq value +no-slot-value+)
 440             (sql-expression :attribute (view-class-slot-column sld)
 441                             :table (view-table class))
 442             (db-value-from-slot
 443              sld
 444              value
 445              database))
 446         (error "Unknown slot ~A for class ~A" slot classname))))
 447
 448 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 449         (declare (ignore database))
 450         (let* ((class (find-class classname)))
 451           (unless (view-table class)
 452             (error "No view-table for class ~A"  classname))
 453           (sql-expression :table (view-table class))))
 454
 455 (defmethod database-get-type-specifier (type args database)
 456   (declare (ignore type args))
 457   (if (clsql-base::in (database-underlying-type database)
 458                           :postgresql :postgresql-socket)
 459           "VARCHAR"
 460           "VARCHAR(255)"))
 461
 462 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 463   (declare (ignore database))
 464   ;;"INT8")
 465   (if args
 466       (format nil "INT(~A)" (car args))
 467       "INT"))
 468
 469 (deftype bigint ()
 470   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
 471   'integer)
 472
 473 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
 474   (declare (ignore args database))
 475   "BIGINT")
 476
 477 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 478                                         database)
 479   (if args
 480       (format nil "VARCHAR(~A)" (car args))
 481     (if (clsql-base::in (database-underlying-type database)
 482                             :postgresql :postgresql-socket)
 483         "VARCHAR"
 484       "VARCHAR(255)")))
 485
 486 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 487                                         database)
 488   (if args
 489       (format nil "VARCHAR(~A)" (car args))
 490     (if (clsql-base::in (database-underlying-type database)
 491                             :postgresql :postgresql-socket)
 492         "VARCHAR"
 493       "VARCHAR(255)")))
 494
 495 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 496   (if args
 497       (format nil "VARCHAR(~A)" (car args))
 498     (if (clsql-base::in (database-underlying-type database)
 499                             :postgresql :postgresql-socket)
 500         "VARCHAR"
 501       "VARCHAR(255)")))
 502
 503 (deftype universal-time ()
 504   "A positive integer as returned by GET-UNIVERSAL-TIME."
 505   '(integer 1 *))
 506
 507 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
 508   (declare (ignore args database))
 509   "BIGINT")
 510
 511 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 512   (declare (ignore args))
 513   (case (database-underlying-type database)
 514     ((:postgresql :postgresql-socket)
 515      "TIMESTAMP WITHOUT TIME ZONE")
 516     (:mysql
 517      "DATETIME")
 518     (t "TIMESTAMP")))
 519
 520 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 521   (declare (ignore database args))
 522   "VARCHAR")
 523
 524 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
 525   (declare (ignore database args))
 526   "INT8")
 527
 528 (deftype raw-string (&optional len)
 529   "A string which is not trimmed when retrieved from the database"
 530   `(string ,len))
 531
 532 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 533   (declare (ignore database))
 534   (if args
 535       (format nil "VARCHAR(~A)" (car args))
 536       "VARCHAR"))
 537
 538 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 539   (declare (ignore database))
 540   (if args
 541       (format nil "FLOAT(~A)" (car args))
 542       "FLOAT"))
 543
 544 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 545   (declare (ignore database))
 546   (if args
 547       (format nil "FLOAT(~A)" (car args))
 548       "FLOAT"))
 549
 550 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
 551   (declare (ignore args database))
 552   "BOOL")
 553
 554 (defmethod database-output-sql-as-type (type val database)
 555   (declare (ignore type database))
 556   val)
 557
 558 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 559   (declare (ignore database))
 560   (progv '(*print-circle* *print-array*) '(t t)
 561     (let ((escaped (prin1-to-string val)))
 562       (clsql-base::substitute-char-string
 563        escaped #\Null " "))))
 564
 565 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 566   (declare (ignore database))
 567   (if (keywordp val)
 568       (symbol-name val)
 569       (if val
 570           (concatenate 'string
 571                        (package-name (symbol-package val))
 572                        "::"
 573                        (symbol-name val))
 574           "")))
 575
 576 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 577   (declare (ignore database))
 578   (if val
 579       (symbol-name val)
 580       ""))
 581
 582 (defmethod database-output-sql-as-type ((type (eql 'vector)) 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 'array)) val database)
 588   (declare (ignore database))
 589   (progv '(*print-circle* *print-array*) '(t t)
 590     (prin1-to-string val)))
 591
 592 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
 593   (case (database-underlying-type database)
 594     (:mysql
 595      (if val 1 0))
 596     (t
 597      (if val "t" "f"))))
 598
 599 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 600   (declare (ignore database))
 601   val)
 602
 603 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 604                                         val database)
 605   (declare (ignore database))
 606   val)
 607
 608 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 609                                         val database)
 610   (declare (ignore database))
 611   val)
 612
 613 (defmethod read-sql-value (val type database)
 614   (declare (ignore type database))
 615   (read-from-string val))
 616
 617 (defmethod read-sql-value (val (type (eql 'string)) database)
 618   (declare (ignore database))
 619   val)
 620
 621 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 622   (declare (ignore database))
 623   val)
 624
 625 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 626   (declare (ignore database))
 627   val)
 628
 629 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 630   (declare (ignore database))
 631   val)
 632
 633 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 634   (declare (ignore database))
 635   (when (< 0 (length val))
 636     (intern (symbol-name-default-case val)
 637             (find-package '#:keyword))))
 638
 639 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 640   (declare (ignore database))
 641   (when (< 0 (length val))
 642     (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
 643       (intern (clsql-base:symbol-name-default-case val)
 644               (symbol-package *update-context*)))))
 645
 646 (defmethod read-sql-value (val (type (eql 'integer)) database)
 647   (declare (ignore database))
 648   (etypecase val
 649     (string
 650      (unless (string-equal "NIL" val)
 651        (parse-integer val)))
 652     (number val)))
 653
 654 (defmethod read-sql-value (val (type (eql 'bigint)) database)
 655   (declare (ignore database))
 656   (etypecase val
 657     (string
 658      (unless (string-equal "NIL" val)
 659        (parse-integer val)))
 660     (number val)))
 661
 662 (defmethod read-sql-value (val (type (eql 'float)) database)
 663   (declare (ignore database))
 664   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 665   (float (read-from-string val)))
 666
 667 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 668   (case (database-underlying-type database)
 669     (:mysql
 670      (etypecase val
 671        (string (if (string= "0" val) nil t))
 672        (integer (if (zerop val) nil t))))
 673     (:postgresql
 674      (if (eq :odbc (database-type database))
 675          (if (string= "0" val) nil t)
 676        (equal "t" val)))
 677     (t
 678      (equal "t" val))))
 679
 680 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
 681   (declare (ignore database))
 682   (unless (eq 'NULL val)
 683     (etypecase val
 684       (string
 685        (parse-integer val))
 686       (number val))))
 687
 688 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 689   (declare (ignore database))
 690   (unless (eq 'NULL val)
 691     (parse-timestring val)))
 692
 693 (defmethod read-sql-value (val (type (eql 'duration)) database)
 694   (declare (ignore database))
 695   (unless (or (eq 'NULL val)
 696               (equal "NIL" val))
 697     (parse-timestring val)))
 698
 699 ;; ------------------------------------------------------------
 700 ;; Logic for 'faulting in' :join slots
 701
 702 (defun fault-join-slot-raw (class object slot-def)
 703   (let* ((dbi (view-class-slot-db-info slot-def))
 704          (jc (gethash :join-class dbi)))
 705     (let ((jq (join-qualifier class object slot-def)))
 706       (when jq
 707         (select jc :where jq :flatp t :result-types nil)))))
 708
 709 (defun fault-join-slot (class object slot-def)
 710   (let* ((dbi (view-class-slot-db-info slot-def))
 711          (ts (gethash :target-slot dbi))
 712          (res (fault-join-slot-raw class object slot-def)))
 713     (when res
 714       (cond
 715         ((and ts (gethash :set dbi))
 716          (mapcar (lambda (obj)
 717                    (cons obj (slot-value obj ts))) res))
 718         ((and ts (not (gethash :set dbi)))
 719          (mapcar (lambda (obj) (slot-value obj ts)) res))
 720         ((and (not ts) (not (gethash :set dbi)))
 721          (car res))
 722         ((and (not ts) (gethash :set dbi))
 723          res)))))
 724
 725 (defun join-qualifier (class object slot-def)
 726     (declare (ignore class))
 727     (let* ((dbi (view-class-slot-db-info slot-def))
 728            (jc (find-class (gethash :join-class dbi)))
 729            ;;(ts (gethash :target-slot dbi))
 730            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 731            (foreign-keys (gethash :foreign-key dbi))
 732            (home-keys (gethash :home-key dbi)))
 733       (when (every #'(lambda (slt)
 734                        (and (slot-boundp object slt)
 735                             (not (null (slot-value object slt)))))
 736                    (if (listp home-keys) home-keys (list home-keys)))
 737         (let ((jc
 738                (mapcar #'(lambda (hk fk)
 739                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 740                              (sql-operation '==
 741                                             (typecase fk
 742                                               (symbol
 743                                                (sql-expression
 744                                                 :attribute
 745                                                 (view-class-slot-column fksd)
 746                                                 :table (view-table jc)))
 747                                               (t fk))
 748                                             (typecase hk
 749                                               (symbol
 750                                                (slot-value object hk))
 751                                               (t
 752                                                hk)))))
 753                        (if (listp home-keys)
 754                            home-keys
 755                            (list home-keys))
 756                        (if (listp foreign-keys)
 757                            foreign-keys
 758                            (list foreign-keys)))))
 759           (when jc
 760             (if (> (length jc) 1)
 761                 (apply #'sql-and jc)
 762                 jc))))))
 763
 764 (defun find-all (view-classes &rest args &key all set-operation distinct from
 765                  where group-by having order-by order-by-descending offset limit
 766                  refresh flatp (database *default-database*))
 767   "Called by SELECT to generate object query results when the
 768   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 769   (declare (ignore all set-operation group-by having offset limit)
 770            (optimize (debug 3) (speed 1)))
 771   (remf args :from)
 772   (remf args :flatp)
 773   (remf args :result-types)
 774   (labels ((table-sql-expr (table)
 775              (sql-expression :table (view-table table)))
 776            (ref-equal (ref1 ref2)
 777              (equal (sql ref1)
 778                     (sql ref2)))
 779            (tables-equal (table-a table-b)
 780              (string= (string (slot-value table-a 'name))
 781                       (string (slot-value table-b 'name))))
 782            (build-object (vals vclass selects)
 783              (let* ((class-name (class-name vclass))
 784                     (db-vals (butlast vals (- (list-length vals)
 785                                               (list-length selects))))
 786                     (*db-initializing* t)
 787                     (obj (make-instance class-name :view-database database)))
 788                ;; use refresh keyword here
 789                (setf obj (get-slot-values-from-view obj (mapcar #'car selects)
 790                                                     db-vals))
 791                (when refresh (instance-refreshed obj))
 792                obj))
 793            (build-objects (vals sclasses sels)
 794              (let ((objects (mapcar #'(lambda (sclass sel)
 795                                         (prog1 (build-object vals sclass sel)
 796                                           (setf vals (nthcdr (list-length sel)
 797                                                              vals))))
 798                                     sclasses sels)))
 799                (if (and flatp (= (length sclasses) 1))
 800                    (car objects)
 801                    objects))))
 802     (let* ((*db-deserializing* t)
 803            (*default-database* (or database
 804                                    (error 'clsql-base::clsql-no-database-error :database nil)))
 805            (sclasses (mapcar #'find-class view-classes))
 806            (sels (mapcar #'generate-selection-list sclasses))
 807            (fullsels (apply #'append sels))
 808            (sel-tables (collect-table-refs where))
 809            (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
 810                                               sel-tables)
 811                                       :test #'tables-equal))
 812            (res nil))
 813         (dolist (ob (listify order-by))
 814           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 815                                      :test #'ref-equal)))
 816             (setq fullsels
 817                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 818                                            (listify ob))))))
 819         (dolist (ob (listify order-by-descending))
 820           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 821                                      :test #'ref-equal)))
 822             (setq fullsels
 823                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 824                                            (listify ob))))))
 825         (dolist (ob (listify distinct))
 826           (when (and (typep ob 'sql-ident)
 827                      (not (member ob (mapcar #'cdr fullsels)
 828                                   :test #'ref-equal)))
 829             (setq fullsels
 830                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 831                                            (listify ob))))))
 832         (setq res
 833               (apply #'select
 834                      (append (mapcar #'cdr fullsels)
 835                              (cons :from
 836                                    (list (append (when from (listify from))
 837                                                  (listify tables))))
 838                              (list :result-types nil)
 839                              args)))
 840         (mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
 841
 842 (defmethod instance-refreshed ((instance standard-db-object)))
 843
 844 (defmethod select (&rest select-all-args)
 845   "Selects data from database given the constraints specified. Returns
 846 a list of lists of record values as specified by select-all-args. By
 847 default, the records are each represented as lists of attribute
 848 values. The selections argument may be either db-identifiers, literal
 849 strings or view classes.  If the argument consists solely of view
 850 classes, the return value will be instances of objects rather than raw
 851 tuples."
 852   (flet ((select-objects (target-args)
 853            (and target-args
 854                 (every #'(lambda (arg)
 855                            (and (symbolp arg)
 856                                 (find-class arg nil)))
 857                        target-args))))
 858     (multiple-value-bind (target-args qualifier-args)
 859         (query-get-selections select-all-args)
 860       (if (select-objects target-args)
 861           (apply #'find-all target-args qualifier-args)
 862           (let ((expr (apply #'make-query select-all-args)))
 863             (destructuring-bind (&key (flatp nil)
 864                                       (result-types :auto)
 865                                       (field-names t)
 866                                       (database *default-database*)
 867                                       &allow-other-keys)
 868                 qualifier-args
 869               (query expr :flatp flatp :result-types result-types
 870                      :field-names field-names :database database)))))))
 871