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