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