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 (defun fault-join-slot-raw (class object slot-def)
 709   (let* ((dbi (view-class-slot-db-info slot-def))
 710          (jc (gethash :join-class dbi)))
 711     (let ((jq (join-qualifier class object slot-def)))
 712       (when jq
 713         (select jc :where jq :flatp t :result-types nil)))))
 714
 715 ;; this works, but is inefficient requiring (+ 1 n-rows)
 716 ;; SQL queries
 717 #+ignore
 718 (defun fault-join-target-slot (class object slot-def)
 719   (let* ((res (fault-join-slot-raw class object slot-def))
 720          (dbi (view-class-slot-db-info slot-def))
 721          (target-name (gethash :target-slot dbi))
 722          (target-class (find-class target-name)))
 723     (when res
 724       (mapcar (lambda (obj)
 725                 (list
 726                  (car
 727                   (fault-join-slot-raw
 728                    target-class
 729                    obj
 730                    (find target-name (class-slots (class-of obj))
 731                          :key #'slot-definition-name)))
 732                  obj))
 733               res)
 734       #+ignore ;; this doesn't work when attempting to call slot-value
 735       (mapcar (lambda (obj)
 736                 (cons obj (slot-value obj ts))) res))))
 737
 738 (defun fault-join-target-slot (class object slot-def)
 739   (let* ((dbi (view-class-slot-db-info slot-def))
 740          (ts (gethash :target-slot dbi))
 741          (jc (gethash :join-class dbi))
 742          (tdbi (view-class-slot-db-info
 743                 (find ts (class-slots (find-class jc))
 744                       :key #'slot-definition-name)))
 745          (jq (join-qualifier class object slot-def))
 746          (key (slot-value object (gethash :home-key dbi))))
 747     (when jq
 748       (let ((res
 749              (find-all (list ts)
 750                        :inner-join (sql-expression :attribute jc)
 751                        :on (sql-operation
 752                             '==
 753                             (sql-expression :attribute (gethash :foreign-key tdbi) :table ts)
 754                             (sql-expression :attribute (gethash :home-key tdbi) :table jc))
 755                        :where jq
 756                        :result-types :auto)))
 757         (mapcar #'(lambda (i)
 758                     (let* ((instance (car i))
 759                            (jcc (make-instance jc :view-database (view-database instance))))
 760                       (setf (slot-value jcc (gethash :foreign-key dbi))
 761                         key)
 762                       (setf (slot-value jcc (gethash :home-key tdbi))
 763                         (slot-value instance (gethash :foreign-key tdbi)))
 764                       (list instance jcc)))
 765                 res)))))
 766
 767 (defun fault-join-slot (class object slot-def)
 768   (let* ((dbi (view-class-slot-db-info slot-def))
 769          (ts (gethash :target-slot dbi)))
 770     (if (and ts (gethash :set dbi))
 771         (fault-join-target-slot class object slot-def)
 772         (let ((res (fault-join-slot-raw class object slot-def)))
 773           (when res
 774             (cond
 775               ((and ts (not (gethash :set dbi)))
 776                (mapcar (lambda (obj) (slot-value obj ts)) res))
 777               ((and (not ts) (not (gethash :set dbi)))
 778                (car res))
 779               ((and (not ts) (gethash :set dbi))
 780                res)))))))
 781
 782 (defun join-qualifier (class object slot-def)
 783     (declare (ignore class))
 784     (let* ((dbi (view-class-slot-db-info slot-def))
 785            (jc (find-class (gethash :join-class dbi)))
 786            ;;(ts (gethash :target-slot dbi))
 787            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 788            (foreign-keys (gethash :foreign-key dbi))
 789            (home-keys (gethash :home-key dbi)))
 790       (when (every #'(lambda (slt)
 791                        (and (slot-boundp object slt)
 792                             (not (null (slot-value object slt)))))
 793                    (if (listp home-keys) home-keys (list home-keys)))
 794         (let ((jc
 795                (mapcar #'(lambda (hk fk)
 796                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 797                              (sql-operation '==
 798                                             (typecase fk
 799                                               (symbol
 800                                                (sql-expression
 801                                                 :attribute
 802                                                 (view-class-slot-column fksd)
 803                                                 :table (view-table jc)))
 804                                               (t fk))
 805                                             (typecase hk
 806                                               (symbol
 807                                                (slot-value object hk))
 808                                               (t
 809                                                hk)))))
 810                        (if (listp home-keys)
 811                            home-keys
 812                            (list home-keys))
 813                        (if (listp foreign-keys)
 814                            foreign-keys
 815                            (list foreign-keys)))))
 816           (when jc
 817             (if (> (length jc) 1)
 818                 (apply #'sql-and jc)
 819                 jc))))))
 820
 821 (defun find-all (view-classes
 822                  &rest args
 823                  &key all set-operation distinct from where group-by having
 824                       order-by order-by-descending offset limit refresh
 825                       flatp result-types inner-join on
 826                       (database *default-database*))
 827   "Called by SELECT to generate object query results when the
 828   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 829   (declare (ignore all set-operation group-by having offset limit inner-join on)
 830            (optimize (debug 3) (speed 1)))
 831   (remf args :from)
 832   (remf args :flatp)
 833   (remf args :additional-fields)
 834   (remf args :result-types)
 835   (labels ((table-sql-expr (table)
 836              (sql-expression :table (view-table table)))
 837            (ref-equal (ref1 ref2)
 838              (equal (sql ref1)
 839                     (sql ref2)))
 840            (tables-equal (table-a table-b)
 841              (string= (string (slot-value table-a 'name))
 842                       (string (slot-value table-b 'name))))
 843            (build-object (vals vclass selects)
 844              (let* ((class-name (class-name vclass))
 845                     (db-vals (butlast vals (- (list-length vals)
 846                                               (list-length selects))))
 847                     (*db-initializing* t)
 848                     (obj (make-instance class-name :view-database database)))
 849                ;; use refresh keyword here
 850                (setf obj (get-slot-values-from-view obj (mapcar #'car selects)
 851                                                     db-vals))
 852                (when refresh (instance-refreshed obj))
 853                obj))
 854            (build-objects (vals sclasses sels)
 855              (let ((objects (mapcar #'(lambda (sclass sel)
 856                                         (prog1 (build-object vals sclass sel)
 857                                           (setf vals (nthcdr (list-length sel)
 858                                                              vals))))
 859                                     sclasses sels)))
 860                (if (and flatp (= (length sclasses) 1))
 861                    (car objects)
 862                    objects))))
 863     (let* ((*db-deserializing* t)
 864            (*default-database* (or database
 865                                    (error 'clsql-base::clsql-no-database-error :database nil)))
 866            (sclasses (mapcar #'find-class view-classes))
 867            (sels (mapcar #'generate-selection-list sclasses))
 868            (fullsels (apply #'append sels))
 869            (sel-tables (collect-table-refs where))
 870            (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
 871                                               sel-tables)
 872                                       :test #'tables-equal))
 873            (res nil))
 874         (dolist (ob (listify order-by))
 875           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 876                                      :test #'ref-equal)))
 877             (setq fullsels
 878                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 879                                            (listify ob))))))
 880         (dolist (ob (listify order-by-descending))
 881           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 882                                      :test #'ref-equal)))
 883             (setq fullsels
 884                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 885                                            (listify ob))))))
 886         (dolist (ob (listify distinct))
 887           (when (and (typep ob 'sql-ident)
 888                      (not (member ob (mapcar #'cdr fullsels)
 889                                   :test #'ref-equal)))
 890             (setq fullsels
 891                   (append fullsels (mapcar #'(lambda (att) (cons nil att))
 892                                            (listify ob))))))
 893         (setq res
 894               (apply #'select
 895                      (append (mapcar #'cdr fullsels)
 896                              (cons :from
 897                                    (list (append (when from (listify from))
 898                                                  (listify tables))))
 899                              (list :result-types result-types)
 900                              args)))
 901         (mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
 902
 903 (defmethod instance-refreshed ((instance standard-db-object)))
 904
 905 (defun select (&rest select-all-args)
 906    "The function SELECT selects data from DATABASE, which has a
 907 default value of *DEFAULT-DATABASE*, given the constraints
 908 specified by the rest of the ARGS. It returns a list of objects
 909 as specified by SELECTIONS. By default, the objects will each be
 910 represented as lists of attribute values. The argument SELECTIONS
 911 consists either of database identifiers, type-modified database
 912 identifiers or literal strings. A type-modifed database
 913 identifier is an expression such as [foo :string] which means
 914 that the values in column foo are returned as Lisp strings.  The
 915 FLATP argument, which has a default value of nil, specifies if
 916 full bracketed results should be returned for each matched
 917 entry. If FLATP is nil, the results are returned as a list of
 918 lists. If FLATP is t, the results are returned as elements of a
 919 list, only if there is only one result per row. The arguments
 920 ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
 921 ORDER-by have the same function as the equivalent SQL expression.
 922 The SELECT function is common across both the functional and
 923 object-oriented SQL interfaces. If selections refers to View
 924 Classes then the select operation becomes object-oriented. This
 925 means that SELECT returns a list of View Class instances, and
 926 SLOT-VALUE becomes a valid SQL operator for use within the where
 927 clause. In the View Class case, a second equivalent select call
 928 will return the same View Class instance objects. If REFRESH is
 929 true, then existing instances are updated if necessary, and in
 930 this case you might need to extend the hook INSTANCE-REFRESHED.
 931 The default value of REFRESH is nil. SQL expressions used in the
 932 SELECT function are specified using the square bracket syntax,
 933 once this syntax has been enabled using
 934 ENABLE-SQL-READER-SYNTAX."
 935
 936   (flet ((select-objects (target-args)
 937            (and target-args
 938                 (every #'(lambda (arg)
 939                            (and (symbolp arg)
 940                                 (find-class arg nil)))
 941                        target-args))))
 942     (multiple-value-bind (target-args qualifier-args)
 943         (query-get-selections select-all-args)
 944       (if (select-objects target-args)
 945           (apply #'find-all target-args qualifier-args)
 946         (let* ((expr (apply #'make-query select-all-args))
 947                (specified-types
 948                 (mapcar #'(lambda (attrib)
 949                             (if (typep attrib 'sql-ident-attribute)
 950                                 (let ((type (slot-value attrib 'type)))
 951                                   (if type
 952                                       type
 953                                     t))
 954                               t))
 955                         (slot-value expr 'selections))))
 956           (destructuring-bind (&key (flatp nil)
 957                                     (result-types :auto)
 958                                     (field-names t)
 959                                     (database *default-database*)
 960                                &allow-other-keys)
 961               qualifier-args
 962             (query expr :flatp flatp
 963                    :result-types
 964                    ;; specifying a type for an attribute overrides result-types
 965                    (if (some #'(lambda (x) (not (eq t x))) specified-types)
 966                        specified-types
 967                      result-types)
 968                    :field-names field-names
 969                    :database database)))))))
 970