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