sql/new-objects.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id: objects.lisp 8906 2004-04-09 12:41:07Z kevin $
   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   ((stored :db-kind :virtual
  20            :initarg :stored
  21            :initform nil))
  22   (:metaclass standard-db-class)
  23   (:documentation "Superclass for all CLSQL View Classes."))
  24
  25 (defvar *db-deserializing* nil)
  26 (defvar *db-initializing* nil)
  27
  28 (defmethod slot-value-using-class ((class standard-db-class) instance slot-def)
  29   (declare (optimize (speed 3)))
  30   (unless *db-deserializing*
  31     (let* ((slot-name (%svuc-slot-name slot-def))
  32            (slot-object (%svuc-slot-object slot-def class))
  33            (slot-kind (view-class-slot-db-kind slot-object)))
  34       (when (and (eql slot-kind :join)
  35                  (not (slot-boundp instance slot-name)))
  36         (let ((*db-deserializing* t))
  37           (setf (slot-value instance slot-name)
  38                 (fault-join-slot class instance slot-def))))))
  39     (call-next-method))
  40
  41 (defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def)
  42   (declare (ignore new-value))
  43   (let* ((slot-name (slot-definition-name slot-def))
  44          (slot-kind (view-class-slot-db-kind slot-def))
  45          (no-update? (or (eql slot-kind :virtual)
  46                          *db-initializing*
  47                          *db-deserializing*)))
  48     (call-next-method)
  49     (unless no-update?
  50       (update-record-from-slot instance slot-name))))
  51
  52 (defmethod initialize-instance :around ((object standard-db-object)
  53                                         &rest all-keys &key &allow-other-keys)
  54   (declare (ignore all-keys))
  55   (let ((*db-initializing* t))
  56     (call-next-method)
  57     (unless *db-deserializing*
  58       #+nil (created-object object)
  59       (update-records-from-instance object))))
  60
  61 (defun sequence-from-class (view-class-name)
  62   (sql-escape
  63    (concatenate
  64     'string
  65     (symbol-name (view-table (find-class view-class-name)))
  66     "-SEQ")))
  67
  68 (defun create-sequence-from-class (view-class-name
  69                                    &key (database *default-database*))
  70   (create-sequence (sequence-from-class view-class-name) :database database))
  71
  72 (defun drop-sequence-from-class (view-class-name
  73                                  &key (if-does-not-exist :error)
  74                                  (database *default-database*))
  75   (drop-sequence (sequence-from-class view-class-name)
  76                  :if-does-not-exist if-does-not-exist
  77                  :database database))
  78
  79 ;;
  80 ;; Build the database tables required to store the given view class
  81 ;;
  82
  83 (defmethod database-pkey-constraint ((class standard-db-class) database)
  84   (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class))))
  85     (when keylist
  86       (format nil "CONSTRAINT ~APK PRIMARY KEY~A"
  87               (database-output-sql (view-table class) database)
  88               (database-output-sql keylist database)))))
  89
  90
  91 (defun create-view-from-class (view-class-name
  92                                &key (database *default-database*))
  93   "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
  94 the view. The argument DATABASE has a default value of
  95 *DEFAULT-DATABASE*."
  96   (let ((tclass (find-class view-class-name)))
  97     (if tclass
  98         (let ((*default-database* database))
  99           (%install-class tclass database))
 100         (error "Class ~s not found." view-class-name)))
 101   (values))
 102
 103 (defmethod %install-class ((self standard-db-class) database &aux schemadef)
 104   (dolist (slotdef (ordered-class-slots self))
 105     (let ((res (database-generate-column-definition (class-name self)
 106                                                     slotdef database)))
 107       (when res
 108         (push res schemadef))))
 109   (unless schemadef
 110     (error "Class ~s has no :base slots" self))
 111   (create-table (sql-expression :table (view-table self)) schemadef
 112                 :database database
 113                 :constraints (database-pkey-constraint self database))
 114   (push self (database-view-classes database))
 115   t)
 116
 117 ;;
 118 ;; Drop the tables which store the given view class
 119 ;;
 120
 121 #.(locally-enable-sql-reader-syntax)
 122
 123 (defun drop-view-from-class (view-class-name &key (database *default-database*))
 124   "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
 125 which defines that view. The argument DATABASE has a default value of
 126 *DEFAULT-DATABASE*."
 127   (let ((tclass (find-class view-class-name)))
 128     (if tclass
 129         (let ((*default-database* database))
 130           (%uninstall-class tclass))
 131         (error "Class ~s not found." view-class-name)))
 132   (values))
 133
 134 #.(restore-sql-reader-syntax-state)
 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 'standard-db-object)
 150                           (database *default-database*))
 151   "Returns a list of View Classes connected to a given DATABASE which
 152 defaults to *DEFAULT-DATABASE*."
 153   (declare (ignore root-class))
 154   (remove-if #'(lambda (c) (not (funcall test c)))
 155              (database-view-classes database)))
 156
 157 ;;
 158 ;; Define a new view class
 159 ;;
 160
 161 (defmacro def-view-class (class supers slots &rest options)
 162   "Extends the syntax of defclass to allow special slots to be mapped
 163 onto the attributes of database views. The macro DEF-VIEW-CLASS
 164 creates a class called CLASS which maps onto a database view. Such a
 165 class is called a View Class. The macro DEF-VIEW-CLASS extends the
 166 syntax of DEFCLASS to allow special base slots to be mapped onto the
 167 attributes of database views (presently single tables). When a select
 168 query that names a View Class is submitted, then the corresponding
 169 database view is queried, and the slots in the resulting View Class
 170 instances are filled with attribute values from the database. If
 171 SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
 172 superclass of the newly-defined View Class."
 173   `(progn
 174      (defclass ,class ,supers ,slots ,@options
 175                (:metaclass standard-db-class))
 176      (finalize-inheritance (find-class ',class))))
 177
 178 (defun keyslots-for-class (class)
 179   (slot-value class 'key-slots))
 180
 181 (defun key-qualifier-for-instance (obj &key (database *default-database*))
 182   (let ((tb (view-table (class-of obj))))
 183     (flet ((qfk (k)
 184              (sql-operation '==
 185                             (sql-expression :attribute
 186                                             (view-class-slot-column k)
 187                                             :table tb)
 188                             (db-value-from-slot
 189                              k
 190                              (slot-value obj (slot-definition-name k))
 191                              database))))
 192       (let* ((keys (keyslots-for-class (class-of obj)))
 193              (keyxprs (mapcar #'qfk (reverse keys))))
 194         (cond
 195           ((= (length keyxprs) 0) nil)
 196           ((= (length keyxprs) 1) (car keyxprs))
 197           ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
 198
 199 ;;
 200 ;; Function used by 'generate-selection-list'
 201 ;;
 202
 203 (defun generate-attribute-reference (vclass slotdef)
 204   (cond
 205    ((eq (view-class-slot-db-kind slotdef) :base)
 206     (sql-expression :attribute (view-class-slot-column slotdef)
 207                     :table (view-table vclass)))
 208    ((eq (view-class-slot-db-kind slotdef) :key)
 209     (sql-expression :attribute (view-class-slot-column slotdef)
 210                     :table (view-table vclass)))
 211    (t nil)))
 212
 213 ;;
 214 ;; Function used by 'find-all'
 215 ;;
 216
 217 (defun generate-selection-list (vclass)
 218   (let ((sels nil))
 219     (dolist (slotdef (ordered-class-slots vclass))
 220       (let ((res (generate-attribute-reference vclass slotdef)))
 221         (when res
 222           (push (cons slotdef res) sels))))
 223     (if sels
 224         sels
 225         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 226
 227 ;;
 228 ;; Used by 'create-view-from-class'
 229 ;;
 230
 231
 232 (defmethod database-generate-column-definition (class slotdef database)
 233   (declare (ignore database class))
 234   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
 235     (let ((cdef
 236            (list (sql-expression :attribute (view-class-slot-column slotdef))
 237                  (slot-type slotdef))))
 238       (let ((const (view-class-slot-db-constraints slotdef)))
 239         (when const
 240           (setq cdef (append cdef (list const)))))
 241       cdef)))
 242
 243 ;;
 244 ;; Called by 'get-slot-values-from-view'
 245 ;;
 246
 247 (declaim (inline delistify))
 248 (defun delistify (list)
 249   (if (listp list)
 250       (car list)
 251       list))
 252
 253 (defun slot-type (slotdef)
 254   (specified-type slotdef))
 255
 256 (defvar *update-context* nil)
 257
 258 (defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
 259   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 260   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 261          (slot-name   (slot-definition-name slotdef))
 262          (slot-type   (slot-type slotdef))
 263          (*update-context* (cons (type-of instance) slot-name)))
 264     (cond ((and value (null slot-reader))
 265            (setf (slot-value instance slot-name)
 266              (read-sql-value value (delistify slot-type)
 267                              *default-database*)))
 268           ((null value)
 269            (update-slot-with-null instance slot-name slotdef))
 270           ((typep slot-reader 'string)
 271            (setf (slot-value instance slot-name)
 272                  (format nil slot-reader value)))
 273           ((typep slot-reader 'function)
 274            (setf (slot-value instance slot-name)
 275                  (apply slot-reader (list value))))
 276           (t
 277            (error "Slot reader is of an unusual type.")))))
 278
 279 (defmethod key-value-from-db (slotdef value database)
 280   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
 281   (let ((slot-reader (view-class-slot-db-reader slotdef))
 282         (slot-type (slot-type slotdef)))
 283     (cond ((and value (null slot-reader))
 284            (read-sql-value value (delistify slot-type) database))
 285           ((null value)
 286            nil)
 287           ((typep slot-reader 'string)
 288            (format nil slot-reader value))
 289           ((typep slot-reader 'function)
 290            (apply slot-reader (list value)))
 291           (t
 292            (error "Slot reader is of an unusual type.")))))
 293
 294 (defun db-value-from-slot (slotdef val database)
 295   (let ((dbwriter (view-class-slot-db-writer slotdef))
 296         (dbtype (slot-type slotdef)))
 297     (typecase dbwriter
 298       (string (format nil dbwriter val))
 299       (function (apply dbwriter (list val)))
 300       (t
 301        (typecase dbtype
 302          (cons
 303           (database-output-sql-as-type (car dbtype) val database))
 304          (t
 305           (database-output-sql-as-type dbtype val database)))))))
 306
 307 (defun check-slot-type (slotdef val)
 308   (let* ((slot-type (slot-type slotdef))
 309          (basetype (if (listp slot-type) (car slot-type) slot-type)))
 310     (when (and slot-type val)
 311       (unless (typep val basetype)
 312         (error 'clsql-type-error
 313                :slotname (slot-definition-name slotdef)
 314                :typespec slot-type
 315                :value val)))))
 316
 317 ;;
 318 ;; Called by find-all
 319 ;;
 320
 321 (defmethod get-slot-values-from-view (obj slotdeflist values)
 322     (flet ((update-slot (slot-def values)
 323              (update-slot-from-db obj slot-def values)))
 324       (mapc #'update-slot slotdeflist values)
 325       obj))
 326
 327 (defun synchronize-keys (src srckey dest destkey)
 328   (let ((skeys (if (listp srckey) srckey (list srckey)))
 329         (dkeys (if (listp destkey) destkey (list destkey))))
 330     (mapcar #'(lambda (sk dk)
 331                 (setf (slot-value dest dk)
 332                       (typecase sk
 333                         (symbol
 334                          (slot-value src sk))
 335                         (t sk))))
 336             skeys dkeys)))
 337
 338 (defun desynchronize-keys (dest destkey)
 339   (let ((dkeys (if (listp destkey) destkey (list destkey))))
 340     (mapcar #'(lambda (dk)
 341                 (setf (slot-value dest dk) nil))
 342             dkeys)))
 343
 344 (defmethod add-to-relation ((target standard-db-object)
 345                             slot-name
 346                             (value standard-db-object))
 347   (let* ((objclass (class-of target))
 348          (sdef (or (slotdef-for-slot-with-class slot-name objclass)
 349                    (error "~s is not an known slot on ~s" slot-name target)))
 350          (dbinfo (view-class-slot-db-info sdef))
 351          (join-class (gethash :join-class dbinfo))
 352          (homekey (gethash :home-key dbinfo))
 353          (foreignkey (gethash :foreign-key dbinfo))
 354          (to-many (gethash :set dbinfo)))
 355     (unless (equal (type-of value) join-class)
 356       (error 'clsql-type-error :slotname slot-name :typespec join-class
 357              :value value))
 358     (when (gethash :target-slot dbinfo)
 359       (error "add-to-relation does not work with many-to-many relations yet."))
 360     (if to-many
 361         (progn
 362           (synchronize-keys target homekey value foreignkey)
 363           (if (slot-boundp target slot-name)
 364               (unless (member value (slot-value target slot-name))
 365                 (setf (slot-value target slot-name)
 366                       (append (slot-value target slot-name) (list value))))
 367               (setf (slot-value target slot-name) (list value))))
 368         (progn
 369           (synchronize-keys value foreignkey target homekey)
 370           (setf (slot-value target slot-name) value)))))
 371
 372 (defmethod remove-from-relation ((target standard-db-object)
 373                             slot-name (value standard-db-object))
 374   (let* ((objclass (class-of target))
 375          (sdef (slotdef-for-slot-with-class slot-name objclass))
 376          (dbinfo (view-class-slot-db-info sdef))
 377          (homekey (gethash :home-key dbinfo))
 378          (foreignkey (gethash :foreign-key dbinfo))
 379          (to-many (gethash :set dbinfo)))
 380     (when (gethash :target-slot dbinfo)
 381       (error "remove-relation does not work with many-to-many relations yet."))
 382     (if to-many
 383         (progn
 384           (desynchronize-keys value foreignkey)
 385           (if (slot-boundp target slot-name)
 386               (setf (slot-value target slot-name)
 387                     (remove value
 388                             (slot-value target slot-name)
 389                             :test #'equal))))
 390         (progn
 391           (desynchronize-keys target homekey)
 392           (setf (slot-value target slot-name)
 393                 nil)))))
 394
 395 (defgeneric update-record-from-slot (object slot &key database)
 396   (:documentation
 397    "The generic function UPDATE-RECORD-FROM-SLOT updates an individual
 398 data item in the column represented by SLOT. The DATABASE is only used
 399 if OBJECT is not yet associated with any database, in which case a
 400 record is created in DATABASE. Only SLOT is initialized in this case;
 401 other columns in the underlying database receive default values. The
 402 argument SLOT is the CLOS slot name; the corresponding column names
 403 are derived from the View Class definition."))
 404
 405 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 406                                     (database *default-database*))
 407   #+nil (odcl:updated-object obj)
 408   (let* ((vct (view-table (class-of obj)))
 409          (stored? (slot-value obj 'stored))
 410          (sd (slotdef-for-slot-with-class slot (class-of obj))))
 411     (check-slot-type sd (slot-value obj slot))
 412     (let* ((att (view-class-slot-column sd))
 413            (val (db-value-from-slot sd (slot-value obj slot) database)))
 414       (cond ((and vct sd stored?)
 415              (update-records (sql-expression :table vct)
 416                              :attributes (list (sql-expression :attribute att))
 417                              :values (list val)
 418                              :where (key-qualifier-for-instance obj :database database)
 419                              :database database))
 420             ((not stored?)
 421              t)
 422             (t
 423              (error "Unable to update record")))))
 424   t)
 425
 426 (defgeneric update-record-from-slots (object slots &key database)
 427   (:documentation
 428    "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the
 429 columns represented by SLOTS. The DATABASE is only used if OBJECT is
 430 not yet associated with any database, in which case a record is
 431 created in DATABASE. Only slots are initialized in this case; other
 432 columns in the underlying database receive default values. The
 433 argument SLOTS contains the CLOS slot names; the corresponding column
 434 names are derived from the view class definition."))
 435
 436 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
 437                                      (database *default-database*))
 438   (let* ((vct (view-table (class-of obj)))
 439          (stored? (slot-value obj 'stored))
 440          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
 441          (avps (mapcar #'(lambda (s)
 442                            (let ((val (slot-value
 443                                        obj (slot-definition-name s))))
 444                              (check-slot-type s val)
 445                              (list (sql-expression
 446                                     :attribute (view-class-slot-column s))
 447                                    (db-value-from-slot s val database))))
 448                        sds)))
 449     (cond ((and avps stored?)
 450            (update-records (sql-expression :table vct)
 451                            :av-pairs avps
 452                            :where (key-qualifier-for-instance
 453                                    obj :database database)
 454                            :database database))
 455           (avps
 456            (insert-records :into (sql-expression :table vct)
 457                            :av-pairs avps
 458                            :database database)
 459            (setf (slot-value obj 'stored) t))
 460           (t
 461            (error "Unable to update records"))))
 462   t)
 463
 464 (defgeneric update-records-from-instance (object &key database)
 465   (:documentation
 466    "Using an instance of a view class, update the database table that
 467 stores its instance data. If the instance is already associated with a
 468 database, that database is used, and database is ignored. If instance
 469 is not yet associated with a database, a record is created for
 470 instance in the appropriate table of database and the instance becomes
 471 associated with that database."))
 472
 473 (defmethod update-records-from-instance ((obj standard-db-object)
 474                                          &key (database *default-database*))
 475   (labels ((slot-storedp (slot)
 476              (and (member (view-class-slot-db-kind slot) '(:base :key))
 477                   (slot-boundp obj (slot-definition-name slot))))
 478            (slot-value-list (slot)
 479              (let ((value (slot-value obj (slot-definition-name slot))))
 480                (check-slot-type slot value)
 481                (list (sql-expression :attribute (view-class-slot-column slot))
 482                      (db-value-from-slot slot value database)))))
 483     (let* ((view-class (class-of obj))
 484            (view-class-table (view-table view-class))
 485            (slots (remove-if-not #'slot-storedp (class-slots view-class)))
 486            (record-values (mapcar #'slot-value-list slots)))
 487       (unless record-values
 488         (error "No settable slots."))
 489       (if (slot-value obj 'stored)
 490           (update-records (sql-expression :table view-class-table)
 491                           :av-pairs record-values
 492                           :where (key-qualifier-for-instance
 493                                   obj :database database)
 494                           :database database)
 495           (progn
 496             (insert-records :into (sql-expression :table view-class-table)
 497                             :av-pairs record-values
 498                             :database database)
 499             (setf (slot-value obj 'stored) t)))))
 500   t)
 501
 502  (setf (symbol-function (intern (symbol-name '#:store-instance)))
 503    (symbol-function 'update-records-from-instance))
 504
 505 (defmethod delete-instance-records ((object standard-db-object))
 506   (let ((vt (sql-expression :table (view-table (class-of object))))
 507         (qualifier (key-qualifier-for-instance object :database *default-database*)))
 508     (delete-records :from vt :where qualifier :database *default-database*)
 509     #+ignore (odcl::deleted-object object)))
 510
 511 (defgeneric update-instance-from-db (instance)
 512   (:documentation
 513    "Updates the values in the slots of the View Class instance
 514 INSTANCE using the data in the database DATABASE which defaults to the
 515 database that INSTANCE is associated with, or the value of
 516 *DEFAULT-DATABASE*."))
 517
 518 (defmethod update-instance-from-db ((object standard-db-object))
 519   (let* ((view-class (find-class (class-name (class-of object))))
 520          (view-table (sql-expression :table (view-table view-class)))
 521          (view-qual  (key-qualifier-for-instance object :database *default-database*))
 522          (sels       (generate-selection-list view-class))
 523          (res (apply #'select (append (mapcar #'cdr sels) (list :from  view-table
 524                                                                 :where view-qual)))))
 525     (when res
 526       (get-slot-values-from-view object (mapcar #'car sels) (car res))
 527       res)))
 528
 529
 530 (defgeneric database-null-value (type)
 531   (:documentation "Return an expression of type TYPE which SQL NULL values
 532 will be converted into."))
 533
 534 (defmethod database-null-value ((type t))
 535   (cond
 536     ((subtypep type 'string) nil)
 537     ((subtypep type 'integer) nil)
 538     ((subtypep type 'list) nil)
 539     ((subtypep type 'boolean) nil)
 540     ((eql type t) nil)
 541     ((subtypep type 'symbol) nil)
 542     ((subtypep type 'keyword) nil)
 543     ((subtypep type 'wall-time) nil)
 544     ((subtypep type 'duration) nil)
 545     ((subtypep type 'money) nil)
 546     (t
 547      (error "Unable to handle null for type ~A" type))))
 548
 549 (defgeneric update-slot-with-null (instance slotname slotdef)
 550   (:documentation "Called to update a slot when its column has a NULL
 551 value.  If nulls are allowed for the column, the slot's value will be
 552 nil, otherwise its value will be set to the result of calling
 553 DATABASE-NULL-VALUE on the type of the slot."))
 554
 555 (defmethod update-slot-with-null ((object standard-db-object)
 556                                   slotname
 557                                   slotdef)
 558   (let ((st (slot-definition-type slotdef))
 559         (allowed (slot-value slotdef 'nulls-ok)))
 560     (if allowed
 561         (setf (slot-value object slotname) nil)
 562         (setf (slot-value object slotname)
 563               (database-null-value st)))))
 564
 565 (defvar +no-slot-value+ '+no-slot-value+)
 566
 567 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 568   (let* ((class (find-class classname))
 569          (sld (slotdef-for-slot-with-class slot class)))
 570     (if sld
 571         (if (eq value +no-slot-value+)
 572             (sql-expression :attribute (view-class-slot-column sld)
 573                             :table (view-table class))
 574             (db-value-from-slot
 575              sld
 576              value
 577              database))
 578         (error "Unknown slot ~A for class ~A" slot classname))))
 579
 580 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
 581         (declare (ignore database))
 582         (let* ((class (find-class classname)))
 583           (unless (view-table class)
 584             (error "No view-table for class ~A"  classname))
 585           (sql-expression :table (view-table class))))
 586
 587 (defmethod database-get-type-specifier (type args database)
 588   (declare (ignore type args))
 589   (if (member (database-type database) '(:postgresql :postgresql-socket))
 590           "VARCHAR"
 591           "VARCHAR(255)"))
 592
 593 (defmethod database-get-type-specifier ((type (eql 'integer)) args database)
 594   (declare (ignore database))
 595   ;;"INT8")
 596   (if args
 597       (format nil "INT(~A)" (car args))
 598       "INT"))
 599
 600 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
 601                                         database)
 602   (if args
 603       (format nil "VARCHAR(~A)" (car args))
 604       (if (member (database-type database) '(:postgresql :postgresql-socket))
 605           "VARCHAR"
 606           "VARCHAR(255)")))
 607
 608 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
 609                                         database)
 610   (if args
 611       (format nil "VARCHAR(~A)" (car args))
 612       (if (member (database-type database) '(:postgresql :postgresql-socket))
 613           "VARCHAR"
 614           "VARCHAR(255)")))
 615
 616 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
 617   (if args
 618       (format nil "VARCHAR(~A)" (car args))
 619       (if (member (database-type database) '(:postgresql :postgresql-socket))
 620           "VARCHAR"
 621           "VARCHAR(255)")))
 622
 623 (defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
 624   (declare (ignore args))
 625   (case (database-type database)
 626     (:postgresql
 627      "TIMESTAMP WITHOUT TIME ZONE")
 628     (:postgresql-socket
 629      "TIMESTAMP WITHOUT TIME ZONE")
 630     (:mysql
 631      "DATETIME")
 632     (t "TIMESTAMP")))
 633
 634 (defmethod database-get-type-specifier ((type (eql 'duration)) args database)
 635   (declare (ignore database args))
 636   "VARCHAR")
 637
 638 (defmethod database-get-type-specifier ((type (eql 'money)) args database)
 639   (declare (ignore database args))
 640   "INT8")
 641
 642 (deftype raw-string (&optional len)
 643   "A string which is not trimmed when retrieved from the database"
 644   `(string ,len))
 645
 646 (defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
 647   (declare (ignore database))
 648   (if args
 649       (format nil "VARCHAR(~A)" (car args))
 650       "VARCHAR"))
 651
 652 (defmethod database-get-type-specifier ((type (eql 'float)) args database)
 653   (declare (ignore database))
 654   (if args
 655       (format nil "FLOAT(~A)" (car args))
 656       "FLOAT"))
 657
 658 (defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
 659   (declare (ignore database))
 660   (if args
 661       (format nil "FLOAT(~A)" (car args))
 662       "FLOAT"))
 663
 664 (defmethod database-get-type-specifier ((type (eql 't)) args database)
 665   (declare (ignore args database))
 666   "BOOL")
 667
 668 (defmethod database-output-sql-as-type (type val database)
 669   (declare (ignore type database))
 670   val)
 671
 672 (defmethod database-output-sql-as-type ((type (eql 'list)) val database)
 673   (declare (ignore database))
 674   (progv '(*print-circle* *print-array*) '(t t)
 675     (let ((escaped (prin1-to-string val)))
 676       (clsql-base-sys::substitute-char-string
 677        escaped #\Null " "))))
 678
 679 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
 680   (declare (ignore database))
 681   (if val
 682       (symbol-name val))
 683   "")
 684
 685 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
 686   (declare (ignore database))
 687   (if val
 688       (symbol-name val)
 689       ""))
 690
 691 (defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
 692   (declare (ignore database))
 693   (progv '(*print-circle* *print-array*) '(t t)
 694     (prin1-to-string val)))
 695
 696 (defmethod database-output-sql-as-type ((type (eql 'array)) val database)
 697   (declare (ignore database))
 698   (progv '(*print-circle* *print-array*) '(t t)
 699     (prin1-to-string val)))
 700
 701 (defmethod database-output-sql-as-type ((type (eql 't)) val database)
 702   (declare (ignore database))
 703   (if val "t" "f"))
 704
 705 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
 706   (declare (ignore database))
 707   val)
 708
 709 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
 710                                         val database)
 711   (declare (ignore database))
 712   val)
 713
 714 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
 715                                         val database)
 716   (declare (ignore database))
 717   val)
 718
 719 (defmethod read-sql-value (val type database)
 720   (declare (ignore type database))
 721   (read-from-string val))
 722
 723 (defmethod read-sql-value (val (type (eql 'string)) database)
 724   (declare (ignore database))
 725   val)
 726
 727 (defmethod read-sql-value (val (type (eql 'simple-string)) database)
 728   (declare (ignore database))
 729   val)
 730
 731 (defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
 732   (declare (ignore database))
 733   val)
 734
 735 (defmethod read-sql-value (val (type (eql 'raw-string)) database)
 736   (declare (ignore database))
 737   val)
 738
 739 (defmethod read-sql-value (val (type (eql 'keyword)) database)
 740   (declare (ignore database))
 741   (when (< 0 (length val))
 742     (intern (string-upcase val) "KEYWORD")))
 743
 744 (defmethod read-sql-value (val (type (eql 'symbol)) database)
 745   (declare (ignore database))
 746   (when (< 0 (length val))
 747     (unless (string= val "NIL")
 748       (intern (string-upcase val)
 749               (symbol-package *update-context*)))))
 750
 751 (defmethod read-sql-value (val (type (eql 'integer)) database)
 752   (declare (ignore database))
 753   (etypecase val
 754     (string
 755      (read-from-string val))
 756     (number val)))
 757
 758 (defmethod read-sql-value (val (type (eql 'float)) database)
 759   (declare (ignore database))
 760   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
 761   (float (read-from-string val)))
 762
 763 (defmethod read-sql-value (val (type (eql 't)) database)
 764   (declare (ignore database))
 765   (equal "t" val))
 766
 767 (defmethod read-sql-value (val (type (eql 'wall-time)) database)
 768   (declare (ignore database))
 769   (unless (eq 'NULL val)
 770     (parse-timestring val)))
 771
 772 (defmethod read-sql-value (val (type (eql 'duration)) database)
 773   (declare (ignore database))
 774   (unless (or (eq 'NULL val)
 775               (equal "NIL" val))
 776     (parse-timestring val)))
 777
 778 (defmethod read-sql-value (val (type (eql 'money)) database)
 779   (unless (eq 'NULL val)
 780     (make-instance 'money :units (read-sql-value val 'integer database))))
 781
 782 ;; ------------------------------------------------------------
 783 ;; Logic for 'faulting in' :join slots
 784
 785 (defun fault-join-slot-raw (class object slot-def)
 786   (let* ((dbi (view-class-slot-db-info slot-def))
 787          (jc (gethash :join-class dbi)))
 788     (let ((jq (join-qualifier class object slot-def)))
 789       (when jq
 790         (select jc :where jq)))))
 791
 792 (defun fault-join-slot (class object slot-def)
 793   (let* ((dbi (view-class-slot-db-info slot-def))
 794          (ts (gethash :target-slot dbi))
 795          (res (fault-join-slot-raw class object slot-def)))
 796     (when res
 797       (cond
 798         ((and ts (gethash :set dbi))
 799          (mapcar (lambda (obj)
 800                    (cons obj (slot-value obj ts))) res))
 801         ((and ts (not (gethash :set dbi)))
 802          (mapcar (lambda (obj) (slot-value obj ts)) res))
 803         ((and (not ts) (not (gethash :set dbi)))
 804          (car res))
 805         ((and (not ts) (gethash :set dbi))
 806          res)))))
 807
 808 (defun join-qualifier (class object slot-def)
 809     (declare (ignore class))
 810     (let* ((dbi (view-class-slot-db-info slot-def))
 811            (jc (find-class (gethash :join-class dbi)))
 812            ;;(ts (gethash :target-slot dbi))
 813            ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
 814            (foreign-keys (gethash :foreign-key dbi))
 815            (home-keys (gethash :home-key dbi)))
 816       (when (every #'(lambda (slt)
 817                        (and (slot-boundp object slt)
 818                             (not (null (slot-value object slt)))))
 819                    (if (listp home-keys) home-keys (list home-keys)))
 820         (let ((jc (mapcar #'(lambda (hk fk)
 821                                    (let ((fksd (slotdef-for-slot-with-class fk jc)))
 822                                      (sql-operation '==
 823                                                     (typecase fk
 824                                                       (symbol
 825                                                        (sql-expression
 826                                                         :attribute (view-class-slot-column fksd)
 827                                                         :table (view-table jc)))
 828                                                       (t fk))
 829                                                     (typecase hk
 830                                                       (symbol
 831                                                        (slot-value object hk))
 832                                                       (t
 833                                                        hk)))))
 834                                (if (listp home-keys) home-keys (list home-keys))
 835                                (if (listp foreign-keys) foreign-keys (list foreign-keys)))))
 836           (when jc
 837             (if (> (length jc) 1)
 838                 (apply #'sql-and jc)
 839               jc))))))
 840
 841 (defmethod postinitialize ((self t))
 842   )
 843
 844 (defun find-all (view-classes &rest args &key all set-operation distinct from
 845                  where group-by having order-by order-by-descending offset limit
 846                  (database *default-database*))
 847   "tweeze me apart someone pleeze"
 848   (declare (ignore all set-operation group-by having
 849                    offset limit)
 850            (optimize (debug 3) (speed 1)))
 851   ;; (cmsg "Args = ~s" args)
 852   (remf args :from)
 853   (let* ((*db-deserializing* t)
 854          (*default-database* (or database
 855                                  (error 'clsql-no-database-error nil))))
 856     (flet ((table-sql-expr (table)
 857              (sql-expression :table (view-table table)))
 858            (ref-equal (ref1 ref2)
 859              (equal (sql ref1)
 860                     (sql ref2)))
 861            (tables-equal (table-a table-b)
 862              (string= (string (slot-value table-a 'name))
 863                       (string (slot-value table-b 'name)))))
 864
 865       (let* ((sclasses (mapcar #'find-class view-classes))
 866              (sels (mapcar #'generate-selection-list sclasses))
 867              (fullsels (apply #'append sels))
 868              (sel-tables (collect-table-refs where))
 869              (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables)
 870                                         :test #'tables-equal))
 871              (res nil))
 872         (dolist (ob (listify order-by))
 873           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 874                                      :test #'ref-equal)))
 875             (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
 876                                                     (listify ob))))))
 877         (dolist (ob (listify order-by-descending))
 878           (when (and ob (not (member ob (mapcar #'cdr fullsels)
 879                                      :test #'ref-equal)))
 880             (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
 881                                                     (listify ob))))))
 882         (dolist (ob (listify distinct))
 883           (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels)
 884                                                         :test #'ref-equal)))
 885             (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att))
 886                                                     (listify ob))))))
 887         ;; (cmsg  "Tables = ~s" tables)
 888         ;; (cmsg  "From = ~s" from)
 889         (setq res (apply #'select (append (mapcar #'cdr fullsels)
 890                                           (cons :from (list (append (when from (listify from)) (listify tables)))) args)))
 891         (flet ((build-object (vals)
 892                  (flet ((%build-object (vclass selects)
 893                           (let ((class-name (class-name vclass))
 894                                 (db-vals    (butlast vals (- (list-length vals)
 895                                                              (list-length selects)))))
 896                             ;; (setf vals (nthcdr (list-length selects) vals))
 897                             (%make-fresh-object class-name (mapcar #'car selects) db-vals))))
 898                    (let ((objects (mapcar #'%build-object sclasses sels)))
 899                      (if (= (length sclasses) 1)
 900                          (car objects)
 901                          objects)))))
 902           (mapcar #'build-object res))))))
 903
 904 (defun %make-fresh-object (class-name slots values)
 905   (let* ((*db-initializing* t)
 906          (obj (make-instance class-name
 907                              :stored t)))
 908     (setf obj (get-slot-values-from-view obj slots values))
 909     (postinitialize obj)
 910     obj))
 911
 912 (defun select (&rest select-all-args)
 913   "Selects data from database given the constraints specified. Returns
 914 a list of lists of record values as specified by select-all-args. By
 915 default, the records are each represented as lists of attribute
 916 values. The selections argument may be either db-identifiers, literal
 917 strings or view classes.  If the argument consists solely of view
 918 classes, the return value will be instances of objects rather than raw
 919 tuples."
 920   (flet ((select-objects (target-args)
 921            (and target-args
 922                 (every #'(lambda (arg)
 923                            (and (symbolp arg)
 924                                 (find-class arg nil)))
 925                        target-args))))
 926     (multiple-value-bind (target-args qualifier-args)
 927         (query-get-selections select-all-args)
 928       ;; (cmsg "Qual args = ~s" qualifier-args)
 929       (if (select-objects target-args)
 930           (apply #'find-all target-args qualifier-args)
 931           (let ((expr (apply #'make-query select-all-args)))
 932             (destructuring-bind (&key (flatp nil)
 933                                       (database *default-database*)
 934                                       &allow-other-keys)
 935                 qualifier-args
 936               (let ((res (query expr :database database)))
 937                 (if (and flatp
 938                          (= (length (slot-value expr 'selections)) 1))
 939                     (mapcar #'car res)
 940                   res))))))))