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 ((class standard-db-object)
  48                                         &rest all-keys &key &allow-other-keys)
  49   (declare (ignore all-keys))
  50   (let ((*db-deserializing* t))
  51     (call-next-method)))
  52
  53 (defun sequence-from-class (view-class-name)
  54   (sql-escape
  55    (concatenate
  56     'string
  57     (symbol-name (view-table (find-class view-class-name)))
  58     "-SEQ")))
  59
  60 (defun create-sequence-from-class (view-class-name
  61                                    &key (database *default-database*))
  62   (create-sequence (sequence-from-class view-class-name) :database database))
  63
  64 (defun drop-sequence-from-class (view-class-name
  65                                  &key (if-does-not-exist :error)
  66                                  (database *default-database*))
  67   (drop-sequence (sequence-from-class view-class-name)
  68                  :if-does-not-exist if-does-not-exist
  69                  :database database))
  70
  71 ;;
  72 ;; Build the database tables required to store the given view class
  73 ;;
  74
  75 (defmethod database-pkey-constraint ((class standard-db-class) database)
  76   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
  77     (when keylist
  78       (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
  79               (database-output-sql (view-table class) database)
  80               (database-output-sql keylist database)))))
  81
  82
  83 (defun create-view-from-class (view-class-name
  84                                &key (database *default-database*))
  85   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
  86 the view. The argument DATABASE has a default value of
  87 *DEFAULT-DATABASE*."
  88   (let ((tclass (find-class view-class-name)))
  89     (if tclass
  90         (let ((*default-database* database))
  91           (%install-class tclass database))
  92         (error "Class ~s not found." view-class-name)))
  93   (values))
  94
  95 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
  96   (dolist (slotdef (ordered-class-slots self))
  97     (let ((res (database-generate-column-definition (class-name self)
  98                                                     slotdef database)))
  99       (when res
 100         (push res schemadef))))
 101   (unless schemadef
 102     (error "Class ~s has no :base slots" self))
 103   (create-table (sql-expression :table (view-table self)) schemadef
 104                 :database database
 105                 :constraints (database-pkey-constraint self database))
 106   (push self (database-view-classes database))
 107   t)
 108
 109 ;;
 110 ;; Drop the tables which store the given view class
 111 ;;
 112
 113 #.(locally-enable-sql-reader-syntax)
 114
 115 (defun drop-view-from-class (view-class-name &key (database *default-database*))
 116   "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
 117 which defines that view. The argument DATABASE has a default value of
 118 *DEFAULT-DATABASE*."
 119   (let ((tclass (find-class view-class-name)))
 120     (if tclass
 121         (let ((*default-database* database))
 122           (%uninstall-class tclass))
 123         (error "Class ~s not found." view-class-name)))
 124   (values))
 125
 126 #.(restore-sql-reader-syntax-state)
 127
 128 (defun %uninstall-class (self &key (database *default-database*))
 129   (drop-table (sql-expression :table (view-table self))
 130               :if-does-not-exist :ignore
 131               :database database)
 132   (setf (database-view-classes database)
 133         (remove self (database-view-classes database))))
 134
 135
 136 ;;
 137 ;; List all known view classes
 138 ;;
 139
 140 (defun list-classes (&key (test #'identity)
 141                           (root-class 'standard-db-object)
 142                           (database *default-database*))
 143   "Returns a list of View Classes connected to a given DATABASE which
 144 defaults to *DEFAULT-DATABASE*."
 145   (declare (ignore root-class))
 146   (remove-if #'(lambda (c) (not (funcall test c)))
 147              (database-view-classes database)))
 148
 149 ;;
 150 ;; Define a new view class
 151 ;;
 152
 153 (defmacro def-view-class (class supers slots &rest options)
 154   "Extends the syntax of defclass to allow special slots to be mapped
 155 onto the attributes of database views. The macro DEF-VIEW-CLASS
 156 creates a class called CLASS which maps onto a database view. Such a
 157 class is called a View Class. The macro DEF-VIEW-CLASS extends the
 158 syntax of DEFCLASS to allow special base slots to be mapped onto the
 159 attributes of database views (presently single tables). When a select
 160 query that names a View Class is submitted, then the corresponding
 161 database view is queried, and the slots in the resulting View Class
 162 instances are filled with attribute values from the database. If
 163 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
 164 superclass of the newly-defined View Class."
 165   `(progn
 166      (defclass ,class ,supers ,slots ,@options
 167                (:metaclass standard-db-class))
 168      (finalize-inheritance (find-class ',class))))
 169
 170 (defun keyslots-for-class (class)
 171   (slot-value class 'key-slots))
 172
 173 (defun key-qualifier-for-instance (obj &key (database *default-database*))
 174   (let ((tb (view-table (class-of obj))))
 175     (flet ((qfk (k)
 176              (sql-operation '==
 177                             (sql-expression :attribute
 178                                             (view-class-slot-column k)
 179                                             :table tb)
 180                             (db-value-from-slot
 181                              k
 182                              (slot-value obj (slot-definition-name k))
 183                              database))))
 184       (let* ((keys (keyslots-for-class (class-of obj)))
 185              (keyxprs (mapcar #'qfk (reverse keys))))
 186         (cond
 187           ((= (length keyxprs) 0) nil)
 188           ((= (length keyxprs) 1) (car keyxprs))
 189           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
 190
 191 ;;
 192 ;; Function used by 'generate-selection-list'
 193 ;;
 194
 195 (defun generate-attribute-reference (vclass slotdef)
 196   (cond
 197    ((eq (view-class-slot-db-kind slotdef) :base)
 198     (sql-expression :attribute (view-class-slot-column slotdef)
 199                     :table (view-table vclass)))
 200    ((eq (view-class-slot-db-kind slotdef) :key)
 201     (sql-expression :attribute (view-class-slot-column slotdef)
 202                     :table (view-table vclass)))
 203    (t nil)))
 204
 205 ;;
 206 ;; Function used by 'find-all'
 207 ;;
 208
 209 (defun generate-selection-list (vclass)
 210   (let ((sels nil))
 211     (dolist (slotdef (ordered-class-slots vclass))
 212       (let ((res (generate-attribute-reference vclass slotdef)))
 213         (when res
 214           (push (cons slotdef res) sels))))
 215     (if sels
 216         sels
 217         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 218
 219 ;;
 220 ;; Used by 'create-view-from-class'
 221 ;;
 222
 223
 224 (defmethod database-generate-column-definition (class slotdef database)
 225   (declare (ignore database class))
 226   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
 227     (let ((cdef
 228            (list (sql-expression :attribute (view-class-slot-column slotdef))
 229                  (slot-type slotdef))))
 230       (let ((const (view-class-slot-db-constraints slotdef)))
 231         (when const
 232           (setq cdef (append cdef (list const)))))
 233       cdef)))
 234
 235 ;;
 236 ;; Called by 'get-slot-values-from-view'
 237 ;;
 238
 239 (declaim (inline delistify))
 240 (defun delistify (list)
 241   (if (listp list)
 242       (car list)
 243       list))
 244
 245 (defun slot-type (slotdef)
 246   (specified-type slotdef))
 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   (slot-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 (slot-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 (slot-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 (slot-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 (defgeneric update-record-from-slot (object slot &key database)
 320   (:documentation
 321    "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
 322 data item in the column represented by SLOT. The DATABASE is only used
 323 if OBJECT is not yet associated with any database, in which case a
 324 record is created in DATABASE. Only SLOT is initialized in this case;
 325 other columns in the underlying database receive default values. The
 326 argument SLOT is the CLOS slot name; the corresponding column names
 327 are derived from the View Class definition."))
 328
 329 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 330                                         (database *default-database*))
 331   (let* ((vct (view-table (class-of obj)))
 332          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 333     (check-slot-type sd (slot-value obj slot))
 334     (let* ((att (view-class-slot-column sd))
 335            (val (db-value-from-slot sd (slot-value obj slot) database)))
 336       (cond ((and vct sd (view-database obj))
 337              (update-records (sql-expression :table vct)
 338                              :attributes (list (sql-expression
 339                                                 :attribute att))
 340                              :values (list val)
 341                              :where (key-qualifier-for-instance
 342                                      obj :database database)
 343                              :database (view-database obj)))
 344             ((and vct sd (not (view-database obj)))
 345              (install-instance obj :database database))
 346             (t
 347              (error "Unable to update record.")))))
 348   (values))
 349
 350 (defgeneric update-record-from-slots (object slots &key database)
 351   (:documentation
 352    "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
 353 columns represented by SLOTS. The DATABASE is only used if OBJECT is
 354 not yet associated with any database, in which case a record is
 355 created in DATABASE. Only slots are initialized in this case; other
 356 columns in the underlying database receive default values. The
 357 argument SLOTS contains the CLOS slot names; the corresponding column
 358 names are derived from the view class definition."))
 359
 360 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 361                                      (database *default-database*))
 362   (let* ((vct (view-table (class-of obj)))
 363          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 364          (avps (mapcar #'(lambda (s)
 365                            (let ((val (slot-value
 366                                        obj (slot-definition-name s))))
 367                              (check-slot-type s val)
 368                              (list (sql-expression
 369                                     :attribute (view-class-slot-column s))
 370                                    (db-value-from-slot s val database))))
 371                        sds)))
 372     (cond ((and avps (view-database obj))
 373            (update-records (sql-expression :table vct)
 374                            :av-pairs avps
 375                            :where (key-qualifier-for-instance
 376                                    obj :database database)
 377                            :database (view-database obj)))
 378           ((and avps (not (view-database obj)))
 379            (insert-records :into (sql-expression :table vct)
 380                            :av-pairs avps
 381                            :database database)
 382            (setf (slot-value obj 'view-database) database))
 383           (t
 384            (error "Unable to update records"))))
 385   (values))
 386
 387 (defgeneric update-records-from-instance (object &key database)
 388   (:documentation
 389    "Using an instance of a view class, update the database table that
 390 stores its instance data. If the instance is already associated with a
 391 database, that database is used, and database is ignored. If instance
 392 is not yet associated with a database, a record is created for
 393 instance in the appropriate table of database and the instance becomes
 394 associated with that database."))
 395
 396 (defmethod update-records-from-instance ((obj standard-db-object)
 397                                          &key (database *default-database*))
 398   (labels ((slot-storedp (slot)
 399              (and (member (view-class-slot-db-kind slot) '(:base :key))
 400                   (slot-boundp obj (slot-definition-name slot))))
 401            (slot-value-list (slot)
 402              (let ((value (slot-value obj (slot-definition-name slot))))
 403                (check-slot-type slot value)
 404                (list (sql-expression :attribute (view-class-slot-column slot))
 405                      (db-value-from-slot slot value database)))))
 406     (let* ((view-class (class-of obj))
 407            (view-class-table (view-table view-class))
 408            (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
 409            (record-values (mapcar #'slot-value-list slots)))
 410       (unless record-values
 411         (error "No settable slots."))
 412       (if (view-database obj)
 413           (update-records (sql-expression :table view-class-table)
 414                           :av-pairs record-values
 415                           :where (key-qualifier-for-instance
 416                                   obj :database database)
 417                           :database (view-database obj))
 418           (progn
 419             (insert-records :into (sql-expression :table view-class-table)
 420                             :av-pairs record-values
 421                             :database database)
 422             (setf (slot-value obj 'view-database) database)))
 423       (values))))
 424
 425 (defmethod install-instance ((obj standard-db-object)
 426                              &key (database *default-database*))
 427   (labels ((slot-storedp (slot)
 428              (and (member (view-class-slot-db-kind slot) '(:base :key))
 429                   (slot-boundp obj (slot-definition-name slot))))
 430            (slot-value-list (slot)
 431              (let ((value (slot-value obj (slot-definition-name slot))))
 432                (check-slot-type slot value)
 433                (list (sql-expression :attribute (view-class-slot-column slot))
 434                      (db-value-from-slot slot value database)))))
 435     (let* ((view-class (class-of obj))
 436            (view-class-table (view-table view-class))
 437            (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
 438            (record-values (mapcar #'slot-value-list slots)))
 439       (unless record-values
 440         (error "No settable slots."))
 441       (unless
 442           (let ((obj-db (slot-value obj 'view-database)))
 443             (when obj-db
 444               (equal obj-db database))))
 445         (insert-records :into (sql-expression :table view-class-table)
 446                         :av-pairs record-values
 447                         :database database)
 448         (setf (slot-value obj 'view-database) database))
 449     (values)))
 450
 451 (defmethod handle-cascade-delete-rule ((instance standard-db-object)
 452                                        (slot
 453                                         view-class-effective-slot-definition))
 454   (let ((val (slot-value instance (slot-definition-name slot))))
 455     (typecase val
 456       (list
 457        (if (gethash :target-slot (view-class-slot-db-info slot))
 458            ;; For relations with target-slot, we delete just the join instance
 459            (mapcar #'(lambda (obj)
 460                        (delete-instance-records obj))
 461                    (fault-join-slot-raw (class-of instance) instance slot))
 462            (dolist (obj val)
 463              (delete-instance-records obj))))
 464       (standard-db-object
 465        (delete-instance-records val)))))
 466
 467 (defmethod nullify-join-foreign-keys ((instance standard-db-object) slot)
 468     (let* ((dbi (view-class-slot-db-info slot))
 469            (fkeys (gethash :foreign-keys dbi)))
 470       (mapcar #'(lambda (fk)
 471                   (if (view-class-slot-nulls-ok slot)
 472                       (setf (slot-value instance fk) nil)
 473                       (warn "Nullify delete rule cannot set slot not allowing nulls to nil")))
 474               (if (listp fkeys) fkeys (list fkeys)))))
 475
 476 (defmethod handle-nullify-delete-rule ((instance standard-db-object)
 477                                        (slot
 478                                         view-class-effective-slot-definition))
 479     (let ((dbi (view-class-slot-db-info slot)))
 480       (if (gethash :set dbi)
 481           (if (gethash :target-slot (view-class-slot-db-info slot))
 482               ;;For relations with target-slot, we delete just the join instance
 483               (mapcar #'(lambda (obj)
 484                           (nullify-join-foreign-keys obj slot))
 485                       (fault-join-slot-raw (class-of instance) instance slot))
 486               (dolist (obj (slot-value instance (slot-definition-name slot)))
 487                 (nullify-join-foreign-keys obj slot)))
 488           (nullify-join-foreign-keys
 489            (slot-value instance (slot-definition-name slot)) slot))))
 490
 491 (defmethod propogate-deletes ((instance standard-db-object))
 492   (let* ((view-class (class-of instance))
 493          (joins (remove-if #'(lambda (sd)
 494                                (not (equal (view-class-slot-db-kind sd) :join)))
 495                            (ordered-class-slots view-class))))
 496     (dolist (slot joins)
 497       (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
 498         (cond
 499           ((eql delete-rule :cascade)
 500            (handle-cascade-delete-rule instance slot))
 501           ((eql delete-rule :deny)
 502            (when (slot-value instance (slot-definition-name slot))
 503              (error
 504               "Unable to delete slot ~A, because it has a deny delete rule."
 505               slot)))
 506           ((eql delete-rule :nullify)
 507            (handle-nullify-delete-rule instance slot))
 508           (t t))))))
 509
 510 (defgeneric delete-instance-records (instance)
 511   (:documentation
 512    "Deletes the records represented by INSTANCE from the database
 513 associated with it. If instance has no associated database, an error
 514 is signalled."))
 515
 516 (defmethod delete-instance-records ((instance standard-db-object))
 517   (let ((vt (sql-expression :table (view-table (class-of instance))))
 518         (vd (or (view-database instance) *default-database*)))
 519     (when vd
 520       (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 521         (with-transaction (:database vd)
 522           (propogate-deletes instance)
 523           (delete-records :from vt :where qualifier :database vd)
 524           (setf (slot-value instance 'view-database) nil)))))
 525   (values))
 526
 527 (defgeneric update-instance-from-records (instance &key database)
 528   (:documentation
 529    "Updates the values in the slots of the View Class instance
 530 INSTANCE using the data in the database DATABASE which defaults to the
 531 database that INSTANCE is associated with, or the value of
 532 *DEFAULT-DATABASE*."))
 533
 534 (defmethod update-instance-from-records ((instance standard-db-object)
 535                                          &key (database *default-database*))
 536   (let* ((view-class (find-class (class-name (class-of instance))))
 537          (view-table (sql-expression :table (view-table view-class)))
 538          (vd (or (view-database instance) database))
 539          (view-qual (key-qualifier-for-instance instance :database vd))
 540          (sels (generate-selection-list view-class))
 541          (res (apply #'select (append (mapcar #'cdr sels)
 542                                       (list :from  view-table
 543                                             :where view-qual)))))
 544     (when res
 545       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 546
 547 (defgeneric update-slot-from-record (instance slot &key database)
 548   (:documentation
 549    "Updates the value in the slot SLOT of the View Class instance
 550 INSTANCE using the data in the database DATABASE which defaults to the
 551 database that INSTANCE is associated with, or the value of
 552 *DEFAULT-DATABASE*."))
 553
 554 (defmethod update-slot-from-record ((instance standard-db-object)
 555                                     slot &key (database *default-database*))
 556   (let* ((view-class (find-class (class-name (class-of instance))))
 557          (view-table (sql-expression :table (view-table view-class)))
 558          (vd (or (view-database instance) database))
 559          (view-qual (key-qualifier-for-instance instance :database vd))
 560          (slot-def (slotdef-for-slot-with-class slot view-class))
 561          (att-ref (generate-attribute-reference view-class slot-def))
 562          (res (select att-ref :from  view-table :where view-qual)))
 563     (get-slot-values-from-view instance (list slot-def) (car res))))
 564
 565
 566 (defgeneric database-null-value (type)
 567   (:documentation "Return an expression of type TYPE which SQL NULL values
 568 will be converted into."))
 569
 570 (defmethod database-null-value ((type t))
 571     (cond
 572      ((subtypep type 'string) "")
 573      ((subtypep type 'integer) 0)
 574      ((subtypep type 'float) (float 0.0))
 575      ((subtypep type 'list) nil)
 576      ((subtypep type 'boolean) nil)
 577      ((subtypep type 'symbol) nil)
 578      ((subtypep type 'keyword) nil)
 579      ((subtypep type 'wall-time) nil)
 580      (t
 581       (error "Unable to handle null for type ~A" type))))
 582
 583 (defgeneric update-slot-with-null (instance slotname slotdef)
 584   (:documentation "Called to update a slot when its column has a NULL
 585 value.  If nulls are allowed for the column, the slot's value will be
 586 nil, otherwise its value will be set to the result of calling
 587 DATABASE-NULL-VALUE on the type of the slot."))
 588
 589 (defmethod update-slot-with-null ((object standard-db-object)
 590                                   slotname
 591                                   slotdef)
 592   (let ((st (slot-type slotdef))
 593         (allowed (slot-value slotdef 'nulls-ok)))
 594     (if allowed
 595         (setf (slot-value object slotname) nil)
 596         (setf (slot-value object slotname)
 597               (database-null-value st)))))
 598
 599 (defvar +no-slot-value+ '+no-slot-value+)
 600
 601 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 602   (let* ((class (find-class classname))
 603          (sld (slotdef-for-slot-with-class slot class)))
 604     (if sld
 605         (if (eq value +no-slot-value+)
 606             (sql-expression :attribute (view-class-slot-column sld)
 607                             :table (view-table class))
 608             (db-value-from-slot
 609              sld
 610              value
 611              database))
 612         (error "Unknown slot ~A for class ~A" slot classname))))
 613
 614 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 615         (declare (ignore database))
 616         (let* ((class (find-class classname)))
 617           (unless (view-table class)
 618             (error "No view-table for class ~A"  classname))
 619           (sql-expression :table (view-table class))))
 620
 621 (defmethod database-get-type-specifier (type args database)
 622   (declare (ignore type args))
 623   (if (member (database-type database) '(:postgresql :postgresql-socket))
 624           "VARCHAR"
 625           "VARCHAR(255)"))
 626
 627 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 628   (declare (ignore database))
 629   ;;"INT8")
 630   (if args
 631       (format nil "INT(~A)" (car args))
 632       "INT"))
 633
 634 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 635                                         database)
 636   (if args
 637       (format nil "VARCHAR(~A)" (car args))
 638       (if (member (database-type database) '(:postgresql :postgresql-socket))
 639           "VARCHAR"
 640           "VARCHAR(255)")))
 641
 642 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 643                                         database)
 644   (if args
 645       (format nil "VARCHAR(~A)" (car args))
 646       (if (member (database-type database) '(:postgresql :postgresql-socket))
 647           "VARCHAR"
 648           "VARCHAR(255)")))
 649
 650 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 651   (if args
 652       (format nil "VARCHAR(~A)" (car args))
 653       (if (member (database-type database) '(:postgresql :postgresql-socket))
 654           "VARCHAR"
 655           "VARCHAR(255)")))
 656
 657 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 658   (declare (ignore args))
 659   (case (database-type database)
 660     (:postgresql
 661      "TIMESTAMP WITHOUT TIME ZONE")
 662     (:postgresql-socket
 663      "TIMESTAMP WITHOUT TIME ZONE")
 664     (:mysql
 665      "DATETIME")
 666     (t "TIMESTAMP")))
 667
 668 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 669   (declare (ignore database args))
 670   "INT8")
 671
 672 (deftype raw-string (&optional len)
 673   "A string which is not trimmed when retrieved from the database"
 674   `(string ,len))
 675
 676 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 677   (declare (ignore database))
 678   (if args
 679       (format nil "VARCHAR(~A)" (car args))
 680       "VARCHAR"))
 681
 682 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 683   (declare (ignore database))
 684   (if args
 685       (format nil "FLOAT(~A)" (car args))
 686       "FLOAT"))
 687
 688 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 689   (declare (ignore database))
 690   (if args
 691       (format nil "FLOAT(~A)" (car args))
 692       "FLOAT"))
 693
 694 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
 695   (declare (ignore args database))
 696   "BOOL")
 697
 698 (defmethod database-output-sql-as-type (type val database)
 699   (declare (ignore type database))
 700   val)
 701
 702 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 703   (declare (ignore database))
 704   (progv '(*print-circle* *print-array*) '(t t)
 705     (prin1-to-string val)))
 706
 707 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 708   (declare (ignore database))
 709   (if (keywordp val)
 710       (symbol-name val)
 711       (if val
 712           (concatenate 'string
 713                        (package-name (symbol-package val))
 714                        "::"
 715                        (symbol-name val))
 716           "")))
 717
 718 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 719   (declare (ignore database))
 720   (if val
 721       (symbol-name val)
 722       ""))
 723
 724 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
 725   (declare (ignore database))
 726   (progv '(*print-circle* *print-array*) '(t t)
 727     (prin1-to-string val)))
 728
 729 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
 730   (declare (ignore database))
 731   (progv '(*print-circle* *print-array*) '(t t)
 732     (prin1-to-string val)))
 733
 734 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
 735   (declare (ignore database))
 736   (if val "t" "f"))
 737
 738 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 739   (declare (ignore database))
 740   val)
 741
 742 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 743                                         val database)
 744   (declare (ignore database))
 745   val)
 746
 747 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 748                                         val database)
 749   (declare (ignore database))
 750   val)
 751
 752 (defmethod read-sql-value (val type database)
 753   (declare (ignore type database))
 754   (read-from-string val))
 755
 756 (defmethod read-sql-value (val (type (eql 'string)) database)
 757   (declare (ignore database))
 758   val)
 759
 760 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 761   (declare (ignore database))
 762   val)
 763
 764 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 765   (declare (ignore database))
 766   val)
 767
 768 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 769   (declare (ignore database))
 770   val)
 771
 772 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 773   (declare (ignore database))
 774   (when (< 0 (length val))
 775     (intern (string-upcase val) "KEYWORD")))
 776
 777 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 778   (declare (ignore database))
 779   (when (< 0 (length val))
 780     (unless (string= val "NIL")
 781       (intern (string-upcase val)
 782               (symbol-package *update-context*)))))
 783
 784 (defmethod read-sql-value (val (type (eql 'integer)) database)
 785   (declare (ignore database))
 786   (etypecase val
 787     (string
 788      (read-from-string val))
 789     (number val)))
 790
 791 (defmethod read-sql-value (val (type (eql 'float)) database)
 792   (declare (ignore database))
 793   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 794   (float (read-from-string val)))
 795
 796 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 797   (declare (ignore database))
 798   (equal "t" val))
 799
 800 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 801   (declare (ignore database))
 802   (unless (eq 'NULL val)
 803     (parse-timestring val)))
 804
 805
 806 ;; ------------------------------------------------------------
 807 ;; Logic for 'faulting in' :join slots
 808
 809 (defun fault-join-slot-raw (class object slot-def)
 810   (let* ((dbi (view-class-slot-db-info slot-def))
 811          (jc (gethash :join-class dbi)))
 812     (let ((jq (join-qualifier class object slot-def)))
 813       (when jq
 814         (select jc :where jq)))))
 815
 816 (defun fault-join-slot (class object slot-def)
 817   (let* ((dbi (view-class-slot-db-info slot-def))
 818          (ts (gethash :target-slot dbi))
 819          (res (fault-join-slot-raw class object slot-def)))
 820     (when res
 821       (cond
 822         ((and ts (gethash :set dbi))
 823          (mapcar (lambda (obj)
 824                    (cons obj (slot-value obj ts))) res))
 825         ((and ts (not (gethash :set dbi)))
 826          (mapcar (lambda (obj) (slot-value obj ts)) res))
 827         ((and (not ts) (not (gethash :set dbi)))
 828          (car res))
 829         ((and (not ts) (gethash :set dbi))
 830          res)))))
 831
 832 (defun join-qualifier (class object slot-def)
 833     (declare (ignore class))
 834     (let* ((dbi (view-class-slot-db-info slot-def))
 835            (jc (find-class (gethash :join-class dbi)))
 836            ;;(ts (gethash :target-slot dbi))
 837            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 838            (foreign-keys (gethash :foreign-key dbi))
 839            (home-keys (gethash :home-key dbi)))
 840       (when (every #'(lambda (slt)
 841                        (and (slot-boundp object slt)
 842                             (not (null (slot-value object slt)))))
 843                    (if (listp home-keys) home-keys (list home-keys)))
 844         (let ((jc
 845                (mapcar #'(lambda (hk fk)
 846                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 847                              (sql-operation '==
 848                                             (typecase fk
 849                                               (symbol
 850                                                (sql-expression
 851                                                 :attribute
 852                                                 (view-class-slot-column fksd)
 853                                                 :table (view-table jc)))
 854                                               (t fk))
 855                                             (typecase hk
 856                                               (symbol
 857                                                (slot-value object hk))
 858                                               (t
 859                                                hk)))))
 860                        (if (listp home-keys)
 861                            home-keys
 862                            (list home-keys))
 863                        (if (listp foreign-keys)
 864                            foreign-keys
 865                            (list foreign-keys)))))
 866           (when jc
 867             (if (> (length jc) 1)
 868                 (apply #'sql-and jc)
 869                 jc))))))
 870
 871 (defmethod postinitialize ((self t))
 872   )
 873
 874 (defun find-all (view-classes &rest args &key all set-operation distinct from
 875                  where group-by having order-by order-by-descending offset limit
 876                  (database *default-database*))
 877   "tweeze me apart someone pleeze"
 878   (declare (ignore all set-operation from group-by having offset limit)
 879            (optimize (debug 3) (speed 1)))
 880   (let* ((*db-deserializing* t)
 881          (*default-database* (or database (error 'clsql-nodb-error))))
 882     (flet ((table-sql-expr (table)
 883              (sql-expression :table (view-table table)))
 884            (ref-equal (ref1 ref2)
 885              (equal (sql ref1)
 886                     (sql ref2)))
 887            (tables-equal (table-a table-b)
 888              (string= (string (slot-value table-a 'name))
 889                       (string (slot-value table-b 'name)))))
 890
 891       (let* ((sclasses (mapcar #'find-class view-classes))
 892              (sels (mapcar #'generate-selection-list sclasses))
 893              (fullsels (apply #'append sels))
 894              (sel-tables (collect-table-refs where))
 895              (tables
 896               (remove-duplicates
 897                (append (mapcar #'table-sql-expr sclasses) sel-tables)
 898                :test #'tables-equal))
 899              (res nil))
 900         (dolist (ob (listify order-by))
 901           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 902                                      :test #'ref-equal)))
 903             (setq fullsels
 904                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 905                                            (listify ob))))))
 906         (dolist (ob (listify order-by-descending))
 907           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 908                                      :test #'ref-equal)))
 909             (setq fullsels
 910                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 911                                            (listify ob))))))
 912         (dolist (ob (listify distinct))
 913           (when (and (typep ob 'sql-ident)
 914                      (not (member ob (mapcar #'cdr fullsels)
 915                                   :test #'ref-equal)))
 916             (setq fullsels
 917                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 918                                            (listify ob))))))
 919         ;;(format t "~%fullsels is : ~A" fullsels)
 920         (setq res (apply #'select (append (mapcar #'cdr fullsels)
 921                                           (cons :from (list tables)) args)))
 922         (flet ((build-instance (vals)
 923                  (flet ((%build-instance (vclass selects)
 924                           (let ((class-name (class-name vclass))
 925                                 (db-vals (butlast vals
 926                                                   (- (list-length vals)
 927                                                      (list-length selects))))
 928                                 cache-key)
 929                             (setf vals (nthcdr (list-length selects) vals))
 930                             (loop for select in selects
 931                                   for value in db-vals
 932                                   do
 933                                   (when (eql (slot-value (car select) 'db-kind)
 934                                              :key)
 935                                     (push
 936                                      (key-value-from-db (car select) value
 937                                                         *default-database*)
 938                                      cache-key)))
 939                             (push class-name cache-key)
 940                             (%make-fresh-object class-name
 941                                                 (mapcar #'car selects)
 942                                                 db-vals))))
 943                    (let ((instances (mapcar #'%build-instance sclasses sels)))
 944                      (if (= (length sclasses) 1)
 945                          (car instances)
 946                          instances)))))
 947           (remove-if #'null (mapcar #'build-instance res)))))))
 948
 949 (defun %make-fresh-object (class-name slots values)
 950   (let* ((*db-initializing* t)
 951          (obj (make-instance class-name
 952                              :view-database *default-database*)))
 953     (setf obj (get-slot-values-from-view obj slots values))
 954     (postinitialize obj)
 955     obj))
 956
 957 (defun select (&rest select-all-args)
 958   "Selects data from database given the constraints specified. Returns
 959 a list of lists of record values as specified by select-all-args. By
 960 default, the records are each represented as lists of attribute
 961 values. The selections argument may be either db-identifiers, literal
 962 strings or view classes.  If the argument consists solely of view
 963 classes, the return value will be instances of objects rather than raw
 964 tuples."
 965   (flet ((select-objects (target-args)
 966            (and target-args
 967                 (every #'(lambda (arg)
 968                            (and (symbolp arg)
 969                                 (find-class arg nil)))
 970                        target-args))))
 971     (multiple-value-bind (target-args qualifier-args)
 972         (query-get-selections select-all-args)
 973       ;; (cmsg "Qual args = ~s" qualifier-args)
 974       (if (select-objects target-args)
 975           (apply #'find-all target-args qualifier-args)
 976           (let ((expr (apply #'make-query select-all-args)))
 977             (destructuring-bind (&key (flatp nil)
 978                                       (database *default-database*)
 979                                       &allow-other-keys)
 980                 qualifier-args
 981               (let ((res (query expr :database database)))
 982                 (if (and flatp
 983                          (= (length (slot-value expr 'selections)) 1))
 984                     (mapcar #'car res)
 985                   res))))))))