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