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