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-sys)
  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-sys::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-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 (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 (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 (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 (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       (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 (symbol-name-default-case "NIL"))
 671       (intern (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
 810 :retrieval :immediate."
 811   (when objects
 812     (unless class-name
 813       (setq class-name (class-name (class-of (first objects)))))
 814     (let* ((class (find-class class-name))
 815            (deferred-joins (generate-retrieval-joins-list class :deferred)))
 816       (cond
 817         (deferred-joins
 818             (mapcar
 819              #'(lambda (slotdef)
 820                  ;; FIXME: Rather than simply reading the values for each
 821                  ;; object, to meet CommonSQL spec need to generate a single
 822                  ;; query to read values for all objects, up to max-len count
 823                  (mapcar
 824                   #'(lambda (object)
 825                       (slot-value object (slot-definition-name slotdef)))
 826                   objects))
 827              deferred-joins))
 828         (t
 829          (warn "Class ~A does not have any deferred join slots." class-name)))
 830       )))
 831
 832
 833 (defun fault-join-slot-raw (class object slot-def)
 834   (let* ((dbi (view-class-slot-db-info slot-def))
 835          (jc (gethash :join-class dbi)))
 836     (let ((jq (join-qualifier class object slot-def)))
 837       (when jq
 838         (select jc :where jq :flatp t :result-types nil)))))
 839
 840 (defun fault-join-slot (class object slot-def)
 841   (let* ((dbi (view-class-slot-db-info slot-def))
 842          (ts (gethash :target-slot dbi)))
 843     (if (and ts (gethash :set dbi))
 844         (fault-join-target-slot class object slot-def)
 845         (let ((res (fault-join-slot-raw class object slot-def)))
 846           (when res
 847             (cond
 848               ((and ts (not (gethash :set dbi)))
 849                (mapcar (lambda (obj) (slot-value obj ts)) res))
 850               ((and (not ts) (not (gethash :set dbi)))
 851                (car res))
 852               ((and (not ts) (gethash :set dbi))
 853                res)))))))
 854
 855 (defun join-qualifier (class object slot-def)
 856     (declare (ignore class))
 857     (let* ((dbi (view-class-slot-db-info slot-def))
 858            (jc (find-class (gethash :join-class dbi)))
 859            ;;(ts (gethash :target-slot dbi))
 860            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 861            (foreign-keys (gethash :foreign-key dbi))
 862            (home-keys (gethash :home-key dbi)))
 863       (when (every #'(lambda (slt)
 864                        (and (slot-boundp object slt)
 865                             (not (null (slot-value object slt)))))
 866                    (if (listp home-keys) home-keys (list home-keys)))
 867         (let ((jc
 868                (mapcar #'(lambda (hk fk)
 869                            (let ((fksd (slotdef-for-slot-with-class fk jc)))
 870                              (sql-operation '==
 871                                             (typecase fk
 872                                               (symbol
 873                                                (sql-expression
 874                                                 :attribute
 875                                                 (view-class-slot-column fksd)
 876                                                 :table (view-table jc)))
 877                                               (t fk))
 878                                             (typecase hk
 879                                               (symbol
 880                                                (slot-value object hk))
 881                                               (t
 882                                                hk)))))
 883                        (if (listp home-keys)
 884                            home-keys
 885                            (list home-keys))
 886                        (if (listp foreign-keys)
 887                            foreign-keys
 888                            (list foreign-keys)))))
 889           (when jc
 890             (if (> (length jc) 1)
 891                 (apply #'sql-and jc)
 892                 jc))))))
 893
 894 ;; FIXME: add retrieval immediate for efficiency
 895 ;; For example, for (select 'employee-address) in test suite =>
 896 ;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
 897
 898 (defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp)
 899   "Used by find-all to build objects."
 900   (labels ((build-object (vals vclass jclasses selects immediate-selects)
 901              (let* ((class-name (class-name vclass))
 902                     (db-vals (butlast vals (- (list-length vals)
 903                                               (list-length selects))))
 904                     (join-vals (subseq vals (list-length selects)))
 905                     (obj (make-instance class-name :view-database database))
 906                     (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
 907                                    jclasses)))
 908                ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals)
 909                ;; use refresh keyword here
 910                (setf obj (get-slot-values-from-view obj (mapcar #'car selects)
 911                                                     db-vals))
 912                (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals))
 913                      joins)
 914                (mapc
 915                 #'(lambda (jc) (let ((slot (find (class-name (class-of jc)) (class-slots vclass)
 916                                                  :key #'(lambda (slot) (when (and (eq :join (view-class-slot-db-kind slot))
 917                                                                                   (eq (slot-definition-name slot)
 918                                                                                       (gethash :join-class (view-class-slot-db-info slot))))
 919                                                                          (slot-definition-name slot))))))
 920                                  (when slot
 921                                    (setf (slot-value obj (slot-definition-name slot)) jc))))
 922
 923                 joins)
 924                (when refresh (instance-refreshed obj))
 925                obj)))
 926     (let ((objects (mapcar #'(lambda (sclass jclass sel immediate-join)
 927                                (prog1 (build-object vals sclass jclass sel immediate-join)
 928                                  (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
 929                                                     vals))))
 930                            sclasses immediate-join-classes sels immediate-joins)))
 931       (if (and flatp (= (length sclasses) 1))
 932           (car objects)
 933           objects))))
 934
 935 (defun find-all (view-classes
 936                  &rest args
 937                  &key all set-operation distinct from where group-by having
 938                       order-by order-by-descending offset limit refresh
 939                       flatp result-types inner-join on
 940                       (database *default-database*))
 941   "Called by SELECT to generate object query results when the
 942   View Classes VIEW-CLASSES are passed as arguments to SELECT."
 943   (declare (ignore all set-operation group-by having offset limit inner-join on)
 944            (optimize (debug 3) (speed 1)))
 945   (labels ((ref-equal (ref1 ref2)
 946              (equal (sql ref1)
 947                     (sql ref2)))
 948            (table-sql-expr (table)
 949              (sql-expression :table (view-table table)))
 950            (tables-equal (table-a table-b)
 951              (when (and table-a table-b)
 952                (string= (string (slot-value table-a 'name))
 953                         (string (slot-value table-b 'name))))))
 954     (remf args :from)
 955     (remf args :where)
 956     (remf args :flatp)
 957     (remf args :additional-fields)
 958     (remf args :result-types)
 959     (let* ((*db-deserializing* t)
 960            (sclasses (mapcar #'find-class view-classes))
 961            (immediate-join-slots (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
 962            (immediate-join-classes (mapcar #'(lambda (jcs)
 963                                                (mapcar #'(lambda (slotdef)
 964                                                            (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
 965                                                        jcs))
 966                                            immediate-join-slots))
 967            (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
 968            (sels (mapcar #'generate-selection-list sclasses))
 969            (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
 970            (sel-tables (collect-table-refs where))
 971            (tables (remove-if #'null
 972                               (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
 973                                                          (mapcar #'(lambda (jcs)
 974                                                                      (mapcan #'(lambda (jc)
 975                                                                                  (when jc (table-sql-expr jc)))
 976                                                                              jcs))
 977                                                                  immediate-join-classes)
 978                                                          sel-tables)
 979                                                  :test #'tables-equal))))
 980       (dolist (ob (listify order-by))
 981         (when (and ob (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       (dolist (ob (listify order-by-descending))
 987         (when (and ob (not (member ob (mapcar #'cdr fullsels)
 988                                    :test #'ref-equal)))
 989           (setq fullsels
 990                 (append fullsels (mapcar #'(lambda (att) (cons nil att))
 991                                          (listify ob))))))
 992       (dolist (ob (listify distinct))
 993         (when (and (typep ob 'sql-ident)
 994                    (not (member ob (mapcar #'cdr fullsels)
 995                                 :test #'ref-equal)))
 996           (setq fullsels
 997               (append fullsels (mapcar #'(lambda (att) (cons nil att))
 998                                        (listify ob))))))
 999       (mapcar #'(lambda (vclass jclasses jslots)
1000                   (when jclasses
1001                     (mapcar
1002                      #'(lambda (jclass jslot)
1003                          (let ((dbi (view-class-slot-db-info jslot)))
1004                            (setq where
1005                                  (append
1006                                   (list (sql-operation '==
1007                                                       (sql-expression
1008                                                        :attribute (gethash :foreign-key dbi)
1009                                                        :table (view-table jclass))
1010                                                       (sql-expression
1011                                                        :attribute (gethash :home-key dbi)
1012                                                        :table (view-table vclass))))
1013                                   (when where (listify where))))))
1014                      jclasses jslots)))
1015               sclasses immediate-join-classes immediate-join-slots)
1016       (let* ((rows (apply #'select
1017                           (append (mapcar #'cdr fullsels)
1018                                   (cons :from
1019                                         (list (append (when from (listify from))
1020                                                       (listify tables))))
1021                                   (list :result-types result-types)
1022                                   (when where (list :where where))
1023                                   args)))
1024              (objects (mapcar
1025                        #'(lambda (r)
1026                            (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp))
1027                        rows)))
1028         objects))))
1029
1030 (defmethod instance-refreshed ((instance standard-db-object)))
1031
1032 (defun select (&rest select-all-args)
1033    "The function SELECT selects data from DATABASE, which has a
1034 default value of *DEFAULT-DATABASE*, given the constraints
1035 specified by the rest of the ARGS. It returns a list of objects
1036 as specified by SELECTIONS. By default, the objects will each be
1037 represented as lists of attribute values. The argument SELECTIONS
1038 consists either of database identifiers, type-modified database
1039 identifiers or literal strings. A type-modifed database
1040 identifier is an expression such as [foo :string] which means
1041 that the values in column foo are returned as Lisp strings.  The
1042 FLATP argument, which has a default value of nil, specifies if
1043 full bracketed results should be returned for each matched
1044 entry. If FLATP is nil, the results are returned as a list of
1045 lists. If FLATP is t, the results are returned as elements of a
1046 list, only if there is only one result per row. The arguments
1047 ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and
1048 ORDER-by have the same function as the equivalent SQL expression.
1049 The SELECT function is common across both the functional and
1050 object-oriented SQL interfaces. If selections refers to View
1051 Classes then the select operation becomes object-oriented. This
1052 means that SELECT returns a list of View Class instances, and
1053 SLOT-VALUE becomes a valid SQL operator for use within the where
1054 clause. In the View Class case, a second equivalent select call
1055 will return the same View Class instance objects. If REFRESH is
1056 true, then existing instances are updated if necessary, and in
1057 this case you might need to extend the hook INSTANCE-REFRESHED.
1058 The default value of REFRESH is nil. SQL expressions used in the
1059 SELECT function are specified using the square bracket syntax,
1060 once this syntax has been enabled using
1061 ENABLE-SQL-READER-SYNTAX."
1062
1063   (flet ((select-objects (target-args)
1064            (and target-args
1065                 (every #'(lambda (arg)
1066                            (and (symbolp arg)
1067                                 (find-class arg nil)))
1068                        target-args))))
1069     (multiple-value-bind (target-args qualifier-args)
1070         (query-get-selections select-all-args)
1071         (cond
1072           ((select-objects target-args)
1073            (let ((caching (getf qualifier-args :caching))
1074                  (refresh (getf qualifier-args :refresh))
1075                  (database (or (getf qualifier-args :database) *default-database*)))
1076              (remf qualifier-args :caching)
1077              (remf qualifier-args :refresh)
1078              (cond
1079                ((null caching)
1080                 (apply #'find-all target-args qualifier-args))
1081                (t
1082                 (let ((cached (records-cache-results target-args qualifier-args database)))
1083                   (cond
1084                     ((and cached (not refresh))
1085                      cached)
1086                     ((and cached refresh)
1087                      (update-cached-results target-args qualifier-args database))
1088                     (t
1089                      (let ((results (apply #'find-all target-args qualifier-args)))
1090                        (setf (records-cache-results target-args qualifier-args database) results)
1091                        results))))))))
1092           (t
1093            (let* ((expr (apply #'make-query select-all-args))
1094                   (specified-types
1095                    (mapcar #'(lambda (attrib)
1096                                (if (typep attrib 'sql-ident-attribute)
1097                                    (let ((type (slot-value attrib 'type)))
1098                                      (if type
1099                                          type
1100                                          t))
1101                                    t))
1102                            (slot-value expr 'selections))))
1103              (destructuring-bind (&key (flatp nil)
1104                                        (result-types :auto)
1105                                        (field-names t)
1106                                        (database *default-database*)
1107                                        &allow-other-keys)
1108                  qualifier-args
1109                (query expr :flatp flatp
1110                       :result-types
1111                       ;; specifying a type for an attribute overrides result-types
1112                       (if (some #'(lambda (x) (not (eq t x))) specified-types)
1113                           specified-types
1114                           result-types)
1115                       :field-names field-names
1116                       :database database))))))))
1117
1118 (defun compute-records-cache-key (targets qualifiers)
1119   (list targets
1120         (do ((args *select-arguments* (cdr args))
1121              (results nil))
1122             ((null args) results)
1123           (let* ((arg (car args))
1124                  (value (getf qualifiers arg)))
1125             (when value
1126               (push (list arg
1127                           (typecase value
1128                             (%sql-expression (sql value))
1129                             (t value)))
1130                     results))))))
1131
1132 (defun records-cache-results (targets qualifiers database)
1133   (when (record-caches database)
1134     (gethash (compute-records-cache-key targets qualifiers) (record-caches database))))
1135
1136 (defun (setf records-cache-results) (results targets qualifiers database)
1137   (unless (record-caches database)
1138     (setf (record-caches database)
1139           (make-hash-table :test 'equal
1140                            #+allegro :values #+allegro :weak)))
1141   (setf (gethash (compute-records-cache-key targets qualifiers)
1142                  (record-caches database)) results)
1143   results)
1144
1145 (defun update-cached-results (targets qualifiers database)
1146   ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached
1147   ;; for now, dump cache entry and perform fresh search
1148   (let ((res (apply #'find-all targets qualifiers)))
1149     (setf (gethash (compute-records-cache-key targets qualifiers)
1150                    (record-caches database)) res)
1151     res))
1152