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)
  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 *update-records-on-make-instance* nil
  25   "When T, UPDATE-RECORDS-FROM-INSTANCE will be automatically called
  26 when a new instance of a view-class is created.")
  27
  28 (defvar *db-deserializing* nil)
  29 (defvar *db-initializing* nil)
  30
  31 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
  32   (declare (optimize (speed 3)))
  33   (unless *db-deserializing*
  34     (let* ((slot-name (%svuc-slot-name slot-def))
  35            (slot-object (%svuc-slot-object slot-def class))
  36            (slot-kind (view-class-slot-db-kind slot-object)))
  37       (when (and (eql slot-kind :join)
  38                  (not (slot-boundp instance slot-name)))
  39         (let ((*db-deserializing* t))
  40           (if (view-database instance)
  41               (setf (slot-value instance slot-name)
  42                     (fault-join-slot class instance slot-object))
  43               (setf (slot-value instance slot-name) nil))))))
  44   (call-next-method))
  45
  46 #+ignore ;; not currently used
  47 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
  48                                           instance slot)
  49   (declare (ignore new-value instance slot))
  50   (call-next-method))
  51
  52 (defmethod initialize-instance ((object standard-db-object)
  53                                         &rest all-keys &key &allow-other-keys)
  54   (declare (ignore all-keys))
  55   (let ((*db-initializing* t))
  56     (call-next-method)
  57     (when (and *update-records-on-make-instance*
  58                (not *db-deserializing*))
  59       #+nil (created-object object)
  60       (update-records-from-instance object))))
  61
  62 ;;
  63 ;; Build the database tables required to store the given view class
  64 ;;
  65
  66 (defun create-view-from-class (view-class-name
  67                                &key (database *default-database*))
  68   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
  69 the view. The argument DATABASE has a default value of
  70 *DEFAULT-DATABASE*."
  71   (let ((tclass (find-class view-class-name)))
  72     (if tclass
  73         (let ((*default-database* database))
  74           (%install-class tclass database))
  75         (error "Class ~s not found." view-class-name)))
  76   (values))
  77
  78 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
  79   (dolist (slotdef (ordered-class-slots self))
  80     (let ((res (database-generate-column-definition (class-name self)
  81                                                     slotdef database)))
  82       (when res
  83         (push res schemadef))))
  84   (unless schemadef
  85     (error "Class ~s has no :base slots" self))
  86   (create-table (sql-expression :table (view-table self)) schemadef
  87                 :database database
  88                 :constraints (database-pkey-constraint self database))
  89   (push self (database-view-classes database))
  90   t)
  91
  92 (defmethod database-pkey-constraint ((class standard-db-class) database)
  93   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
  94     (when keylist
  95       (convert-to-db-default-case
  96        (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
  97                (database-output-sql (view-table class) database)
  98                (database-output-sql keylist database))
  99        database))))
 100
 101 (defmethod database-generate-column-definition (class slotdef database)
 102   (declare (ignore database class))
 103   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
 104     (let ((cdef
 105            (list (sql-expression :attribute (view-class-slot-column slotdef))
 106                  (specified-type slotdef))))
 107       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
 108       (let ((const (view-class-slot-db-constraints slotdef)))
 109         (when const
 110           (setq cdef (append cdef (list const)))))
 111       cdef)))
 112
 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::standard-db-class) `,cl-options)))
 179     (finalize-inheritance (find-class ',class))
 180     (find-class ',class)))
 181
 182 (defun keyslots-for-class (class)
 183   (slot-value class 'key-slots))
 184
 185 (defun key-qualifier-for-instance (obj &key (database *default-database*))
 186   (let ((tb (view-table (class-of obj))))
 187     (flet ((qfk (k)
 188              (sql-operation '==
 189                             (sql-expression :attribute
 190                                             (view-class-slot-column k)
 191                                             :table tb)
 192                             (db-value-from-slot
 193                              k
 194                              (slot-value obj (slot-definition-name k))
 195                              database))))
 196       (let* ((keys (keyslots-for-class (class-of obj)))
 197              (keyxprs (mapcar #'qfk (reverse keys))))
 198         (cond
 199           ((= (length keyxprs) 0) nil)
 200           ((= (length keyxprs) 1) (car keyxprs))
 201           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
 202
 203 ;;
 204 ;; Function used by 'generate-selection-list'
 205 ;;
 206
 207 (defun generate-attribute-reference (vclass slotdef)
 208   (cond
 209    ((eq (view-class-slot-db-kind slotdef) :base)
 210     (sql-expression :attribute (view-class-slot-column slotdef)
 211                     :table (view-table vclass)))
 212    ((eq (view-class-slot-db-kind slotdef) :key)
 213     (sql-expression :attribute (view-class-slot-column slotdef)
 214                     :table (view-table vclass)))
 215    (t nil)))
 216
 217 ;;
 218 ;; Function used by 'find-all'
 219 ;;
 220
 221 (defun generate-selection-list (vclass)
 222   (let ((sels nil))
 223     (dolist (slotdef (ordered-class-slots vclass))
 224       (let ((res (generate-attribute-reference vclass slotdef)))
 225         (when res
 226           (push (cons slotdef res) sels))))
 227     (if sels
 228         sels
 229         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 230
 231
 232 ;;
 233 ;; Called by 'get-slot-values-from-view'
 234 ;;
 235
 236 (declaim (inline delistify))
 237 (defun delistify (list)
 238   (if (listp list)
 239       (car list)
 240       list))
 241
 242 (defvar *update-context* nil)
 243
 244 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
 245   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 246   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 247          (slot-name   (slot-definition-name slotdef))
 248          (slot-type   (specified-type slotdef))
 249          (*update-context* (cons (type-of instance) slot-name)))
 250     (cond ((and value (null slot-reader))
 251            (setf (slot-value instance slot-name)
 252                  (read-sql-value value (delistify slot-type)
 253                                  (view-database instance))))
 254           ((null value)
 255            (update-slot-with-null instance slot-name slotdef))
 256           ((typep slot-reader 'string)
 257            (setf (slot-value instance slot-name)
 258                  (format nil slot-reader value)))
 259           ((typep slot-reader 'function)
 260            (setf (slot-value instance slot-name)
 261                  (apply slot-reader (list value))))
 262           (t
 263            (error "Slot reader is of an unusual type.")))))
 264
 265 (defmethod key-value-from-db (slotdef value database)
 266   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 267   (let ((slot-reader (view-class-slot-db-reader slotdef))
 268         (slot-type (specified-type slotdef)))
 269     (cond ((and value (null slot-reader))
 270            (read-sql-value value (delistify slot-type) database))
 271           ((null value)
 272            nil)
 273           ((typep slot-reader 'string)
 274            (format nil slot-reader value))
 275           ((typep slot-reader 'function)
 276            (apply slot-reader (list value)))
 277           (t
 278            (error "Slot reader is of an unusual type.")))))
 279
 280 (defun db-value-from-slot (slotdef val database)
 281   (let ((dbwriter (view-class-slot-db-writer slotdef))
 282         (dbtype (specified-type slotdef)))
 283     (typecase dbwriter
 284       (string (format nil dbwriter val))
 285       (function (apply dbwriter (list val)))
 286       (t
 287        (typecase dbtype
 288          (cons
 289           (database-output-sql-as-type (car dbtype) val database))
 290          (t
 291           (database-output-sql-as-type dbtype val database)))))))
 292
 293 (defun check-slot-type (slotdef val)
 294   (let* ((slot-type (specified-type slotdef))
 295          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 296     (when (and slot-type val)
 297       (unless (typep val basetype)
 298         (error 'clsql-type-error
 299                :slotname (slot-definition-name slotdef)
 300                :typespec slot-type
 301                :value val)))))
 302
 303 ;;
 304 ;; Called by find-all
 305 ;;
 306
 307 (defmethod get-slot-values-from-view (obj slotdeflist values)
 308     (flet ((update-slot (slot-def values)
 309              (update-slot-from-db obj slot-def values)))
 310       (mapc #'update-slot slotdeflist values)
 311       obj))
 312
 313 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 314                                     (database *default-database*))
 315   (let* ((database (or (view-database obj) database))
 316          (vct (view-table (class-of obj)))
 317          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 318     (check-slot-type sd (slot-value obj slot))
 319     (let* ((att (view-class-slot-column sd))
 320            (val (db-value-from-slot sd (slot-value obj slot) database)))
 321       (cond ((and vct sd (view-database obj))
 322              (update-records (sql-expression :table vct)
 323                              :attributes (list (sql-expression :attribute att))
 324                              :values (list val)
 325                              :where (key-qualifier-for-instance
 326                                      obj :database database)
 327                              :database database))
 328             ((and vct sd (not (view-database obj)))
 329              (insert-records :into (sql-expression :table vct)
 330                              :attributes (list (sql-expression :attribute att))
 331                              :values (list val)
 332                              :database database)
 333              (setf (slot-value obj 'view-database) database))
 334             (t
 335              (error "Unable to update record.")))))
 336   (values))
 337
 338 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 339                                      (database *default-database*))
 340   (let* ((database (or (view-database obj) database))
 341          (vct (view-table (class-of obj)))
 342          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 343          (avps (mapcar #'(lambda (s)
 344                            (let ((val (slot-value
 345                                        obj (slot-definition-name s))))
 346                              (check-slot-type s val)
 347                              (list (sql-expression
 348                                     :attribute (view-class-slot-column s))
 349                                    (db-value-from-slot s val database))))
 350                        sds)))
 351     (cond ((and avps (view-database obj))
 352            (update-records (sql-expression :table vct)
 353                            :av-pairs avps
 354                            :where (key-qualifier-for-instance
 355                                    obj :database database)
 356                            :database database))
 357           ((and avps (not (view-database obj)))
 358            (insert-records :into (sql-expression :table vct)
 359                            :av-pairs avps
 360                            :database database)
 361            (setf (slot-value obj 'view-database) database))
 362           (t
 363            (error "Unable to update records"))))
 364   (values))
 365
 366 (defmethod update-records-from-instance ((obj standard-db-object)
 367                                          &key (database *default-database*))
 368   (let ((database (or (view-database obj) database)))
 369     (labels ((slot-storedp (slot)
 370                (and (member (view-class-slot-db-kind slot) '(:base :key))
 371                     (slot-boundp obj (slot-definition-name slot))))
 372              (slot-value-list (slot)
 373                (let ((value (slot-value obj (slot-definition-name slot))))
 374                  (check-slot-type slot value)
 375                  (list (sql-expression :attribute (view-class-slot-column slot))
 376                        (db-value-from-slot slot value database)))))
 377       (let* ((view-class (class-of obj))
 378              (view-class-table (view-table view-class))
 379              (slots (remove-if-not #'slot-storedp
 380                                    (ordered-class-slots view-class)))
 381              (record-values (mapcar #'slot-value-list slots)))
 382         (unless record-values
 383           (error "No settable slots."))
 384         (if (view-database obj)
 385             (update-records (sql-expression :table view-class-table)
 386                             :av-pairs record-values
 387                             :where (key-qualifier-for-instance
 388                                     obj :database database)
 389                             :database database)
 390             (progn
 391               (insert-records :into (sql-expression :table view-class-table)
 392                               :av-pairs record-values
 393                               :database database)
 394               (setf (slot-value obj 'view-database) database))))))
 395   (values))
 396
 397 (defmethod delete-instance-records ((instance standard-db-object))
 398   (let ((vt (sql-expression :table (view-table (class-of instance))))
 399         (vd (view-database instance)))
 400     (if vd
 401         (let ((qualifier (key-qualifier-for-instance instance :database vd)))
 402           (delete-records :from vt :where qualifier :database vd)
 403           (setf (slot-value instance 'view-database) nil))
 404         (error 'clsql-base::clsql-no-database-error :database nil))))
 405
 406 (defmethod update-instance-from-records ((instance standard-db-object)
 407                                          &key (database *default-database*))
 408   (let* ((view-class (find-class (class-name (class-of instance))))
 409          (view-table (sql-expression :table (view-table view-class)))
 410          (vd (or (view-database instance) database))
 411          (view-qual (key-qualifier-for-instance instance :database vd))
 412          (sels (generate-selection-list view-class))
 413          (res (apply #'select (append (mapcar #'cdr sels)
 414                                       (list :from  view-table
 415                                             :where view-qual)
 416                                       (list :result-types nil)))))
 417     (when res
 418       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 419
 420 (defmethod update-slot-from-record ((instance standard-db-object)
 421                                     slot &key (database *default-database*))
 422   (let* ((view-class (find-class (class-name (class-of instance))))
 423          (view-table (sql-expression :table (view-table view-class)))
 424          (vd (or (view-database instance) database))
 425          (view-qual (key-qualifier-for-instance instance :database vd))
 426          (slot-def (slotdef-for-slot-with-class slot view-class))
 427          (att-ref (generate-attribute-reference view-class slot-def))
 428          (res (select att-ref :from  view-table :where view-qual
 429                       :result-types nil)))
 430     (when res
 431       (get-slot-values-from-view instance (list slot-def) (car res)))))
 432
 433
 434 (defmethod update-slot-with-null ((object standard-db-object)
 435                                   slotname
 436                                   slotdef)
 437   (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 438
 439 (defvar +no-slot-value+ '+no-slot-value+)
 440
 441 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 442   (let* ((class (find-class classname))
 443          (sld (slotdef-for-slot-with-class slot class)))
 444     (if sld
 445         (if (eq value +no-slot-value+)
 446             (sql-expression :attribute (view-class-slot-column sld)
 447                             :table (view-table class))
 448             (db-value-from-slot
 449              sld
 450              value
 451              database))
 452         (error "Unknown slot ~A for class ~A" slot classname))))
 453
 454 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 455         (declare (ignore database))
 456         (let* ((class (find-class classname)))
 457           (unless (view-table class)
 458             (error "No view-table for class ~A"  classname))
 459           (sql-expression :table (view-table class))))
 460
 461 (defmethod database-get-type-specifier (type args database)
 462   (declare (ignore type args))
 463   (if (clsql-base::in (database-underlying-type database)
 464                           :postgresql :postgresql-socket)
 465           "VARCHAR"
 466           "VARCHAR(255)"))
 467
 468 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 469   (declare (ignore database))
 470   ;;"INT8")
 471   (if args
 472       (format nil "INT(~A)" (car args))
 473       "INT"))
 474
 475 (deftype bigint ()
 476   "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
 477   'integer)
 478
 479 (defmethod database-get-type-specifier ((type (eql 'bigint)) args database)
 480   (declare (ignore args database))
 481   "BIGINT")
 482
 483 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 484                                         database)
 485   (if args
 486       (format nil "VARCHAR(~A)" (car args))
 487     (if (clsql-base::in (database-underlying-type database)
 488                             :postgresql :postgresql-socket)
 489         "VARCHAR"
 490       "VARCHAR(255)")))
 491
 492 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 493                                         database)
 494   (if args
 495       (format nil "VARCHAR(~A)" (car args))
 496     (if (clsql-base::in (database-underlying-type database)
 497                             :postgresql :postgresql-socket)
 498         "VARCHAR"
 499       "VARCHAR(255)")))
 500
 501 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 502   (if args
 503       (format nil "VARCHAR(~A)" (car args))
 504     (if (clsql-base::in (database-underlying-type database)
 505                             :postgresql :postgresql-socket)
 506         "VARCHAR"
 507       "VARCHAR(255)")))
 508
 509 (deftype universal-time ()
 510   "A positive integer as returned by GET-UNIVERSAL-TIME."
 511   '(integer 1 *))
 512
 513 (defmethod database-get-type-specifier ((type (eql 'universal-time)) args database)
 514   (declare (ignore args database))
 515   "BIGINT")
 516
 517 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 518   (declare (ignore args))
 519   (case (database-underlying-type database)
 520     ((:postgresql :postgresql-socket)
 521      "TIMESTAMP WITHOUT TIME ZONE")
 522     (:mysql
 523      "DATETIME")
 524     (t "TIMESTAMP")))
 525
 526 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 527   (declare (ignore database args))
 528   "VARCHAR")
 529
 530 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
 531   (declare (ignore database args))
 532   "INT8")
 533
 534 (deftype raw-string (&optional len)
 535   "A string which is not trimmed when retrieved from the database"
 536   `(string ,len))
 537
 538 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 539   (declare (ignore database))
 540   (if args
 541       (format nil "VARCHAR(~A)" (car args))
 542       "VARCHAR"))
 543
 544 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 545   (declare (ignore database))
 546   (if args
 547       (format nil "FLOAT(~A)" (car args))
 548       "FLOAT"))
 549
 550 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 551   (declare (ignore database))
 552   (if args
 553       (format nil "FLOAT(~A)" (car args))
 554       "FLOAT"))
 555
 556 (defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
 557   (declare (ignore args database))
 558   "BOOL")
 559
 560 (defmethod database-output-sql-as-type (type val database)
 561   (declare (ignore type database))
 562   val)
 563
 564 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 565   (declare (ignore database))
 566   (progv '(*print-circle* *print-array*) '(t t)
 567     (let ((escaped (prin1-to-string val)))
 568       (clsql-base::substitute-char-string
 569        escaped #\Null " "))))
 570
 571 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 572   (declare (ignore database))
 573   (if (keywordp val)
 574       (symbol-name val)
 575       (if val
 576           (concatenate 'string
 577                        (package-name (symbol-package val))
 578                        "::"
 579                        (symbol-name val))
 580           "")))
 581
 582 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 583   (declare (ignore database))
 584   (if val
 585       (symbol-name val)
 586       ""))
 587
 588 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
 589   (declare (ignore database))
 590   (progv '(*print-circle* *print-array*) '(t t)
 591     (prin1-to-string val)))
 592
 593 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
 594   (declare (ignore database))
 595   (progv '(*print-circle* *print-array*) '(t t)
 596     (prin1-to-string val)))
 597
 598 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
 599   (case (database-underlying-type database)
 600     (:mysql
 601      (if val 1 0))
 602     (t
 603      (if val "t" "f"))))
 604
 605 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 606   (declare (ignore database))
 607   val)
 608
 609 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 610                                         val database)
 611   (declare (ignore database))
 612   val)
 613
 614 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 615                                         val database)
 616   (declare (ignore database))
 617   val)
 618
 619 (defmethod read-sql-value (val type database)
 620   (declare (ignore type database))
 621   (read-from-string val))
 622
 623 (defmethod read-sql-value (val (type (eql 'string)) database)
 624   (declare (ignore database))
 625   val)
 626
 627 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 628   (declare (ignore database))
 629   val)
 630
 631 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 632   (declare (ignore database))
 633   val)
 634
 635 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 636   (declare (ignore database))
 637   val)
 638
 639 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 640   (declare (ignore database))
 641   (when (< 0 (length val))
 642     (intern (symbol-name-default-case val)
 643             (find-package '#:keyword))))
 644
 645 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 646   (declare (ignore database))
 647   (when (< 0 (length val))
 648     (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
 649       (intern (clsql-base:symbol-name-default-case val)
 650               (symbol-package *update-context*)))))
 651
 652 (defmethod read-sql-value (val (type (eql 'integer)) database)
 653   (declare (ignore database))
 654   (etypecase val
 655     (string
 656      (unless (string-equal "NIL" val)
 657        (parse-integer val)))
 658     (number val)))
 659
 660 (defmethod read-sql-value (val (type (eql 'bigint)) database)
 661   (declare (ignore database))
 662   (etypecase val
 663     (string
 664      (unless (string-equal "NIL" val)
 665        (parse-integer val)))
 666     (number val)))
 667
 668 (defmethod read-sql-value (val (type (eql 'float)) database)
 669   (declare (ignore database))
 670   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 671   (float (read-from-string val)))
 672
 673 (defmethod read-sql-value (val (type (eql 'boolean)) database)
 674   (case (database-underlying-type database)
 675     (:mysql
 676      (etypecase val
 677        (string (if (string= "0" val) nil t))
 678        (integer (if (zerop val) nil t))))
 679     (:postgresql
 680      (if (eq :odbc (database-type database))
 681          (if (string= "0" val) nil t)
 682        (equal "t" val)))
 683     (t
 684      (equal "t" val))))
 685
 686 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
 687   (declare (ignore database))
 688   (unless (eq 'NULL val)
 689     (etypecase val
 690       (string
 691        (parse-integer val))
 692       (number val))))
 693
 694 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 695   (declare (ignore database))
 696   (unless (eq 'NULL val)
 697     (parse-timestring val)))
 698
 699 (defmethod read-sql-value (val (type (eql 'duration)) database)
 700   (declare (ignore database))
 701   (unless (or (eq 'NULL val)
 702               (equal "NIL" val))
 703     (parse-timestring val)))
 704
 705 ;; ------------------------------------------------------------
 706 ;; Logic for 'faulting in' :join slots
 707
 708 ;; this works, but is inefficient requiring (+ 1 n-rows)
 709 ;; SQL queries
 710 #+ignore
 711 (defun fault-join-target-slot (class object slot-def)
 712   (let* ((res (fault-join-slot-raw class object slot-def))
 713          (dbi (view-class-slot-db-info slot-def))
 714          (target-name (gethash :target-slot dbi))
 715          (target-class (find-class target-name)))
 716     (when res
 717       (mapcar (lambda (obj)
 718                 (list
 719                  (car
 720                   (fault-join-slot-raw
 721                    target-class
 722                    obj
 723                    (find target-name (class-slots (class-of obj))
 724                          :key #'slot-definition-name)))
 725                  obj))
 726               res)
 727       #+ignore ;; this doesn't work when attempting to call slot-value
 728       (mapcar (lambda (obj)
 729                 (cons obj (slot-value obj ts))) res))))
 730
 731 (defun fault-join-target-slot (class object slot-def)
 732   (let* ((dbi (view-class-slot-db-info slot-def))
 733          (ts (gethash :target-slot dbi))
 734          (jc (gethash :join-class dbi))
 735          (tdbi (view-class-slot-db-info
 736                 (find ts (class-slots (find-class jc))
 737                       :key #'slot-definition-name)))
 738          (retrieval (gethash :retrieval tdbi))
 739          (jq (join-qualifier class object slot-def))
 740          (key (slot-value object (gethash :home-key dbi))))
 741     (when jq
 742       (ecase retrieval
 743         (:immediate
 744          (let ((res
 745                 (find-all (list ts)
 746                           :inner-join (sql-expression :attribute jc)
 747                           :on (sql-operation
 748                                '==
 749                                (sql-expression :attribute (gethash :foreign-key tdbi) :table ts)
 750                                (sql-expression :attribute (gethash :home-key tdbi) :table jc))
 751                           :where jq
 752                           :result-types :auto)))
 753            (mapcar #'(lambda (i)
 754                        (let* ((instance (car i))
 755                               (jcc (make-instance jc :view-database (view-database instance))))
 756                          (setf (slot-value jcc (gethash :foreign-key dbi))
 757                                key)
 758                          (setf (slot-value jcc (gethash :home-key tdbi))
 759                                (slot-value instance (gethash :foreign-key tdbi)))
 760                       (list instance jcc)))
 761                    res)))
 762         (:deferred
 763             ;; just fill in minimal slots
 764             (mapcar
 765              #'(lambda (k)
 766                  (let ((instance (make-instance ts :view-database (view-database object)))
 767                        (jcc (make-instance jc :view-database (view-database object)))
 768                        (fk (car k)))
 769                    (setf (slot-value instance (gethash :home-key tdbi)) fk)
 770                    (setf (slot-value jcc (gethash :foreign-key dbi))
 771                          key)
 772                    (setf (slot-value jcc (gethash :home-key tdbi))
 773                          fk)
 774                    (list instance jcc)))
 775              (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc)
 776                      :from (sql-expression :table jc)
 777                      :where jq)))))))
 778
 779 (defun update-object-joins (objects &key (slots t) (force-p t)
 780                             class-name (max-len *default-update-objects-max-len))
 781   "Updates the remote join slots, that is those slots defined without :retrieval :immediate."
 782   (when objects
 783     (unless class-name
 784       (class-name (class-of (first object))))
 785     )
 786   )
 787
 788
 789 (defun fault-join-slot-raw (class object slot-def)
 790   (let* ((dbi (view-class-slot-db-info slot-def))
 791          (jc (gethash :join-class dbi)))
 792     (let ((jq (join-qualifier class object slot-def)))
 793       (when jq
 794         (select jc :where jq :flatp t :result-types nil)))))
 795
 796 (defun fault-join-slot (class object slot-def)
 797   (let* ((dbi (view-class-slot-db-info slot-def))
 798          (ts (gethash :target-slot dbi)))
 799     (if (and ts (gethash :set dbi))
 800         (fault-join-target-slot class object slot-def)
 801         (let ((res (fault-join-slot-raw class object slot-def)))
 802           (when res
 803             (cond
 804               ((and ts (not (gethash :set dbi)))
 805                (mapcar (lambda (obj) (slot-value obj ts)) res))
 806               ((and (not ts) (not (gethash :set dbi)))
 807                (car res))
 808               ((and (not ts) (gethash :set dbi))
 809                res)))))))
 810
 811 (defun join-qualifier (class object slot-def)
 812     (declare (ignore class))
 813     (let* ((dbi (view-class-slot-db-info slot-def))
 814            (jc (find-class (gethash :join-class dbi)))
 815            ;;(ts (gethash :target-slot dbi))
 816            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 817            (foreign-keys (gethash :foreign-key dbi))
 818            (home-keys (gethash :home-key dbi)))
 819       (when (every #'(lambda (slt)
 820                        (and (slot-boundp object slt)
 821                             (not (null (slot-value object slt)))))
 822                    (if (listp home-keys) home-keys (list home-keys)))
 823         (let ((jc
 824                (mapcar #'(lambda (hk fk)
 825                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 826                              (sql-operation '==
 827                                             (typecase fk
 828                                               (symbol
 829                                                (sql-expression
 830                                                 :attribute
 831                                                 (view-class-slot-column fksd)
 832                                                 :table (view-table jc)))
 833                                               (t fk))
 834                                             (typecase hk
 835                                               (symbol
 836                                                (slot-value object hk))
 837                                               (t
 838                                                hk)))))
 839                        (if (listp home-keys)
 840                            home-keys
 841                            (list home-keys))
 842                        (if (listp foreign-keys)
 843                            foreign-keys
 844                            (list foreign-keys)))))
 845           (when jc
 846             (if (> (length jc) 1)
 847                 (apply #'sql-and jc)
 848                 jc))))))
 849
 850 (defun find-all (view-classes
 851                  &rest args
 852                  &key all set-operation distinct from where group-by having
 853                       order-by order-by-descending offset limit refresh
 854                       flatp result-types inner-join on
 855                       (database *default-database*))
 856   "Called by SELECT to generate object query results when the
 857   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 858   (declare (ignore all set-operation group-by having offset limit inner-join on)
 859            (optimize (debug 3) (speed 1)))
 860   (remf args :from)
 861   (remf args :flatp)
 862   (remf args :additional-fields)
 863   (remf args :result-types)
 864   (labels ((table-sql-expr (table)
 865              (sql-expression :table (view-table table)))
 866            (ref-equal (ref1 ref2)
 867              (equal (sql ref1)
 868                     (sql ref2)))
 869            (tables-equal (table-a table-b)
 870              (string= (string (slot-value table-a 'name))
 871                       (string (slot-value table-b 'name))))
 872            (build-object (vals vclass selects)
 873              (let* ((class-name (class-name vclass))
 874                     (db-vals (butlast vals (- (list-length vals)
 875                                               (list-length selects))))
 876                     (*db-initializing* t)
 877                     (obj (make-instance class-name :view-database database)))
 878                ;; use refresh keyword here
 879                (setf obj (get-slot-values-from-view obj (mapcar #'car selects)
 880                                                     db-vals))
 881                (when refresh (instance-refreshed obj))
 882                obj))
 883            (build-objects (vals sclasses sels)
 884              (let ((objects (mapcar #'(lambda (sclass sel)
 885                                         (prog1 (build-object vals sclass sel)
 886                                           (setf vals (nthcdr (list-length sel)
 887                                                              vals))))
 888                                     sclasses sels)))
 889                (if (and flatp (= (length sclasses) 1))
 890                    (car objects)
 891                    objects))))
 892     (let* ((*db-deserializing* t)
 893            (*default-database* (or database
 894                                    (error 'clsql-base::clsql-no-database-error :database nil)))
 895            (sclasses (mapcar #'find-class view-classes))
 896            (sels (mapcar #'generate-selection-list sclasses))
 897            (fullsels (apply #'append sels))
 898            (sel-tables (collect-table-refs where))
 899            (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
 900                                               sel-tables)
 901                                       :test #'tables-equal))
 902            (res nil))
 903         (dolist (ob (listify order-by))
 904           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 905                                      :test #'ref-equal)))
 906             (setq fullsels
 907                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 908                                            (listify ob))))))
 909         (dolist (ob (listify order-by-descending))
 910           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 911                                      :test #'ref-equal)))
 912             (setq fullsels
 913                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 914                                            (listify ob))))))
 915         (dolist (ob (listify distinct))
 916           (when (and (typep ob 'sql-ident)
 917                      (not (member ob (mapcar #'cdr fullsels)
 918                                   :test #'ref-equal)))
 919             (setq fullsels
 920                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 921                                            (listify ob))))))
 922         (setq res
 923               (apply #'select
 924                      (append (mapcar #'cdr fullsels)
 925                              (cons :from
 926                                    (list (append (when from (listify from))
 927                                                  (listify tables))))
 928                              (list :result-types result-types)
 929                              args)))
 930         (mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
 931
 932 (defmethod instance-refreshed ((instance standard-db-object)))
 933
 934 (defun select (&rest select-all-args)
 935    "The function SELECT selects data from DATABASE, which has a
 936 default value of *DEFAULT-DATABASE*, given the constraints
 937 specified by the rest of the ARGS. It returns a list of objects
 938 as specified by SELECTIONS. By default, the objects will each be
 939 represented as lists of attribute values. The argument SELECTIONS
 940 consists either of database identifiers, type-modified database
 941 identifiers or literal strings. A type-modifed database
 942 identifier is an expression such as [foo :string] which means
 943 that the values in column foo are returned as Lisp strings.  The
 944 FLATP argument, which has a default value of nil, specifies if
 945 full bracketed results should be returned for each matched
 946 entry. If FLATP is nil, the results are returned as a list of
 947 lists. If FLATP is t, the results are returned as elements of a
 948 list, only if there is only one result per row. The arguments
 949 ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
 950 ORDER-by have the same function as the equivalent SQL expression.
 951 The SELECT function is common across both the functional and
 952 object-oriented SQL interfaces. If selections refers to View
 953 Classes then the select operation becomes object-oriented. This
 954 means that SELECT returns a list of View Class instances, and
 955 SLOT-VALUE becomes a valid SQL operator for use within the where
 956 clause. In the View Class case, a second equivalent select call
 957 will return the same View Class instance objects. If REFRESH is
 958 true, then existing instances are updated if necessary, and in
 959 this case you might need to extend the hook INSTANCE-REFRESHED.
 960 The default value of REFRESH is nil. SQL expressions used in the
 961 SELECT function are specified using the square bracket syntax,
 962 once this syntax has been enabled using
 963 ENABLE-SQL-READER-SYNTAX."
 964
 965   (flet ((select-objects (target-args)
 966            (and target-args
 967                 (every #'(lambda (arg)
 968                            (and (symbolp arg)
 969                                 (find-class arg nil)))
 970                        target-args))))
 971     (multiple-value-bind (target-args qualifier-args)
 972         (query-get-selections select-all-args)
 973       (if (select-objects target-args)
 974           (apply #'find-all target-args qualifier-args)
 975         (let* ((expr (apply #'make-query select-all-args))
 976                (specified-types
 977                 (mapcar #'(lambda (attrib)
 978                             (if (typep attrib 'sql-ident-attribute)
 979                                 (let ((type (slot-value attrib 'type)))
 980                                   (if type
 981                                       type
 982                                     t))
 983                               t))
 984                         (slot-value expr 'selections))))
 985           (destructuring-bind (&key (flatp nil)
 986                                     (result-types :auto)
 987                                     (field-names t)
 988                                     (database *default-database*)
 989                                &allow-other-keys)
 990               qualifier-args
 991             (query expr :flatp flatp
 992                    :result-types
 993                    ;; specifying a type for an attribute overrides result-types
 994                    (if (some #'(lambda (x) (not (eq t x))) specified-types)
 995                        specified-types
 996                      result-types)
 997                    :field-names field-names
 998                    :database database)))))))
 999