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