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 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
 249   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 250   (let ((slot-reader (view-class-slot-db-reader slotdef))
 251         (slot-name   (slot-definition-name slotdef))
 252         (slot-type   (slot-type slotdef)))
 253     (cond ((and value (null slot-reader))
 254            (setf (slot-value instance slot-name)
 255                  (read-sql-value value (delistify slot-type)
 256                                  (view-database instance))))
 257           ((null value)
 258            (update-slot-with-null instance slot-name slotdef))
 259           ((typep slot-reader 'string)
 260            (setf (slot-value instance slot-name)
 261                  (format nil slot-reader value)))
 262           ((typep slot-reader 'function)
 263            (setf (slot-value instance slot-name)
 264                  (apply slot-reader (list value))))
 265           (t
 266            (error "Slot reader is of an unusual type.")))))
 267
 268 (defmethod key-value-from-db (slotdef value database)
 269   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 270   (let ((slot-reader (view-class-slot-db-reader slotdef))
 271         (slot-type (slot-type slotdef)))
 272     (cond ((and value (null slot-reader))
 273            (read-sql-value value (delistify slot-type) database))
 274           ((null value)
 275            nil)
 276           ((typep slot-reader 'string)
 277            (format nil slot-reader value))
 278           ((typep slot-reader 'function)
 279            (apply slot-reader (list value)))
 280           (t
 281            (error "Slot reader is of an unusual type.")))))
 282
 283 (defun db-value-from-slot (slotdef val database)
 284   (let ((dbwriter (view-class-slot-db-writer slotdef))
 285         (dbtype (slot-type slotdef)))
 286     (typecase dbwriter
 287       (string (format nil dbwriter val))
 288       (function (apply dbwriter (list val)))
 289       (t
 290        (typecase dbtype
 291          (cons
 292           (database-output-sql-as-type (car dbtype) val database))
 293          (t
 294           (database-output-sql-as-type dbtype val database)))))))
 295
 296 (defun check-slot-type (slotdef val)
 297   (let* ((slot-type (slot-type slotdef))
 298          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 299     (when (and slot-type val)
 300       (unless (typep val basetype)
 301         (error 'clsql-type-error
 302                :slotname (slot-definition-name slotdef)
 303                :typespec slot-type
 304                :value val)))))
 305
 306 ;;
 307 ;; Called by find-all
 308 ;;
 309
 310 (defmethod get-slot-values-from-view (obj slotdeflist values)
 311     (flet ((update-slot (slot-def values)
 312              (update-slot-from-db obj slot-def values)))
 313       (mapc #'update-slot slotdeflist values)
 314       obj))
 315
 316
 317 (defun synchronize-keys (src srckey dest destkey)
 318   (let ((skeys (if (listp srckey) srckey (list srckey)))
 319         (dkeys (if (listp destkey) destkey (list destkey))))
 320     (mapcar #'(lambda (sk dk)
 321                 (setf (slot-value dest dk)
 322                       (typecase sk
 323                         (symbol
 324                          (slot-value src sk))
 325                         (t sk))))
 326             skeys dkeys)))
 327
 328 (defun desynchronize-keys (dest destkey)
 329   (let ((dkeys (if (listp destkey) destkey (list destkey))))
 330     (mapcar #'(lambda (dk)
 331                 (setf (slot-value dest dk) nil))
 332             dkeys)))
 333
 334 (defmethod add-to-relation ((target standard-db-object)
 335                             slot-name
 336                             (value standard-db-object))
 337   (let* ((objclass (class-of target))
 338          (sdef (or (slotdef-for-slot-with-class slot-name objclass)
 339                    (error "~s is not an known slot on ~s" slot-name target)))
 340          (dbinfo (view-class-slot-db-info sdef))
 341          (join-class (gethash :join-class dbinfo))
 342          (homekey (gethash :home-key dbinfo))
 343          (foreignkey (gethash :foreign-key dbinfo))
 344          (to-many (gethash :set dbinfo)))
 345     (unless (equal (type-of value) join-class)
 346       (error 'clsql-type-error :slotname slot-name :typespec join-class
 347              :value value))
 348     (when (gethash :target-slot dbinfo)
 349       (error "add-to-relation does not work with many-to-many relations yet."))
 350     (if to-many
 351         (progn
 352           (synchronize-keys target homekey value foreignkey)
 353           (if (slot-boundp target slot-name)
 354               (unless (member value (slot-value target slot-name))
 355                 (setf (slot-value target slot-name)
 356                       (append (slot-value target slot-name) (list value))))
 357               (setf (slot-value target slot-name) (list value))))
 358         (progn
 359           (synchronize-keys value foreignkey target homekey)
 360           (setf (slot-value target slot-name) value)))))
 361
 362 (defmethod remove-from-relation ((target standard-db-object)
 363                             slot-name (value standard-db-object))
 364   (let* ((objclass (class-of target))
 365          (sdef (slotdef-for-slot-with-class slot-name objclass))
 366          (dbinfo (view-class-slot-db-info sdef))
 367          (homekey (gethash :home-key dbinfo))
 368          (foreignkey (gethash :foreign-key dbinfo))
 369          (to-many (gethash :set dbinfo)))
 370     (when (gethash :target-slot dbinfo)
 371       (error "remove-relation does not work with many-to-many relations yet."))
 372     (if to-many
 373         (progn
 374           (desynchronize-keys value foreignkey)
 375           (if (slot-boundp target slot-name)
 376               (setf (slot-value target slot-name)
 377                     (remove value
 378                             (slot-value target slot-name)
 379                             :test #'equal))))
 380         (progn
 381           (desynchronize-keys target homekey)
 382           (setf (slot-value target slot-name)
 383                 nil)))))
 384
 385 (defgeneric update-record-from-slot (object slot &key database)
 386   (:documentation
 387    "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
 388 data item in the column represented by SLOT. The DATABASE is only used
 389 if OBJECT is not yet associated with any database, in which case a
 390 record is created in DATABASE. Only SLOT is initialized in this case;
 391 other columns in the underlying database receive default values. The
 392 argument SLOT is the CLOS slot name; the corresponding column names
 393 are derived from the View Class definition."))
 394
 395 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 396                                         (database *default-database*))
 397   (let* ((vct (view-table (class-of obj)))
 398          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 399     (check-slot-type sd (slot-value obj slot))
 400     (let* ((att (view-class-slot-column sd))
 401            (val (db-value-from-slot sd (slot-value obj slot) database)))
 402       (cond ((and vct sd (view-database obj))
 403              (update-records (sql-expression :table vct)
 404                              :attributes (list (sql-expression
 405                                                 :attribute att))
 406                              :values (list val)
 407                              :where (key-qualifier-for-instance
 408                                      obj :database database)
 409                              :database (view-database obj)))
 410             ((and vct sd (not (view-database obj)))
 411              (install-instance obj :database database))
 412             (t
 413              (error "Unable to update record.")))))
 414   (values))
 415
 416 (defgeneric update-record-from-slots (object slots &key database)
 417   (:documentation
 418    "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
 419 columns represented by SLOTS. The DATABASE is only used if OBJECT is
 420 not yet associated with any database, in which case a record is
 421 created in DATABASE. Only slots are initialized in this case; other
 422 columns in the underlying database receive default values. The
 423 argument SLOTS contains the CLOS slot names; the corresponding column
 424 names are derived from the view class definition."))
 425
 426 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 427                                      (database *default-database*))
 428   (let* ((vct (view-table (class-of obj)))
 429          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 430          (avps (mapcar #'(lambda (s)
 431                            (let ((val (slot-value
 432                                        obj (slot-definition-name s))))
 433                              (check-slot-type s val)
 434                              (list (sql-expression
 435                                     :attribute (view-class-slot-column s))
 436                                    (db-value-from-slot s val database))))
 437                        sds)))
 438     (cond ((and avps (view-database obj))
 439            (update-records (sql-expression :table vct)
 440                            :av-pairs avps
 441                            :where (key-qualifier-for-instance
 442                                    obj :database database)
 443                            :database (view-database obj)))
 444           ((and avps (not (view-database obj)))
 445            (insert-records :into (sql-expression :table vct)
 446                            :av-pairs avps
 447                            :database database)
 448            (setf (slot-value obj 'view-database) database))
 449           (t
 450            (error "Unable to update records"))))
 451   (values))
 452
 453 (defgeneric update-records-from-instance (object &key database)
 454   (:documentation
 455    "Using an instance of a view class, update the database table that
 456 stores its instance data. If the instance is already associated with a
 457 database, that database is used, and database is ignored. If instance
 458 is not yet associated with a database, a record is created for
 459 instance in the appropriate table of database and the instance becomes
 460 associated with that database."))
 461
 462 (defmethod update-records-from-instance ((obj standard-db-object)
 463                                          &key (database *default-database*))
 464   (labels ((slot-storedp (slot)
 465              (and (member (view-class-slot-db-kind slot) '(:base :key))
 466                   (slot-boundp obj (slot-definition-name slot))))
 467            (slot-value-list (slot)
 468              (let ((value (slot-value obj (slot-definition-name slot))))
 469                (check-slot-type slot value)
 470                (list (sql-expression :attribute (view-class-slot-column slot))
 471                      (db-value-from-slot slot value database)))))
 472     (let* ((view-class (class-of obj))
 473            (view-class-table (view-table view-class))
 474            (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
 475            (record-values (mapcar #'slot-value-list slots)))
 476       (unless record-values
 477         (error "No settable slots."))
 478       (if (view-database obj)
 479           (update-records (sql-expression :table view-class-table)
 480                           :av-pairs record-values
 481                           :where (key-qualifier-for-instance
 482                                   obj :database database)
 483                           :database (view-database obj))
 484           (progn
 485             (insert-records :into (sql-expression :table view-class-table)
 486                             :av-pairs record-values
 487                             :database database)
 488             (setf (slot-value obj 'view-database) database)))
 489       (values))))
 490
 491 (defmethod install-instance ((obj standard-db-object)
 492                              &key (database *default-database*))
 493   (labels ((slot-storedp (slot)
 494              (and (member (view-class-slot-db-kind slot) '(:base :key))
 495                   (slot-boundp obj (slot-definition-name slot))))
 496            (slot-value-list (slot)
 497              (let ((value (slot-value obj (slot-definition-name slot))))
 498                (check-slot-type slot value)
 499                (list (sql-expression :attribute (view-class-slot-column slot))
 500                      (db-value-from-slot slot value database)))))
 501     (let* ((view-class (class-of obj))
 502            (view-class-table (view-table view-class))
 503            (slots (remove-if-not #'slot-storedp (ordered-class-slots view-class)))
 504            (record-values (mapcar #'slot-value-list slots)))
 505       (unless record-values
 506         (error "No settable slots."))
 507       (unless
 508           (let ((obj-db (slot-value obj 'view-database)))
 509             (when obj-db
 510               (equal obj-db database))))
 511         (insert-records :into (sql-expression :table view-class-table)
 512                         :av-pairs record-values
 513                         :database database)
 514         (setf (slot-value obj 'view-database) database))
 515     (values)))
 516
 517 (defmethod handle-cascade-delete-rule ((instance standard-db-object)
 518                                        (slot
 519                                         view-class-effective-slot-definition))
 520   (let ((val (slot-value instance (slot-definition-name slot))))
 521     (typecase val
 522       (list
 523        (if (gethash :target-slot (view-class-slot-db-info slot))
 524            ;; For relations with target-slot, we delete just the join instance
 525            (mapcar #'(lambda (obj)
 526                        (delete-instance-records obj))
 527                    (fault-join-slot-raw (class-of instance) instance slot))
 528            (dolist (obj val)
 529              (delete-instance-records obj))))
 530       (standard-db-object
 531        (delete-instance-records val)))))
 532
 533 (defmethod nullify-join-foreign-keys ((instance standard-db-object) slot)
 534     (let* ((dbi (view-class-slot-db-info slot))
 535            (fkeys (gethash :foreign-keys dbi)))
 536       (mapcar #'(lambda (fk)
 537                   (if (view-class-slot-nulls-ok slot)
 538                       (setf (slot-value instance fk) nil)
 539                       (warn "Nullify delete rule cannot set slot not allowing nulls to nil")))
 540               (if (listp fkeys) fkeys (list fkeys)))))
 541
 542 (defmethod handle-nullify-delete-rule ((instance standard-db-object)
 543                                        (slot
 544                                         view-class-effective-slot-definition))
 545     (let ((dbi (view-class-slot-db-info slot)))
 546       (if (gethash :set dbi)
 547           (if (gethash :target-slot (view-class-slot-db-info slot))
 548               ;;For relations with target-slot, we delete just the join instance
 549               (mapcar #'(lambda (obj)
 550                           (nullify-join-foreign-keys obj slot))
 551                       (fault-join-slot-raw (class-of instance) instance slot))
 552               (dolist (obj (slot-value instance (slot-definition-name slot)))
 553                 (nullify-join-foreign-keys obj slot)))
 554           (nullify-join-foreign-keys
 555            (slot-value instance (slot-definition-name slot)) slot))))
 556
 557 (defmethod propogate-deletes ((instance standard-db-object))
 558   (let* ((view-class (class-of instance))
 559          (joins (remove-if #'(lambda (sd)
 560                                (not (equal (view-class-slot-db-kind sd) :join)))
 561                            (ordered-class-slots view-class))))
 562     (dolist (slot joins)
 563       (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot))))
 564         (cond
 565           ((eql delete-rule :cascade)
 566            (handle-cascade-delete-rule instance slot))
 567           ((eql delete-rule :deny)
 568            (when (slot-value instance (slot-definition-name slot))
 569              (error
 570               "Unable to delete slot ~A, because it has a deny delete rule."
 571               slot)))
 572           ((eql delete-rule :nullify)
 573            (handle-nullify-delete-rule instance slot))
 574           (t t))))))
 575
 576 (defgeneric delete-instance-records (instance)
 577   (:documentation
 578    "Deletes the records represented by INSTANCE from the database
 579 associated with it. If instance has no associated database, an error
 580 is signalled."))
 581
 582 (defmethod delete-instance-records ((instance standard-db-object))
 583   (let ((vt (sql-expression :table (view-table (class-of instance))))
 584         (vd (or (view-database instance) *default-database*)))
 585     (when vd
 586       (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 587         (with-transaction (:database vd)
 588           (propogate-deletes instance)
 589           (delete-records :from vt :where qualifier :database vd)
 590           (setf (slot-value instance 'view-database) nil)))))
 591   (values))
 592
 593 (defgeneric update-instance-from-records (instance &key database)
 594   (:documentation
 595    "Updates the values in the slots of the View Class instance
 596 INSTANCE using the data in the database DATABASE which defaults to the
 597 database that INSTANCE is associated with, or the value of
 598 *DEFAULT-DATABASE*."))
 599
 600 (defmethod update-instance-from-records ((instance standard-db-object)
 601                                          &key (database *default-database*))
 602   (let* ((view-class (find-class (class-name (class-of instance))))
 603          (view-table (sql-expression :table (view-table view-class)))
 604          (vd (or (view-database instance) database))
 605          (view-qual (key-qualifier-for-instance instance :database vd))
 606          (sels (generate-selection-list view-class))
 607          (res (apply #'select (append (mapcar #'cdr sels)
 608                                       (list :from  view-table
 609                                             :where view-qual)))))
 610     (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
 611
 612 (defgeneric update-slot-from-record (instance slot &key database)
 613   (:documentation
 614    "Updates the value in the slot SLOT of the View Class instance
 615 INSTANCE using the data in the database DATABASE which defaults to the
 616 database that INSTANCE is associated with, or the value of
 617 *DEFAULT-DATABASE*."))
 618
 619 (defmethod update-slot-from-record ((instance standard-db-object)
 620                                     slot &key (database *default-database*))
 621   (let* ((view-class (find-class (class-name (class-of instance))))
 622          (view-table (sql-expression :table (view-table view-class)))
 623          (vd (or (view-database instance) database))
 624          (view-qual (key-qualifier-for-instance instance :database vd))
 625          (slot-def (slotdef-for-slot-with-class slot view-class))
 626          (att-ref (generate-attribute-reference view-class slot-def))
 627          (res (select att-ref :from  view-table :where view-qual)))
 628     (get-slot-values-from-view instance (list slot-def) (car res))))
 629
 630
 631 (defgeneric database-null-value (type)
 632   (:documentation "Return an expression of type TYPE which SQL NULL values
 633 will be converted into."))
 634
 635 (defmethod database-null-value ((type t))
 636     (cond
 637      ((subtypep type 'string) "")
 638      ((subtypep type 'integer) 0)
 639      ((subtypep type 'float) (float 0.0))
 640      ((subtypep type 'list) nil)
 641      ((subtypep type 'boolean) nil)
 642      ((subtypep type 'symbol) nil)
 643      ((subtypep type 'keyword) nil)
 644      ((subtypep type 'wall-time) nil)
 645      (t
 646       (error "Unable to handle null for type ~A" type))))
 647
 648 (defgeneric update-slot-with-null (instance slotname slotdef)
 649   (:documentation "Called to update a slot when its column has a NULL
 650 value.  If nulls are allowed for the column, the slot's value will be
 651 nil, otherwise its value will be set to the result of calling
 652 DATABASE-NULL-VALUE on the type of the slot."))
 653
 654 (defmethod update-slot-with-null ((object standard-db-object)
 655                                   slotname
 656                                   slotdef)
 657   (let ((st (slot-type slotdef))
 658         (allowed (slot-value slotdef 'nulls-ok)))
 659     (if allowed
 660         (setf (slot-value object slotname) nil)
 661         (setf (slot-value object slotname)
 662               (database-null-value st)))))
 663
 664 (defvar +no-slot-value+ '+no-slot-value+)
 665
 666 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 667   (let* ((class (find-class classname))
 668          (sld (slotdef-for-slot-with-class slot class)))
 669     (if sld
 670         (if (eq value +no-slot-value+)
 671             (sql-expression :attribute (view-class-slot-column sld)
 672                             :table (view-table class))
 673             (db-value-from-slot
 674              sld
 675              value
 676              database))
 677         (error "Unknown slot ~A for class ~A" slot classname))))
 678
 679 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 680         (declare (ignore database))
 681         (let* ((class (find-class classname)))
 682           (unless (view-table class)
 683             (error "No view-table for class ~A"  classname))
 684           (sql-expression :table (view-table class))))
 685
 686 (defmethod database-get-type-specifier (type args database)
 687   (declare (ignore type args))
 688   (if (member (database-type database) '(:postgresql :postgresql-socket))
 689           "VARCHAR"
 690           "VARCHAR(255)"))
 691
 692 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 693   (declare (ignore database))
 694   ;;"INT8")
 695   (if args
 696       (format nil "INT(~A)" (car args))
 697       "INT"))
 698
 699 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 700                                         database)
 701   (if args
 702       (format nil "VARCHAR(~A)" (car args))
 703       (if (member (database-type database) '(:postgresql :postgresql-socket))
 704           "VARCHAR"
 705           "VARCHAR(255)")))
 706
 707 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 708                                         database)
 709   (if args
 710       (format nil "VARCHAR(~A)" (car args))
 711       (if (member (database-type database) '(:postgresql :postgresql-socket))
 712           "VARCHAR"
 713           "VARCHAR(255)")))
 714
 715 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 716   (if args
 717       (format nil "VARCHAR(~A)" (car args))
 718       (if (member (database-type database) '(:postgresql :postgresql-socket))
 719           "VARCHAR"
 720           "VARCHAR(255)")))
 721
 722 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 723   (declare (ignore args))
 724   (case (database-type database)
 725     (:postgresql
 726      "TIMESTAMP WITHOUT TIME ZONE")
 727     (:postgresql-socket
 728      "TIMESTAMP WITHOUT TIME ZONE")
 729     (:mysql
 730      "DATETIME")
 731     (t "TIMESTAMP")))
 732
 733 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 734   (declare (ignore database args))
 735   "INT8")
 736
 737 (deftype raw-string (&optional len)
 738   "A string which is not trimmed when retrieved from the database"
 739   `(string ,len))
 740
 741 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 742   (declare (ignore database))
 743   (if args
 744       (format nil "VARCHAR(~A)" (car args))
 745       "VARCHAR"))
 746
 747 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 748   (declare (ignore database))
 749   (if args
 750       (format nil "FLOAT(~A)" (car args))
 751       "FLOAT"))
 752
 753 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 754   (declare (ignore database))
 755   (if args
 756       (format nil "FLOAT(~A)" (car args))
 757       "FLOAT"))
 758
 759 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
 760   (declare (ignore args database))
 761   "BOOL")
 762
 763 (defmethod database-output-sql-as-type (type val database)
 764   (declare (ignore type database))
 765   val)
 766
 767 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 768   (declare (ignore database))
 769   (progv '(*print-circle* *print-array*) '(t t)
 770     (prin1-to-string val)))
 771
 772 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 773   (declare (ignore database))
 774   (if (keywordp val)
 775       (symbol-name val)
 776       (if val
 777           (concatenate 'string
 778                        (package-name (symbol-package val))
 779                        "::"
 780                        (symbol-name val))
 781           "")))
 782
 783 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 784   (declare (ignore database))
 785   (if val
 786       (symbol-name val)
 787       ""))
 788
 789 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
 790   (declare (ignore database))
 791   (progv '(*print-circle* *print-array*) '(t t)
 792     (prin1-to-string val)))
 793
 794 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
 795   (declare (ignore database))
 796   (progv '(*print-circle* *print-array*) '(t t)
 797     (prin1-to-string val)))
 798
 799 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
 800   (declare (ignore database))
 801   (if val "t" "f"))
 802
 803 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 804   (declare (ignore database))
 805   val)
 806
 807 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 808                                         val database)
 809   (declare (ignore database))
 810   val)
 811
 812 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 813                                         val database)
 814   (declare (ignore database))
 815   val)
 816
 817 (defmethod read-sql-value (val type database)
 818   (declare (ignore type database))
 819   (read-from-string val))
 820
 821 (defmethod read-sql-value (val (type (eql 'string)) database)
 822   (declare (ignore database))
 823   val)
 824
 825 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 826   (declare (ignore database))
 827   val)
 828
 829 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 830   (declare (ignore database))
 831   val)
 832
 833 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 834   (declare (ignore database))
 835   val)
 836
 837 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 838   (declare (ignore database))
 839   (when (< 0 (length val))
 840     (intern (string-upcase val) "KEYWORD")))
 841
 842 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 843   (declare (ignore database))
 844   (when (< 0 (length val))
 845     (if (find #\: val)
 846         (read-from-string val)
 847         (intern (string-upcase val) "KEYWORD"))))
 848
 849 (defmethod read-sql-value (val (type (eql 'integer)) database)
 850   (declare (ignore database))
 851   (etypecase val
 852     (string
 853      (read-from-string val))
 854     (number val)))
 855
 856 (defmethod read-sql-value (val (type (eql 'float)) database)
 857   (declare (ignore database))
 858   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 859   (float (read-from-string val)))
 860
 861 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 862   (declare (ignore database))
 863   (equal "t" val))
 864
 865 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 866   (declare (ignore database))
 867   (unless (eq 'NULL val)
 868     (parse-timestring val)))
 869
 870
 871 ;; ------------------------------------------------------------
 872 ;; Logic for 'faulting in' :join slots
 873
 874 (defun fault-join-slot-raw (class instancex slot-def)
 875   (let* ((dbi (view-class-slot-db-info slot-def))
 876          (jc (gethash :join-class dbi)))
 877     (let ((jq (join-qualifier class instance slot-def)))
 878       (when jq
 879         (select jc :where jq)))))
 880
 881 (defun fault-join-slot (class instance slot-def)
 882   (let* ((dbi (view-class-slot-db-info slot-def))
 883          (ts (gethash :target-slot dbi))
 884          (res (fault-join-slot-raw class instance slot-def)))
 885     (when res
 886       (cond
 887         ((and ts (gethash :set dbi))
 888          (mapcar (lambda (obj)
 889                    (cons obj (slot-value obj ts))) res))
 890         ((and ts (not (gethash :set dbi)))
 891          (mapcar (lambda (obj) (slot-value obj ts)) res))
 892         ((and (not ts) (not (gethash :set dbi)))
 893          (car res))
 894         ((and (not ts) (gethash :set dbi))
 895          res)))))
 896
 897 (defun join-qualifier (class object slot-def)
 898     (declare (ignore class))
 899     (let* ((dbi (view-class-slot-db-info slot-def))
 900            (jc (find-class (gethash :join-class dbi)))
 901            ;;(ts (gethash :target-slot dbi))
 902            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 903            (foreign-keys (gethash :foreign-key dbi))
 904            (home-keys (gethash :home-key dbi)))
 905       (when (every #'(lambda (slt)
 906                        (and (slot-boundp object slt)
 907                             (not (null (slot-value object slt)))))
 908                    (if (listp home-keys) home-keys (list home-keys)))
 909         (let ((jc
 910                (mapcar #'(lambda (hk fk)
 911                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 912                              (sql-operation '==
 913                                             (typecase fk
 914                                               (symbol
 915                                                (sql-expression
 916                                                 :attribute
 917                                                 (view-class-slot-column fksd)
 918                                                 :table (view-table jc)))
 919                                               (t fk))
 920                                             (typecase hk
 921                                               (symbol
 922                                                (slot-value object hk))
 923                                               (t
 924                                                hk)))))
 925                        (if (listp home-keys)
 926                            home-keys
 927                            (list home-keys))
 928                        (if (listp foreign-keys)
 929                            foreign-keys
 930                            (list foreign-keys)))))
 931           (when jc
 932             (if (> (length jc) 1)
 933                 (apply #'sql-and jc)
 934                 jc))))))
 935
 936
 937 (defun find-all (view-classes &rest args &key all set-operation distinct from
 938                  where group-by having order-by order-by-descending offset limit
 939                  (database *default-database*))
 940   "tweeze me apart someone pleeze"
 941   (declare (ignore all set-operation from group-by having offset limit)
 942            (optimize (debug 3) (speed 1)))
 943   (let* ((*db-deserializing* t)
 944          (*default-database* (or database (error 'clsql-nodb-error))))
 945     (flet ((table-sql-expr (table)
 946              (sql-expression :table (view-table table)))
 947            (ref-equal (ref1 ref2)
 948              (equal (sql ref1)
 949                     (sql ref2)))
 950            (tables-equal (table-a table-b)
 951              (string= (string (slot-value table-a 'name))
 952                       (string (slot-value table-b 'name)))))
 953
 954       (let* ((sclasses (mapcar #'find-class view-classes))
 955              (sels (mapcar #'generate-selection-list sclasses))
 956              (fullsels (apply #'append sels))
 957              (sel-tables (collect-table-refs where))
 958              (tables
 959               (remove-duplicates
 960                (append (mapcar #'table-sql-expr sclasses) sel-tables)
 961                :test #'tables-equal))
 962              (res nil))
 963         (dolist (ob (listify order-by))
 964           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 965                                      :test #'ref-equal)))
 966             (setq fullsels
 967                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 968                                            (listify ob))))))
 969         (dolist (ob (listify order-by-descending))
 970           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 971                                      :test #'ref-equal)))
 972             (setq fullsels
 973                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 974                                            (listify ob))))))
 975         (dolist (ob (listify distinct))
 976           (when (and (typep ob 'sql-ident)
 977                      (not (member ob (mapcar #'cdr fullsels)
 978                                   :test #'ref-equal)))
 979             (setq fullsels
 980                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 981                                            (listify ob))))))
 982         ;;(format t "~%fullsels is : ~A" fullsels)
 983         (setq res (apply #'select (append (mapcar #'cdr fullsels)
 984                                           (cons :from (list tables)) args)))
 985         (flet ((build-instance (vals)
 986                  (flet ((%build-instance (vclass selects)
 987                           (let ((class-name (class-name vclass))
 988                                 (db-vals (butlast vals
 989                                                   (- (list-length vals)
 990                                                      (list-length selects))))
 991                                 cache-key)
 992                             (setf vals (nthcdr (list-length selects) vals))
 993                             (loop for select in selects
 994                                   for value in db-vals
 995                                   do
 996                                   (when (eql (slot-value (car select) 'db-kind)
 997                                              :key)
 998                                     (push
 999                                      (key-value-from-db (car select) value
1000                                                         *default-database*)
1001                                      cache-key)))
1002                             (push class-name cache-key)
1003                             (%make-fresh-object class-name
1004                                                 (mapcar #'car selects)
1005                                                 db-vals))))
1006                    (let ((instances (mapcar #'%build-instance sclasses sels)))
1007                      (if (= (length sclasses) 1)
1008                          (car instances)
1009                          instances)))))
1010           (remove-if #'null (mapcar #'build-instance res)))))))
1011
1012 (defun %make-fresh-object (class-name slots values)
1013   (let* ((*db-initializing* t)
1014          (obj (make-instance class-name
1015                              :view-database *default-database*)))
1016     (setf obj (get-slot-values-from-view obj slots values))
1017     (postinitialize obj)
1018     obj))
1019
1020 (defmethod postinitialize ((self t))
1021   )
1022
1023 (defun select (&rest select-all-args)
1024   "Selects data from database given the constraints specified. Returns
1025 a list of lists of record values as specified by select-all-args. By
1026 default, the records are each represented as lists of attribute
1027 values. The selections argument may be either db-identifiers, literal
1028 strings or view classes.  If the argument consists solely of view
1029 classes, the return value will be instances of objects rather than raw
1030 tuples."
1031   (flet ((select-objects (target-args)
1032            (and target-args
1033                 (every #'(lambda (arg)
1034                            (and (symbolp arg)
1035                                 (find-class arg nil)))
1036                        target-args))))
1037     (multiple-value-bind (target-args qualifier-args)
1038         (query-get-selections select-all-args)
1039       ;; (cmsg "Qual args = ~s" qualifier-args)
1040       (if (select-objects target-args)
1041           (apply #'find-all target-args qualifier-args)
1042           (let ((expr (apply #'make-query select-all-args)))
1043             (destructuring-bind (&key (flatp nil)
1044                                       (database *default-database*)
1045                                       &allow-other-keys)
1046                 qualifier-args
1047               (let ((res (query expr :database database)))
1048                 (if (and flatp
1049                          (= (length (slot-value expr 'selections)) 1))
1050                     (mapcar #'car res)
1051                   res))))))))