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