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