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)
  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-auto-sync* nil
  25   "A non-nil value means that creating View Class instances or
  26   setting their slots automatically creates/updates the
  27   corresponding records in the underlying database.")
  28
  29 (defvar *db-deserializing* nil)
  30 (defvar *db-initializing* nil)
  31
  32 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
  33   (declare (optimize (speed 3)))
  34   (unless *db-deserializing*
  35     (let* ((slot-name (%svuc-slot-name slot-def))
  36            (slot-object (%svuc-slot-object slot-def class))
  37            (slot-kind (view-class-slot-db-kind slot-object)))
  38       (when (and (eql slot-kind :join)
  39                  (not (slot-boundp instance slot-name)))
  40         (let ((*db-deserializing* t))
  41           (if (view-database instance)
  42               (setf (slot-value instance slot-name)
  43                     (fault-join-slot class instance slot-object))
  44               (setf (slot-value instance slot-name) nil))))))
  45   (call-next-method))
  46
  47 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
  48                                           instance slot-def)
  49   (declare (ignore new-value))
  50   (let ((slot-name (%svuc-slot-name slot-def))
  51         (slot-kind (view-class-slot-db-kind slot-def)))
  52     (call-next-method)
  53     (when (and *db-auto-sync*
  54                (not *db-initializing*)
  55                (not *db-deserializing*)
  56                (not (eql slot-kind :virtual)))
  57       (update-record-from-slot instance slot-name))))
  58
  59 (defmethod initialize-instance ((object standard-db-object)
  60                                         &rest all-keys &key &allow-other-keys)
  61   (declare (ignore all-keys))
  62   (let ((*db-initializing* t))
  63     (call-next-method)
  64     (when (and *db-auto-sync*
  65                (not *db-deserializing*))
  66       (update-records-from-instance object))))
  67
  68 ;;
  69 ;; Build the database tables required to store the given view class
  70 ;;
  71
  72 (defun create-view-from-class (view-class-name
  73                                &key (database *default-database*))
  74   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
  75 the view. The argument DATABASE has a default value of
  76 *DEFAULT-DATABASE*."
  77   (let ((tclass (find-class view-class-name)))
  78     (if tclass
  79         (let ((*default-database* database))
  80           (%install-class tclass database))
  81         (error "Class ~s not found." view-class-name)))
  82   (values))
  83
  84 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
  85   (dolist (slotdef (ordered-class-slots self))
  86     (let ((res (database-generate-column-definition (class-name self)
  87                                                     slotdef database)))
  88       (when res
  89         (push res schemadef))))
  90   (unless schemadef
  91     (error "Class ~s has no :base slots" self))
  92   (create-table (sql-expression :table (view-table self)) schemadef
  93                 :database database
  94                 :constraints (database-pkey-constraint self database))
  95   (push self (database-view-classes database))
  96   t)
  97
  98 (defmethod database-pkey-constraint ((class standard-db-class) database)
  99   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
 100     (when keylist
 101       (convert-to-db-default-case
 102        (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
 103                (database-output-sql (view-table class) database)
 104                (database-output-sql keylist database))
 105        database))))
 106
 107 (defmethod database-generate-column-definition (class slotdef database)
 108   (declare (ignore database class))
 109   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
 110     (let ((cdef
 111            (list (sql-expression :attribute (view-class-slot-column slotdef))
 112                  (specified-type slotdef))))
 113       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
 114       (let ((const (view-class-slot-db-constraints slotdef)))
 115         (when const
 116           (setq cdef (append cdef (list const)))))
 117       cdef)))
 118
 119
 120 ;;
 121 ;; Drop the tables which store the given view class
 122 ;;
 123
 124 (defun drop-view-from-class (view-class-name &key (database *default-database*))
 125   "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
 126 which defines that view. The argument DATABASE has a default value of
 127 *DEFAULT-DATABASE*."
 128   (let ((tclass (find-class view-class-name)))
 129     (if tclass
 130         (let ((*default-database* database))
 131           (%uninstall-class tclass))
 132         (error "Class ~s not found." view-class-name)))
 133   (values))
 134
 135 (defun %uninstall-class (self &key (database *default-database*))
 136   (drop-table (sql-expression :table (view-table self))
 137               :if-does-not-exist :ignore
 138               :database database)
 139   (setf (database-view-classes database)
 140         (remove self (database-view-classes database))))
 141
 142
 143 ;;
 144 ;; List all known view classes
 145 ;;
 146
 147 (defun list-classes (&key (test #'identity)
 148                      (root-class (find-class 'standard-db-object))
 149                      (database *default-database*))
 150   "The LIST-CLASSES function collects all the classes below
 151 ROOT-CLASS, which defaults to standard-db-object, that are connected
 152 to the supplied DATABASE and which satisfy the TEST function. The
 153 default for the TEST argument is identity. By default, LIST-CLASSES
 154 returns a list of all the classes connected to the default database,
 155 *DEFAULT-DATABASE*."
 156   (flet ((find-superclass (class)
 157            (member root-class (class-precedence-list class))))
 158     (let ((view-classes (and database (database-view-classes database))))
 159       (when view-classes
 160         (remove-if #'(lambda (c) (or (not (funcall test c))
 161                                      (not (find-superclass c))))
 162                    view-classes)))))
 163
 164 ;;
 165 ;; Define a new view class
 166 ;;
 167
 168 (defmacro def-view-class (class supers slots &rest cl-options)
 169   "Extends the syntax of defclass to allow special slots to be mapped
 170 onto the attributes of database views. The macro DEF-VIEW-CLASS
 171 creates a class called CLASS which maps onto a database view. Such a
 172 class is called a View Class. The macro DEF-VIEW-CLASS extends the
 173 syntax of DEFCLASS to allow special base slots to be mapped onto the
 174 attributes of database views (presently single tables). When a select
 175 query that names a View Class is submitted, then the corresponding
 176 database view is queried, and the slots in the resulting View Class
 177 instances are filled with attribute values from the database. If
 178 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
 179 superclass of the newly-defined View Class."
 180   `(progn
 181     (defclass ,class ,supers ,slots
 182       ,@(if (find :metaclass `,cl-options :key #'car)
 183             `,cl-options
 184             (cons '(:metaclass clsql::standard-db-class) `,cl-options)))
 185     (finalize-inheritance (find-class ',class))
 186     (find-class ',class)))
 187
 188 (defun keyslots-for-class (class)
 189   (slot-value class 'key-slots))
 190
 191 (defun key-qualifier-for-instance (obj &key (database *default-database*))
 192   (let ((tb (view-table (class-of obj))))
 193     (flet ((qfk (k)
 194              (sql-operation '==
 195                             (sql-expression :attribute
 196                                             (view-class-slot-column k)
 197                                             :table tb)
 198                             (db-value-from-slot
 199                              k
 200                              (slot-value obj (slot-definition-name k))
 201                              database))))
 202       (let* ((keys (keyslots-for-class (class-of obj)))
 203              (keyxprs (mapcar #'qfk (reverse keys))))
 204         (cond
 205           ((= (length keyxprs) 0) nil)
 206           ((= (length keyxprs) 1) (car keyxprs))
 207           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
 208
 209 ;;
 210 ;; Function used by 'generate-selection-list'
 211 ;;
 212
 213 (defun generate-attribute-reference (vclass slotdef)
 214   (cond
 215    ((eq (view-class-slot-db-kind slotdef) :base)
 216     (sql-expression :attribute (view-class-slot-column slotdef)
 217                     :table (view-table vclass)))
 218    ((eq (view-class-slot-db-kind slotdef) :key)
 219     (sql-expression :attribute (view-class-slot-column slotdef)
 220                     :table (view-table vclass)))
 221    (t nil)))
 222
 223 ;;
 224 ;; Function used by 'find-all'
 225 ;;
 226
 227 (defun generate-selection-list (vclass)
 228   (let ((sels nil))
 229     (dolist (slotdef (ordered-class-slots vclass))
 230       (let ((res (generate-attribute-reference vclass slotdef)))
 231         (when res
 232           (push (cons slotdef res) sels))))
 233     (if sels
 234         sels
 235         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 236
 237
 238 ;;
 239 ;; Called by 'get-slot-values-from-view'
 240 ;;
 241
 242 (declaim (inline delistify))
 243 (defun delistify (list)
 244   (if (listp list)
 245       (car list)
 246       list))
 247
 248 (defvar *update-context* nil)
 249
 250 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
 251   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 252   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 253          (slot-name   (slot-definition-name slotdef))
 254          (slot-type   (specified-type slotdef))
 255          (*update-context* (cons (type-of instance) slot-name)))
 256     (cond ((and value (null slot-reader))
 257            (setf (slot-value instance slot-name)
 258                  (read-sql-value value (delistify slot-type)
 259                                  (view-database instance))))
 260           ((null value)
 261            (update-slot-with-null instance slot-name slotdef))
 262           ((typep slot-reader 'string)
 263            (setf (slot-value instance slot-name)
 264                  (format nil slot-reader value)))
 265           ((typep slot-reader 'function)
 266            (setf (slot-value instance slot-name)
 267                  (apply slot-reader (list value))))
 268           (t
 269            (error "Slot reader is of an unusual type.")))))
 270
 271 (defmethod key-value-from-db (slotdef value database)
 272   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 273   (let ((slot-reader (view-class-slot-db-reader slotdef))
 274         (slot-type (specified-type slotdef)))
 275     (cond ((and value (null slot-reader))
 276            (read-sql-value value (delistify slot-type) database))
 277           ((null value)
 278            nil)
 279           ((typep slot-reader 'string)
 280            (format nil slot-reader value))
 281           ((typep slot-reader 'function)
 282            (apply slot-reader (list value)))
 283           (t
 284            (error "Slot reader is of an unusual type.")))))
 285
 286 (defun db-value-from-slot (slotdef val database)
 287   (let ((dbwriter (view-class-slot-db-writer slotdef))
 288         (dbtype (specified-type slotdef)))
 289     (typecase dbwriter
 290       (string (format nil dbwriter val))
 291       (function (apply dbwriter (list val)))
 292       (t
 293        (typecase dbtype
 294          (cons
 295           (database-output-sql-as-type (car dbtype) val database))
 296          (t
 297           (database-output-sql-as-type dbtype val database)))))))
 298
 299 (defun check-slot-type (slotdef val)
 300   (let* ((slot-type (specified-type slotdef))
 301          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 302     (when (and slot-type val)
 303       (unless (typep val basetype)
 304         (error 'clsql-type-error
 305                :slotname (slot-definition-name slotdef)
 306                :typespec slot-type
 307                :value val)))))
 308
 309 ;;
 310 ;; Called by find-all
 311 ;;
 312
 313 (defmethod get-slot-values-from-view (obj slotdeflist values)
 314     (flet ((update-slot (slot-def values)
 315              (update-slot-from-db obj slot-def values)))
 316       (mapc #'update-slot slotdeflist values)
 317       obj))
 318
 319 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 320                                     (database *default-database*))
 321   (let* ((database (or (view-database obj) database))
 322          (vct (view-table (class-of obj)))
 323          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 324     (check-slot-type sd (slot-value obj slot))
 325     (let* ((att (view-class-slot-column sd))
 326            (val (db-value-from-slot sd (slot-value obj slot) database)))
 327       (cond ((and vct sd (view-database obj))
 328              (update-records (sql-expression :table vct)
 329                              :attributes (list (sql-expression :attribute att))
 330                              :values (list val)
 331                              :where (key-qualifier-for-instance
 332                                      obj :database database)
 333                              :database database))
 334             ((and vct sd (not (view-database obj)))
 335              (insert-records :into (sql-expression :table vct)
 336                              :attributes (list (sql-expression :attribute att))
 337                              :values (list val)
 338                              :database database)
 339              (setf (slot-value obj 'view-database) database))
 340             (t
 341              (error "Unable to update record.")))))
 342   (values))
 343
 344 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 345                                      (database *default-database*))
 346   (let* ((database (or (view-database obj) database))
 347          (vct (view-table (class-of obj)))
 348          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 349          (avps (mapcar #'(lambda (s)
 350                            (let ((val (slot-value
 351                                        obj (slot-definition-name s))))
 352                              (check-slot-type s val)
 353                              (list (sql-expression
 354                                     :attribute (view-class-slot-column s))
 355                                    (db-value-from-slot s val database))))
 356                        sds)))
 357     (cond ((and avps (view-database obj))
 358            (update-records (sql-expression :table vct)
 359                            :av-pairs avps
 360                            :where (key-qualifier-for-instance
 361                                    obj :database database)
 362                            :database database))
 363           ((and avps (not (view-database obj)))
 364            (insert-records :into (sql-expression :table vct)
 365                            :av-pairs avps
 366                            :database database)
 367            (setf (slot-value obj 'view-database) database))
 368           (t
 369            (error "Unable to update records"))))
 370   (values))
 371
 372 (defmethod update-records-from-instance ((obj standard-db-object)
 373                                          &key (database *default-database*))
 374   (let ((database (or (view-database obj) database)))
 375     (labels ((slot-storedp (slot)
 376                (and (member (view-class-slot-db-kind slot) '(:base :key))
 377                     (slot-boundp obj (slot-definition-name slot))))
 378              (slot-value-list (slot)
 379                (let ((value (slot-value obj (slot-definition-name slot))))
 380                  (check-slot-type slot value)
 381                  (list (sql-expression :attribute (view-class-slot-column slot))
 382                        (db-value-from-slot slot value database)))))
 383       (let* ((view-class (class-of obj))
 384              (view-class-table (view-table view-class))
 385              (slots (remove-if-not #'slot-storedp
 386                                    (ordered-class-slots view-class)))
 387              (record-values (mapcar #'slot-value-list slots)))
 388         (unless record-values
 389           (error "No settable slots."))
 390         (if (view-database obj)
 391             (update-records (sql-expression :table view-class-table)
 392                             :av-pairs record-values
 393                             :where (key-qualifier-for-instance
 394                                     obj :database database)
 395                             :database database)
 396             (progn
 397               (insert-records :into (sql-expression :table view-class-table)
 398                               :av-pairs record-values
 399                               :database database)
 400               (setf (slot-value obj 'view-database) database))))))
 401   (values))
 402
 403 (defmethod delete-instance-records ((instance standard-db-object))
 404   (let ((vt (sql-expression :table (view-table (class-of instance))))
 405         (vd (view-database instance)))
 406     (if vd
 407         (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 408           (delete-records :from vt :where qualifier :database vd)
 409           (setf (slot-value instance 'view-database) nil))
 410         (error 'clsql-base::clsql-no-database-error :database nil))))
 411
 412 (defmethod update-instance-from-records ((instance standard-db-object)
 413                                          &key (database *default-database*))
 414   (let* ((view-class (find-class (class-name (class-of instance))))
 415          (view-table (sql-expression :table (view-table view-class)))
 416          (vd (or (view-database instance) database))
 417          (view-qual (key-qualifier-for-instance instance :database vd))
 418          (sels (generate-selection-list view-class))
 419          (res (apply #'select (append (mapcar #'cdr sels)
 420                                       (list :from  view-table
 421                                             :where view-qual)
 422                                       (list :result-types nil)))))
 423     (when res
 424       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 425
 426 (defmethod update-slot-from-record ((instance standard-db-object)
 427                                     slot &key (database *default-database*))
 428   (let* ((view-class (find-class (class-name (class-of instance))))
 429          (view-table (sql-expression :table (view-table view-class)))
 430          (vd (or (view-database instance) database))
 431          (view-qual (key-qualifier-for-instance instance :database vd))
 432          (slot-def (slotdef-for-slot-with-class slot view-class))
 433          (att-ref (generate-attribute-reference view-class slot-def))
 434          (res (select att-ref :from  view-table :where view-qual
 435                       :result-types nil)))
 436     (when res
 437       (get-slot-values-from-view instance (list slot-def) (car res)))))
 438
 439
 440 (defmethod update-slot-with-null ((object standard-db-object)
 441                                   slotname
 442                                   slotdef)
 443   (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 444
 445 (defvar +no-slot-value+ '+no-slot-value+)
 446
 447 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 448   (let* ((class (find-class classname))
 449          (sld (slotdef-for-slot-with-class slot class)))
 450     (if sld
 451         (if (eq value +no-slot-value+)
 452             (sql-expression :attribute (view-class-slot-column sld)
 453                             :table (view-table class))
 454             (db-value-from-slot
 455              sld
 456              value
 457              database))
 458         (error "Unknown slot ~A for class ~A" slot classname))))
 459
 460 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 461         (declare (ignore database))
 462         (let* ((class (find-class classname)))
 463           (unless (view-table class)
 464             (error "No view-table for class ~A"  classname))
 465           (sql-expression :table (view-table class))))
 466
 467 (defmethod database-get-type-specifier (type args database)
 468   (declare (ignore type args))
 469   (if (clsql-base::in (database-underlying-type database)
 470                           :postgresql :postgresql-socket)
 471           "VARCHAR"
 472           "VARCHAR(255)"))
 473
 474 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 475   (declare (ignore database))
 476   ;;"INT8")
 477   (if args
 478       (format nil "INT(~A)" (car args))
 479       "INT"))
 480
 481 (deftype bigint ()
 482   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
 483   'integer)
 484
 485 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
 486   (declare (ignore args database))
 487   "BIGINT")
 488
 489 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 490                                         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 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 499                                         database)
 500   (if args
 501       (format nil "VARCHAR(~A)" (car args))
 502     (if (clsql-base::in (database-underlying-type database)
 503                             :postgresql :postgresql-socket)
 504         "VARCHAR"
 505       "VARCHAR(255)")))
 506
 507 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 508   (if args
 509       (format nil "VARCHAR(~A)" (car args))
 510     (if (clsql-base::in (database-underlying-type database)
 511                             :postgresql :postgresql-socket)
 512         "VARCHAR"
 513       "VARCHAR(255)")))
 514
 515 (deftype universal-time ()
 516   "A positive integer as returned by GET-UNIVERSAL-TIME."
 517   '(integer 1 *))
 518
 519 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
 520   (declare (ignore args database))
 521   "BIGINT")
 522
 523 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 524   (declare (ignore args))
 525   (case (database-underlying-type database)
 526     ((:postgresql :postgresql-socket)
 527      "TIMESTAMP WITHOUT TIME ZONE")
 528     (:mysql
 529      "DATETIME")
 530     (t "TIMESTAMP")))
 531
 532 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 533   (declare (ignore database args))
 534   "VARCHAR")
 535
 536 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
 537   (declare (ignore database args))
 538   "INT8")
 539
 540 (deftype raw-string (&optional len)
 541   "A string which is not trimmed when retrieved from the database"
 542   `(string ,len))
 543
 544 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 545   (declare (ignore database))
 546   (if args
 547       (format nil "VARCHAR(~A)" (car args))
 548       "VARCHAR"))
 549
 550 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 551   (declare (ignore database))
 552   (if args
 553       (format nil "FLOAT(~A)" (car args))
 554       "FLOAT"))
 555
 556 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 557   (declare (ignore database))
 558   (if args
 559       (format nil "FLOAT(~A)" (car args))
 560       "FLOAT"))
 561
 562 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
 563   (declare (ignore args database))
 564   "BOOL")
 565
 566 (defmethod database-output-sql-as-type (type val database)
 567   (declare (ignore type database))
 568   val)
 569
 570 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 571   (declare (ignore database))
 572   (progv '(*print-circle* *print-array*) '(t t)
 573     (let ((escaped (prin1-to-string val)))
 574       (clsql-base::substitute-char-string
 575        escaped #\Null " "))))
 576
 577 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 578   (declare (ignore database))
 579   (if (keywordp val)
 580       (symbol-name val)
 581       (if val
 582           (concatenate 'string
 583                        (package-name (symbol-package val))
 584                        "::"
 585                        (symbol-name val))
 586           "")))
 587
 588 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 589   (declare (ignore database))
 590   (if val
 591       (symbol-name val)
 592       ""))
 593
 594 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
 595   (declare (ignore database))
 596   (progv '(*print-circle* *print-array*) '(t t)
 597     (prin1-to-string val)))
 598
 599 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
 600   (declare (ignore database))
 601   (progv '(*print-circle* *print-array*) '(t t)
 602     (prin1-to-string val)))
 603
 604 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
 605   (case (database-underlying-type database)
 606     (:mysql
 607      (if val 1 0))
 608     (t
 609      (if val "t" "f"))))
 610
 611 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 612   (declare (ignore database))
 613   val)
 614
 615 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 616                                         val database)
 617   (declare (ignore database))
 618   val)
 619
 620 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 621                                         val database)
 622   (declare (ignore database))
 623   val)
 624
 625 (defmethod read-sql-value (val type database)
 626   (declare (ignore type database))
 627   (read-from-string val))
 628
 629 (defmethod read-sql-value (val (type (eql 'string)) database)
 630   (declare (ignore database))
 631   val)
 632
 633 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 634   (declare (ignore database))
 635   val)
 636
 637 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 638   (declare (ignore database))
 639   val)
 640
 641 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 642   (declare (ignore database))
 643   val)
 644
 645 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 646   (declare (ignore database))
 647   (when (< 0 (length val))
 648     (intern (symbol-name-default-case val)
 649             (find-package '#:keyword))))
 650
 651 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 652   (declare (ignore database))
 653   (when (< 0 (length val))
 654     (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
 655       (intern (clsql-base:symbol-name-default-case val)
 656               (symbol-package *update-context*)))))
 657
 658 (defmethod read-sql-value (val (type (eql 'integer)) database)
 659   (declare (ignore database))
 660   (etypecase val
 661     (string
 662      (unless (string-equal "NIL" val)
 663        (parse-integer val)))
 664     (number val)))
 665
 666 (defmethod read-sql-value (val (type (eql 'bigint)) database)
 667   (declare (ignore database))
 668   (etypecase val
 669     (string
 670      (unless (string-equal "NIL" val)
 671        (parse-integer val)))
 672     (number val)))
 673
 674 (defmethod read-sql-value (val (type (eql 'float)) database)
 675   (declare (ignore database))
 676   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 677   (float (read-from-string val)))
 678
 679 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 680   (case (database-underlying-type database)
 681     (:mysql
 682      (etypecase val
 683        (string (if (string= "0" val) nil t))
 684        (integer (if (zerop val) nil t))))
 685     (:postgresql
 686      (if (eq :odbc (database-type database))
 687          (if (string= "0" val) nil t)
 688        (equal "t" val)))
 689     (t
 690      (equal "t" val))))
 691
 692 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
 693   (declare (ignore database))
 694   (unless (eq 'NULL val)
 695     (etypecase val
 696       (string
 697        (parse-integer val))
 698       (number val))))
 699
 700 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 701   (declare (ignore database))
 702   (unless (eq 'NULL val)
 703     (parse-timestring val)))
 704
 705 (defmethod read-sql-value (val (type (eql 'duration)) database)
 706   (declare (ignore database))
 707   (unless (or (eq 'NULL val)
 708               (equal "NIL" val))
 709     (parse-timestring val)))
 710
 711 ;; ------------------------------------------------------------
 712 ;; Logic for 'faulting in' :join slots
 713
 714 ;; this works, but is inefficient requiring (+ 1 n-rows)
 715 ;; SQL queries
 716 #+ignore
 717 (defun fault-join-target-slot (class object slot-def)
 718   (let* ((res (fault-join-slot-raw class object slot-def))
 719          (dbi (view-class-slot-db-info slot-def))
 720          (target-name (gethash :target-slot dbi))
 721          (target-class (find-class target-name)))
 722     (when res
 723       (mapcar (lambda (obj)
 724                 (list
 725                  (car
 726                   (fault-join-slot-raw
 727                    target-class
 728                    obj
 729                    (find target-name (class-slots (class-of obj))
 730                          :key #'slot-definition-name)))
 731                  obj))
 732               res)
 733       #+ignore ;; this doesn't work when attempting to call slot-value
 734       (mapcar (lambda (obj)
 735                 (cons obj (slot-value obj ts))) res))))
 736
 737 (defun fault-join-target-slot (class object slot-def)
 738   (let* ((dbi (view-class-slot-db-info slot-def))
 739          (ts (gethash :target-slot dbi))
 740          (jc (gethash :join-class dbi))
 741          (ts-view-table (view-table (find-class ts)))
 742          (jc-view-table (view-table (find-class jc)))
 743          (tdbi (view-class-slot-db-info
 744                 (find ts (class-slots (find-class jc))
 745                       :key #'slot-definition-name)))
 746          (retrieval (gethash :retrieval tdbi))
 747          (jq (join-qualifier class object slot-def))
 748          (key (slot-value object (gethash :home-key dbi))))
 749     (when jq
 750       (ecase retrieval
 751         (:immediate
 752          (let ((res
 753                 (find-all (list ts)
 754                           :inner-join (sql-expression :table jc-view-table)
 755                           :on (sql-operation
 756                                '==
 757                                (sql-expression
 758                                 :attribute (gethash :foreign-key tdbi)
 759                                 :table ts-view-table)
 760                                (sql-expression
 761                                 :attribute (gethash :home-key tdbi)
 762                                 :table jc-view-table))
 763                           :where jq
 764                           :result-types :auto)))
 765            (mapcar #'(lambda (i)
 766                        (let* ((instance (car i))
 767                               (jcc (make-instance jc :view-database (view-database instance))))
 768                          (setf (slot-value jcc (gethash :foreign-key dbi))
 769                                key)
 770                          (setf (slot-value jcc (gethash :home-key tdbi))
 771                                (slot-value instance (gethash :foreign-key tdbi)))
 772                       (list instance jcc)))
 773                    res)))
 774         (:deferred
 775             ;; just fill in minimal slots
 776             (mapcar
 777              #'(lambda (k)
 778                  (let ((instance (make-instance ts :view-database (view-database object)))
 779                        (jcc (make-instance jc :view-database (view-database object)))
 780                        (fk (car k)))
 781                    (setf (slot-value instance (gethash :home-key tdbi)) fk)
 782                    (setf (slot-value jcc (gethash :foreign-key dbi))
 783                          key)
 784                    (setf (slot-value jcc (gethash :home-key tdbi))
 785                          fk)
 786                    (list instance jcc)))
 787              (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
 788                      :from (sql-expression :table jc-view-table)
 789                      :where jq)))))))
 790
 791 (defun update-object-joins (objects &key (slots t) (force-p t)
 792                             class-name (max-len *default-update-objects-max-len*))
 793   "Updates the remote join slots, that is those slots defined without :retrieval :immediate."
 794   (when objects
 795     (unless class-name
 796       (class-name (class-of (first objects))))
 797     )
 798   )
 799
 800
 801 (defun fault-join-slot-raw (class object slot-def)
 802   (let* ((dbi (view-class-slot-db-info slot-def))
 803          (jc (gethash :join-class dbi)))
 804     (let ((jq (join-qualifier class object slot-def)))
 805       (when jq
 806         (select jc :where jq :flatp t :result-types nil)))))
 807
 808 (defun fault-join-slot (class object slot-def)
 809   (let* ((dbi (view-class-slot-db-info slot-def))
 810          (ts (gethash :target-slot dbi)))
 811     (if (and ts (gethash :set dbi))
 812         (fault-join-target-slot class object slot-def)
 813         (let ((res (fault-join-slot-raw class object slot-def)))
 814           (when res
 815             (cond
 816               ((and ts (not (gethash :set dbi)))
 817                (mapcar (lambda (obj) (slot-value obj ts)) res))
 818               ((and (not ts) (not (gethash :set dbi)))
 819                (car res))
 820               ((and (not ts) (gethash :set dbi))
 821                res)))))))
 822
 823 (defun join-qualifier (class object slot-def)
 824     (declare (ignore class))
 825     (let* ((dbi (view-class-slot-db-info slot-def))
 826            (jc (find-class (gethash :join-class dbi)))
 827            ;;(ts (gethash :target-slot dbi))
 828            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 829            (foreign-keys (gethash :foreign-key dbi))
 830            (home-keys (gethash :home-key dbi)))
 831       (when (every #'(lambda (slt)
 832                        (and (slot-boundp object slt)
 833                             (not (null (slot-value object slt)))))
 834                    (if (listp home-keys) home-keys (list home-keys)))
 835         (let ((jc
 836                (mapcar #'(lambda (hk fk)
 837                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 838                              (sql-operation '==
 839                                             (typecase fk
 840                                               (symbol
 841                                                (sql-expression
 842                                                 :attribute
 843                                                 (view-class-slot-column fksd)
 844                                                 :table (view-table jc)))
 845                                               (t fk))
 846                                             (typecase hk
 847                                               (symbol
 848                                                (slot-value object hk))
 849                                               (t
 850                                                hk)))))
 851                        (if (listp home-keys)
 852                            home-keys
 853                            (list home-keys))
 854                        (if (listp foreign-keys)
 855                            foreign-keys
 856                            (list foreign-keys)))))
 857           (when jc
 858             (if (> (length jc) 1)
 859                 (apply #'sql-and jc)
 860                 jc))))))
 861
 862 (defun find-all (view-classes
 863                  &rest args
 864                  &key all set-operation distinct from where group-by having
 865                       order-by order-by-descending offset limit refresh
 866                       flatp result-types inner-join on
 867                       (database *default-database*))
 868   "Called by SELECT to generate object query results when the
 869   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 870   (declare (ignore all set-operation group-by having offset limit inner-join on)
 871            (optimize (debug 3) (speed 1)))
 872   (remf args :from)
 873   (remf args :flatp)
 874   (remf args :additional-fields)
 875   (remf args :result-types)
 876   (labels ((table-sql-expr (table)
 877              (sql-expression :table (view-table table)))
 878            (ref-equal (ref1 ref2)
 879              (equal (sql ref1)
 880                     (sql ref2)))
 881            (tables-equal (table-a table-b)
 882              (string= (string (slot-value table-a 'name))
 883                       (string (slot-value table-b 'name))))
 884            (build-object (vals vclass selects)
 885              (let* ((class-name (class-name vclass))
 886                     (db-vals (butlast vals (- (list-length vals)
 887                                               (list-length selects))))
 888                     (obj (make-instance class-name :view-database database)))
 889                ;; use refresh keyword here
 890                (setf obj (get-slot-values-from-view obj (mapcar #'car selects)
 891                                                     db-vals))
 892                (when refresh (instance-refreshed obj))
 893                obj))
 894            (build-objects (vals sclasses sels)
 895              (let ((objects (mapcar #'(lambda (sclass sel)
 896                                         (prog1 (build-object vals sclass sel)
 897                                           (setf vals (nthcdr (list-length sel)
 898                                                              vals))))
 899                                     sclasses sels)))
 900                (if (and flatp (= (length sclasses) 1))
 901                    (car objects)
 902                    objects))))
 903     (let* ((*db-deserializing* t)
 904            (sclasses (mapcar #'find-class view-classes))
 905            (sels (mapcar #'generate-selection-list sclasses))
 906            (fullsels (apply #'append sels))
 907            (sel-tables (collect-table-refs where))
 908            (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
 909                                               sel-tables)
 910                                       :test #'tables-equal))
 911            (res nil))
 912         (dolist (ob (listify order-by))
 913           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 914                                      :test #'ref-equal)))
 915             (setq fullsels
 916                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 917                                            (listify ob))))))
 918         (dolist (ob (listify order-by-descending))
 919           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 920                                      :test #'ref-equal)))
 921             (setq fullsels
 922                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 923                                            (listify ob))))))
 924         (dolist (ob (listify distinct))
 925           (when (and (typep ob 'sql-ident)
 926                      (not (member ob (mapcar #'cdr fullsels)
 927                                   :test #'ref-equal)))
 928             (setq fullsels
 929                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 930                                            (listify ob))))))
 931         (setq res
 932               (apply #'select
 933                      (append (mapcar #'cdr fullsels)
 934                              (cons :from
 935                                    (list (append (when from (listify from))
 936                                                  (listify tables))))
 937                              (list :result-types result-types)
 938                              args)))
 939         (mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
 940
 941 (defmethod instance-refreshed ((instance standard-db-object)))
 942
 943 (defun select (&rest select-all-args)
 944    "The function SELECT selects data from DATABASE, which has a
 945 default value of *DEFAULT-DATABASE*, given the constraints
 946 specified by the rest of the ARGS. It returns a list of objects
 947 as specified by SELECTIONS. By default, the objects will each be
 948 represented as lists of attribute values. The argument SELECTIONS
 949 consists either of database identifiers, type-modified database
 950 identifiers or literal strings. A type-modifed database
 951 identifier is an expression such as [foo :string] which means
 952 that the values in column foo are returned as Lisp strings.  The
 953 FLATP argument, which has a default value of nil, specifies if
 954 full bracketed results should be returned for each matched
 955 entry. If FLATP is nil, the results are returned as a list of
 956 lists. If FLATP is t, the results are returned as elements of a
 957 list, only if there is only one result per row. The arguments
 958 ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
 959 ORDER-by have the same function as the equivalent SQL expression.
 960 The SELECT function is common across both the functional and
 961 object-oriented SQL interfaces. If selections refers to View
 962 Classes then the select operation becomes object-oriented. This
 963 means that SELECT returns a list of View Class instances, and
 964 SLOT-VALUE becomes a valid SQL operator for use within the where
 965 clause. In the View Class case, a second equivalent select call
 966 will return the same View Class instance objects. If REFRESH is
 967 true, then existing instances are updated if necessary, and in
 968 this case you might need to extend the hook INSTANCE-REFRESHED.
 969 The default value of REFRESH is nil. SQL expressions used in the
 970 SELECT function are specified using the square bracket syntax,
 971 once this syntax has been enabled using
 972 ENABLE-SQL-READER-SYNTAX."
 973
 974   (flet ((select-objects (target-args)
 975            (and target-args
 976                 (every #'(lambda (arg)
 977                            (and (symbolp arg)
 978                                 (find-class arg nil)))
 979                        target-args))))
 980     (multiple-value-bind (target-args qualifier-args)
 981         (query-get-selections select-all-args)
 982       (if (select-objects target-args)
 983           (apply #'find-all target-args qualifier-args)
 984         (let* ((expr (apply #'make-query select-all-args))
 985                (specified-types
 986                 (mapcar #'(lambda (attrib)
 987                             (if (typep attrib 'sql-ident-attribute)
 988                                 (let ((type (slot-value attrib 'type)))
 989                                   (if type
 990                                       type
 991                                     t))
 992                               t))
 993                         (slot-value expr 'selections))))
 994           (destructuring-bind (&key (flatp nil)
 995                                     (result-types :auto)
 996                                     (field-names t)
 997                                     (database *default-database*)
 998                                &allow-other-keys)
 999               qualifier-args
1000             (query expr :flatp flatp
1001                    :result-types
1002                    ;; specifying a type for an attribute overrides result-types
1003                    (if (some #'(lambda (x) (not (eq t x))) specified-types)
1004                        specified-types
1005                      result-types)
1006                    :field-names field-names
1007                    :database database)))))))
1008