sql/objects.lisp

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