sql/objects.lisp

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