sql/objects.lisp

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