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