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