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