sql/objects.lisp

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