sql/new-objects.lisp

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