X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fnew-objects.lisp;fp=sql%2Fnew-objects.lisp;h=e5e06145e6aee105efff7ef5fee03331595a837e;hp=0000000000000000000000000000000000000000;hb=e3f355aa2b125569097bd7108fbbd14daa23e7aa;hpb=8550d408609dd0eccf93c9ab0c20143311ce7c7c diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp new file mode 100644 index 0000000..e5e0614 --- /dev/null +++ b/sql/new-objects.lisp @@ -0,0 +1,1048 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id: objects.lisp 8906 2004-04-09 12:41:07Z kevin $ +;;;; +;;;; The CLSQL Object Oriented Data Definitional Language (OODDL) +;;;; and Object Oriented Data Manipulation Language (OODML). +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + + +;; utils + +(defun replaced-string-length (str repl-alist) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) + (let* ((c (char str i)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) + + +(defun substitute-chars-strings (str repl-alist) + "Replace all instances of a chars with a string. repl-alist is an assoc +list of characters and replacement strings." + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) + +(defun string-replace (procstr match-char subst-str) + "Substitutes a string for a single matching character of a string" + (substitute-chars-strings procstr (list (cons match-char subst-str)))) + + +(defclass standard-db-object () + ((stored :db-kind :virtual + :initarg :stored + :initform nil)) + (:metaclass view-metaclass) + (:documentation "Superclass for all CLSQL View Classes.")) + +(defvar *deserializing* nil) +(defvar *initializing* nil) + +(defmethod initialize-instance :around ((object standard-db-object) + &rest all-keys &key &allow-other-keys) + (declare (ignore all-keys)) + (let ((*initializing* t)) + (call-next-method) + (unless *deserializing* + #+nil (created-object object) + (update-records-from-instance object)))) + +(defmethod slot-value-using-class ((class view-metaclass) instance slot-def) + (declare (optimize (speed 3))) + (unless *deserializing* + (let ((slot-name (%slot-def-name slot-def)) + (slot-kind (view-class-slot-db-kind slot-def))) + (when (and (eql slot-kind :join) + (not (slot-boundp instance slot-name))) + (let ((*deserializing* t)) + (setf (slot-value instance slot-name) + (fault-join-slot class instance slot-def)))))) + (call-next-method)) + +(defmethod (setf slot-value-using-class) :around (new-value (class view-metaclass) instance slot-def) + (declare (ignore new-value)) + (let* ((slot-name (%slot-def-name slot-def)) + (slot-kind (view-class-slot-db-kind slot-def)) + (no-update? (or (eql slot-kind :virtual) + *initializing* + *deserializing*))) + (call-next-method) + (unless no-update? + (update-record-from-slot instance slot-name)))) + +(defun %slot-def-name (slot) + #+lispworks slot + #-lispworks (slot-definition-name slot)) + +(defun %slot-object (slot class) + (declare (ignorable class)) + #+lispworks (clos:find-slot-definition slot class) + #-lispworks slot) + +(defun sequence-from-class (view-class-name) + (sql-escape + (concatenate + 'string + (symbol-name (view-table (find-class view-class-name))) + "-SEQ"))) + +(defun create-sequence-from-class (view-class-name + &key (database *default-database*)) + (create-sequence (sequence-from-class view-class-name) :database database)) + +(defun drop-sequence-from-class (view-class-name + &key (if-does-not-exist :error) + (database *default-database*)) + (drop-sequence (sequence-from-class view-class-name) + :if-does-not-exist if-does-not-exist + :database database)) + +;; +;; Build the database tables required to store the given view class +;; + +(defmethod database-pkey-constraint ((class view-metaclass) database) + (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) + (when keylist + (format nil "CONSTRAINT ~APK PRIMARY KEY~A" + (database-output-sql (view-table class) database) + (database-output-sql keylist database))))) + + + +#+noschema +(progn +#.(locally-enable-sql-reader-syntax) + +(defun ensure-schema-version-table (database) + (unless (table-exists-p "clsql_object_v" :database database) + (create-table [clsql_object_v] '(([name] string) + ([vers] integer) + ([def] string)) + :database database))) + +(defun update-schema-version-records (view-class-name + &key (database *default-database*)) + (let ((schemadef nil) + (tclass (find-class view-class-name))) + (dolist (slotdef (class-slots tclass)) + (let ((res (database-generate-column-definition view-class-name + slotdef database))) + (when res (setf schemadef (cons res schemadef))))) + (when schemadef + (delete-records :from [clsql_object_v] + :where [= [name] (sql-escape (class-name tclass))] + :database database) + (insert-records :into [clsql_object_v] + :av-pairs `(([name] ,(sql-escape (class-name tclass))) + ([vers] ,(car (object-version tclass))) + ([def] ,(prin1-to-string + (object-definition tclass)))) + :database database)))) + +#.(restore-sql-reader-syntax-state) +) + +(defun create-view-from-class (view-class-name + &key (database *default-database*)) + "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines +the view. The argument DATABASE has a default value of +*DEFAULT-DATABASE*." + (let ((tclass (find-class view-class-name))) + (if tclass + (let ((*default-database* database)) + (%install-class tclass database) + #+noschema (ensure-schema-version-table database) + #+noschema (update-schema-version-records view-class-name :database database)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defmethod %install-class ((self view-metaclass) database &aux schemadef) + (dolist (slotdef (ordered-class-slots self)) + (let ((res (database-generate-column-definition (class-name self) + slotdef database))) + (when res + (push res schemadef)))) + (unless schemadef + (error "Class ~s has no :base slots" self)) + (create-table (sql-expression :table (view-table self)) schemadef + :database database + :constraints (database-pkey-constraint self database)) + (push self (database-view-classes database)) + t) + +;; +;; Drop the tables which store the given view class +;; + +#.(locally-enable-sql-reader-syntax) + +(defun drop-view-from-class (view-class-name &key (database *default-database*)) + "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME +which defines that view. The argument DATABASE has a default value of +*DEFAULT-DATABASE*." + (let ((tclass (find-class view-class-name))) + (if tclass + (let ((*default-database* database)) + (%uninstall-class tclass) + #+nil + (delete-records :from [clsql_object_v] + :where [= [name] (sql-escape view-class-name)])) + (error "Class ~s not found." view-class-name))) + (values)) + +#.(restore-sql-reader-syntax-state) + +(defun %uninstall-class (self &key (database *default-database*)) + (drop-table (sql-expression :table (view-table self)) + :if-does-not-exist :ignore + :database database) + (setf (database-view-classes database) + (remove self (database-view-classes database)))) + + +;; +;; List all known view classes +;; + +(defun list-classes (&key (test #'identity) + (root-class 'standard-db-object) + (database *default-database*)) + "Returns a list of View Classes connected to a given DATABASE which +defaults to *DEFAULT-DATABASE*." + (declare (ignore root-class)) + (remove-if #'(lambda (c) (not (funcall test c))) + (database-view-classes database))) + +;; +;; Define a new view class +;; + +(defmacro def-view-class (class supers slots &rest options) + "Extends the syntax of defclass to allow special slots to be mapped +onto the attributes of database views. The macro DEF-VIEW-CLASS +creates a class called CLASS which maps onto a database view. Such a +class is called a View Class. The macro DEF-VIEW-CLASS extends the +syntax of DEFCLASS to allow special base slots to be mapped onto the +attributes of database views (presently single tables). When a select +query that names a View Class is submitted, then the corresponding +database view is queried, and the slots in the resulting View Class +instances are filled with attribute values from the database. If +SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the +superclass of the newly-defined View Class." + `(progn + (defclass ,class ,supers ,slots ,@options + (:metaclass view-metaclass)) + (finalize-inheritance (find-class ',class)))) + +(defun keyslots-for-class (class) + (slot-value class 'key-slots)) + +(defun key-qualifier-for-instance (obj &key (database *default-database*)) + (let ((tb (view-table (class-of obj)))) + (flet ((qfk (k) + (sql-operation '== + (sql-expression :attribute + (view-class-slot-column k) + :table tb) + (db-value-from-slot + k + (slot-value obj (slot-definition-name k)) + database)))) + (let* ((keys (keyslots-for-class (class-of obj))) + (keyxprs (mapcar #'qfk (reverse keys)))) + (cond + ((= (length keyxprs) 0) nil) + ((= (length keyxprs) 1) (car keyxprs)) + ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs))))))) + +;; +;; Function used by 'generate-selection-list' +;; + +(defun generate-attribute-reference (vclass slotdef) + (cond + ((eq (view-class-slot-db-kind slotdef) :base) + (sql-expression :attribute (view-class-slot-column slotdef) + :table (view-table vclass))) + ((eq (view-class-slot-db-kind slotdef) :key) + (sql-expression :attribute (view-class-slot-column slotdef) + :table (view-table vclass))) + (t nil))) + +;; +;; Function used by 'find-all' +;; + +(defun generate-selection-list (vclass) + (let ((sels nil)) + (dolist (slotdef (ordered-class-slots vclass)) + (let ((res (generate-attribute-reference vclass slotdef))) + (when res + (push (cons slotdef res) sels)))) + (if sels + sels + (error "No slots of type :base in view-class ~A" (class-name vclass))))) + +;; +;; Used by 'create-view-from-class' +;; + + +(defmethod database-generate-column-definition (class slotdef database) + (declare (ignore database class)) + (when (member (view-class-slot-db-kind slotdef) '(:base :key)) + (let ((cdef + (list (sql-expression :attribute (view-class-slot-column slotdef)) + (slot-type slotdef)))) + (let ((const (view-class-slot-db-constraints slotdef))) + (when const + (setq cdef (append cdef (list const))))) + cdef))) + +;; +;; Called by 'get-slot-values-from-view' +;; + +(declaim (inline delistify)) +(defun delistify (list) + (if (listp list) + (car list) + list)) + +(defun slot-type (slotdef) + (specified-type slotdef) + #+ignore + (let ((slot-type (specified-type slotdef))) + (if (listp slot-type) + (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys) + (cdr slot-type)) + (find-symbol (symbol-name slot-type) :clsql-sys)))) + +(defvar *update-context* nil) + +(defmethod update-slot-from-db ((instance standard-db-object) slotdef value) + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let* ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-name (slot-definition-name slotdef)) + (slot-type (slot-type slotdef)) + (*update-context* (cons (type-of instance) slot-name))) + (cond ((and value (null slot-reader)) + (setf (slot-value instance slot-name) + (read-sql-value value (delistify slot-type) + *default-database*))) + ((null value) + (update-slot-with-null instance slot-name slotdef)) + ((typep slot-reader 'string) + (setf (slot-value instance slot-name) + (format nil slot-reader value))) + ((typep slot-reader 'function) + (setf (slot-value instance slot-name) + (apply slot-reader (list value)))) + (t + (error "Slot reader is of an unusual type."))))) + +(defmethod key-value-from-db (slotdef value database) + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-type (slot-type slotdef))) + (cond ((and value (null slot-reader)) + (read-sql-value value (delistify slot-type) database)) + ((null value) + nil) + ((typep slot-reader 'string) + (format nil slot-reader value)) + ((typep slot-reader 'function) + (apply slot-reader (list value))) + (t + (error "Slot reader is of an unusual type."))))) + +(defun db-value-from-slot (slotdef val database) + (let ((dbwriter (view-class-slot-db-writer slotdef)) + (dbtype (slot-type slotdef))) + (typecase dbwriter + (string (format nil dbwriter val)) + (function (apply dbwriter (list val))) + (t + (typecase dbtype + (cons + (database-output-sql-as-type (car dbtype) val database)) + (t + (database-output-sql-as-type dbtype val database))))))) + +(defun check-slot-type (slotdef val) + (let* ((slot-type (slot-type slotdef)) + (basetype (if (listp slot-type) (car slot-type) slot-type))) + (when (and slot-type val) + (unless (typep val basetype) + (error 'clsql-type-error + :slotname (slot-definition-name slotdef) + :typespec slot-type + :value val))))) + +;; +;; Called by find-all +;; + +(defmethod get-slot-values-from-view (obj slotdeflist values) + (flet ((update-slot (slot-def values) + (update-slot-from-db obj slot-def values))) + (mapc #'update-slot slotdeflist values) + obj)) + +(defun synchronize-keys (src srckey dest destkey) + (let ((skeys (if (listp srckey) srckey (list srckey))) + (dkeys (if (listp destkey) destkey (list destkey)))) + (mapcar #'(lambda (sk dk) + (setf (slot-value dest dk) + (typecase sk + (symbol + (slot-value src sk)) + (t sk)))) + skeys dkeys))) + +(defun desynchronize-keys (dest destkey) + (let ((dkeys (if (listp destkey) destkey (list destkey)))) + (mapcar #'(lambda (dk) + (setf (slot-value dest dk) nil)) + dkeys))) + +(defmethod add-to-relation ((target standard-db-object) + slot-name + (value standard-db-object)) + (let* ((objclass (class-of target)) + (sdef (or (slotdef-for-slot-with-class slot-name objclass) + (error "~s is not an known slot on ~s" slot-name target))) + (dbinfo (view-class-slot-db-info sdef)) + (join-class (gethash :join-class dbinfo)) + (homekey (gethash :home-key dbinfo)) + (foreignkey (gethash :foreign-key dbinfo)) + (to-many (gethash :set dbinfo))) + (unless (equal (type-of value) join-class) + (error 'clsql-type-error :slotname slot-name :typespec join-class + :value value)) + (when (gethash :target-slot dbinfo) + (error "add-to-relation does not work with many-to-many relations yet.")) + (if to-many + (progn + (synchronize-keys target homekey value foreignkey) + (if (slot-boundp target slot-name) + (unless (member value (slot-value target slot-name)) + (setf (slot-value target slot-name) + (append (slot-value target slot-name) (list value)))) + (setf (slot-value target slot-name) (list value)))) + (progn + (synchronize-keys value foreignkey target homekey) + (setf (slot-value target slot-name) value))))) + +(defmethod remove-from-relation ((target standard-db-object) + slot-name (value standard-db-object)) + (let* ((objclass (class-of target)) + (sdef (slotdef-for-slot-with-class slot-name objclass)) + (dbinfo (view-class-slot-db-info sdef)) + (homekey (gethash :home-key dbinfo)) + (foreignkey (gethash :foreign-key dbinfo)) + (to-many (gethash :set dbinfo))) + (when (gethash :target-slot dbinfo) + (error "remove-relation does not work with many-to-many relations yet.")) + (if to-many + (progn + (desynchronize-keys value foreignkey) + (if (slot-boundp target slot-name) + (setf (slot-value target slot-name) + (remove value + (slot-value target slot-name) + :test #'equal)))) + (progn + (desynchronize-keys target homekey) + (setf (slot-value target slot-name) + nil))))) + + +(defgeneric update-record-from-slot (object slot &key database) + (:documentation + "The generic function UPDATE-RECORD-FROM-SLOT updates an individual +data item in the column represented by SLOT. The DATABASE is only used +if OBJECT is not yet associated with any database, in which case a +record is created in DATABASE. Only SLOT is initialized in this case; +other columns in the underlying database receive default values. The +argument SLOT is the CLOS slot name; the corresponding column names +are derived from the View Class definition.")) + +(defmethod update-record-from-slot ((obj standard-db-object) slot &key + (database *default-database*)) + #+nil (odcl:updated-object obj) + (let* ((vct (view-table (class-of obj))) + (stored? (slot-value obj 'stored)) + (sd (slotdef-for-slot-with-class slot (class-of obj)))) + (check-slot-type sd (slot-value obj slot)) + (let* ((att (view-class-slot-column sd)) + (val (db-value-from-slot sd (slot-value obj slot) database))) + (cond ((and vct sd stored?) + (update-records :table (sql-expression :table vct) + :attributes (list (sql-expression :attribute att)) + :values (list val) + :where (key-qualifier-for-instance obj :database database) + :database database)) + ((not stored?) + t) + (t + (error "Unable to update record"))))) + t) + +(defgeneric update-record-from-slots (object slots &key database) + (:documentation + "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the +columns represented by SLOTS. The DATABASE is only used if OBJECT is +not yet associated with any database, in which case a record is +created in DATABASE. Only slots are initialized in this case; other +columns in the underlying database receive default values. The +argument SLOTS contains the CLOS slot names; the corresponding column +names are derived from the view class definition.")) + +(defmethod update-record-from-slots ((obj standard-db-object) slots &key + (database *default-database*)) + (let* ((vct (view-table (class-of obj))) + (stored? (slot-value obj 'stored)) + (sds (slotdefs-for-slots-with-class slots (class-of obj))) + (avps (mapcar #'(lambda (s) + (let ((val (slot-value + obj (slot-definition-name s)))) + (check-slot-type s val) + (list (sql-expression + :attribute (view-class-slot-column s)) + (db-value-from-slot s val database)))) + sds))) + (cond ((and avps stored?) + (update-records :table (sql-expression :table vct) + :av-pairs avps + :where (key-qualifier-for-instance + obj :database database) + :database database)) + (avps + (insert-records :into (sql-expression :table vct) + :av-pairs avps + :database database) + (setf (slot-value obj 'stored) t)) + (t + (error "Unable to update records")))) + t) + + +(defgeneric update-records-from-instance (object &key database) + (:documentation + "Using an instance of a view class, update the database table that +stores its instance data. If the instance is already associated with a +database, that database is used, and database is ignored. If instance +is not yet associated with a database, a record is created for +instance in the appropriate table of database and the instance becomes +associated with that database.")) + +(defmethod update-records-from-instance ((obj standard-db-object) + &key (database *default-database*)) + (labels ((slot-storedp (slot) + (and (member (view-class-slot-db-kind slot) '(:base :key)) + (slot-boundp obj (slot-definition-name slot)))) + (slot-value-list (slot) + (let ((value (slot-value obj (slot-definition-name slot)))) + (check-slot-type slot value) + (list (sql-expression :attribute (view-class-slot-column slot)) + (db-value-from-slot slot value database))))) + (let* ((view-class (class-of obj)) + (view-class-table (view-table view-class)) + (slots (remove-if-not #'slot-storedp (class-slots view-class))) + (record-values (mapcar #'slot-value-list slots))) + (unless record-values + (error "No settable slots.")) + (if (slot-value obj 'stored) + (update-records :table (sql-expression :table view-class-table) + :av-pairs record-values + :where (key-qualifier-for-instance + obj :database database) + :database database) + (progn + (insert-records :into (sql-expression :table view-class-table) + :av-pairs record-values + :database database) + (setf (slot-value obj 'stored) t))))) + t) + + (setf (symbol-function (intern (symbol-name '#:store-instance))) + (symbol-function 'update-records-from-instance)) + +(defmethod delete-instance-records ((object standard-db-object)) + (let ((vt (sql-expression :table (view-table (class-of object)))) + (qualifier (key-qualifier-for-instance object :database *default-database*))) + (delete-records :from vt :where qualifier :database *default-database*) + #+ignore (odcl::deleted-object object))) + +(defgeneric update-instance-from-db (instance) + (:documentation + "Updates the values in the slots of the View Class instance +INSTANCE using the data in the database DATABASE which defaults to the +database that INSTANCE is associated with, or the value of +*DEFAULT-DATABASE*.")) + +(defmethod update-instance-from-db ((object standard-db-object)) + (let* ((view-class (find-class (class-name (class-of object)))) + (view-table (sql-expression :table (view-table view-class))) + (view-qual (key-qualifier-for-instance object :database *default-database*)) + (sels (generate-selection-list view-class)) + (res (apply #'select (append (mapcar #'cdr sels) (list :from view-table + :where view-qual))))) + (when res + (get-slot-values-from-view object (mapcar #'car sels) (car res)) + res))) + + +(defgeneric database-null-value (type) + (:documentation "Return an expression of type TYPE which SQL NULL values +will be converted into.")) + +(defmethod database-null-value ((type t)) + (cond + ((subtypep type 'string) nil) + ((subtypep type 'integer) nil) + ((subtypep type 'list) nil) + ((subtypep type 'boolean) nil) + ((eql type t) nil) + ((subtypep type 'symbol) nil) + ((subtypep type 'keyword) nil) + ((subtypep type 'wall-time) nil) + ((subtypep type 'duration) nil) + ((subtypep type 'money) nil) + (t + (error "Unable to handle null for type ~A" type)))) + +(defgeneric update-slot-with-null (instance slotname slotdef) + (:documentation "Called to update a slot when its column has a NULL +value. If nulls are allowed for the column, the slot's value will be +nil, otherwise its value will be set to the result of calling +DATABASE-NULL-VALUE on the type of the slot.")) + +(defmethod update-slot-with-null ((object standard-db-object) + slotname + slotdef) + (let ((st (slot-definition-type slotdef)) + (allowed (slot-value slotdef 'nulls-ok))) + (if allowed + (setf (slot-value object slotname) nil) + (setf (slot-value object slotname) + (database-null-value st))))) + +(defvar +no-slot-value+ '+no-slot-value+) + +(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*)) + (let* ((class (find-class classname)) + (sld (slotdef-for-slot-with-class slot class))) + (if sld + (if (eq value +no-slot-value+) + (sql-expression :attribute (view-class-slot-column sld) + :table (view-table class)) + (db-value-from-slot + sld + value + database)) + (error "Unknown slot ~A for class ~A" slot classname)))) + +(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) + (declare (ignore database)) + (let* ((class (find-class classname))) + (unless (view-table class) + (error "No view-table for class ~A" classname)) + (sql-expression :table (view-table class)))) + +(defmethod database-get-type-specifier (type args database) + (declare (ignore type args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)")) + +(defmethod database-get-type-specifier ((type (eql 'integer)) args database) + (declare (ignore database)) + ;;"INT8") + (if args + (format nil "INT(~A)" (car args)) + "INT")) + +(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args + database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'simple-string)) args + database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'string)) args database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) + (declare (ignore args)) + (case (database-type database) + (:postgresql + "TIMESTAMP WITHOUT TIME ZONE") + (:postgresql-socket + "TIMESTAMP WITHOUT TIME ZONE") + (:mysql + "DATETIME") + (t "TIMESTAMP"))) + +(defmethod database-get-type-specifier ((type (eql 'duration)) args database) + (declare (ignore database args)) + "VARCHAR") + +(defmethod database-get-type-specifier ((type (eql 'money)) args database) + (declare (ignore database args)) + "INT8") + +(deftype raw-string (&optional len) + "A string which is not trimmed when retrieved from the database" + `(string ,len)) + +(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + "VARCHAR")) + +(defmethod database-get-type-specifier ((type (eql 'float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 't)) args database) + (declare (ignore args database)) + "BOOL") + +(defmethod database-output-sql-as-type (type val database) + (declare (ignore type database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'list)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (let ((escaped (prin1-to-string val))) + (setf escaped (string-replace #\Null " " escaped)) + escaped))) + + +(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) + (declare (ignore database)) + (if val + (symbol-name val)) + "") + +(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) + (declare (ignore database)) + (if val + (symbol-name val) + "")) + +(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'array)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 't)) val database) + (declare (ignore database)) + (if val "t" "f")) + +(defmethod database-output-sql-as-type ((type (eql 'string)) val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-string)) + val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) + val database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val type database) + (declare (ignore type database)) + (read-from-string val)) + +(defmethod read-sql-value (val (type (eql 'string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'raw-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'keyword)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (intern (string-upcase val) "KEYWORD"))) + +(defmethod read-sql-value (val (type (eql 'symbol)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (unless (string= val "NIL") + (intern (string-upcase val) + (symbol-package *update-context*))))) + +(defmethod read-sql-value (val (type (eql 'integer)) database) + (declare (ignore database)) + (etypecase val + (string + (read-from-string val)) + (number val))) + +(defmethod read-sql-value (val (type (eql 'float)) database) + (declare (ignore database)) + ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) + (float (read-from-string val))) + +(defmethod read-sql-value (val (type (eql 't)) database) + (declare (ignore database)) + (equal "t" val)) + +(defmethod read-sql-value (val (type (eql 'wall-time)) database) + (declare (ignore database)) + (unless (eq 'NULL val) + (parse-timestring val))) + +(defmethod read-sql-value (val (type (eql 'duration)) database) + (declare (ignore database)) + (unless (or (eq 'NULL val) + (equal "NIL" val)) + (parse-timestring val))) + +(defmethod read-sql-value (val (type (eql 'money)) database) + (unless (eq 'NULL val) + (make-instance 'money :units (read-sql-value val 'integer database)))) + +;; ------------------------------------------------------------ +;; Logic for 'faulting in' :join slots + +(defun fault-join-slot-raw (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (jc (gethash :join-class dbi))) + (let ((jq (join-qualifier class object slot-def))) + (when jq + (select jc :where jq))))) + +(defun fault-join-slot (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (res (fault-join-slot-raw class object slot-def))) + (when res + (cond + ((and ts (gethash :set dbi)) + (mapcar (lambda (obj) + (cons obj (slot-value obj ts))) res)) + ((and ts (not (gethash :set dbi))) + (mapcar (lambda (obj) (slot-value obj ts)) res)) + ((and (not ts) (not (gethash :set dbi))) + (car res)) + ((and (not ts) (gethash :set dbi)) + res))))) + +(defun join-qualifier (class object slot-def) + (declare (ignore class)) + (let* ((dbi (view-class-slot-db-info slot-def)) + (jc (find-class (gethash :join-class dbi))) + ;;(ts (gethash :target-slot dbi)) + ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc))) + (foreign-keys (gethash :foreign-key dbi)) + (home-keys (gethash :home-key dbi))) + (when (every #'(lambda (slt) + (and (slot-boundp object slt) + (not (null (slot-value object slt))))) + (if (listp home-keys) home-keys (list home-keys))) + (let ((jc (mapcar #'(lambda (hk fk) + (let ((fksd (slotdef-for-slot-with-class fk jc))) + (sql-operation '== + (typecase fk + (symbol + (sql-expression + :attribute (view-class-slot-column fksd) + :table (view-table jc))) + (t fk)) + (typecase hk + (symbol + (slot-value object hk)) + (t + hk))))) + (if (listp home-keys) home-keys (list home-keys)) + (if (listp foreign-keys) foreign-keys (list foreign-keys))))) + (when jc + (if (> (length jc) 1) + (apply #'sql-and jc) + jc)))))) + +(defmethod postinitialize ((self t)) + ) + +(defun find-all (view-classes &rest args &key all set-operation distinct from + where group-by having order-by order-by-descending offset limit + (database *default-database*)) + "tweeze me apart someone pleeze" + (declare (ignore all set-operation group-by having + offset limit) + (optimize (debug 3) (speed 1))) + ;; (cmsg "Args = ~s" args) + (remf args :from) + (let* ((*deserializing* t) + (*default-database* (or database + (error 'usql-nodb-error)))) + (flet ((table-sql-expr (table) + (sql-expression :table (view-table table))) + (ref-equal (ref1 ref2) + (equal (sql ref1) + (sql ref2))) + (tables-equal (table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name))))) + + (let* ((sclasses (mapcar #'find-class view-classes)) + (sels (mapcar #'generate-selection-list sclasses)) + (fullsels (apply #'append sels)) + (sel-tables (collect-table-refs where)) + (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables) + :test #'tables-equal)) + (res nil)) + (dolist (ob (listify order-by)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (dolist (ob (listify order-by-descending)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (dolist (ob (listify distinct)) + (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + ;; (cmsg "Tables = ~s" tables) + ;; (cmsg "From = ~s" from) + (setq res (apply #'select (append (mapcar #'cdr fullsels) + (cons :from (list (append (when from (listify from)) (listify tables)))) args))) + (flet ((build-object (vals) + (flet ((%build-object (vclass selects) + (let ((class-name (class-name vclass)) + (db-vals (butlast vals (- (list-length vals) + (list-length selects))))) + ;; (setf vals (nthcdr (list-length selects) vals)) + (%make-fresh-object class-name (mapcar #'car selects) db-vals)))) + (let ((objects (mapcar #'%build-object sclasses sels))) + (if (= (length sclasses) 1) + (car objects) + objects))))) + (mapcar #'build-object res)))))) + +(defun %make-fresh-object (class-name slots values) + (let* ((*initializing* t) + (obj (make-instance class-name + :stored t))) + (setf obj (get-slot-values-from-view obj slots values)) + (postinitialize obj) + obj)) + +(defun select (&rest select-all-args) + "Selects data from database given the constraints specified. Returns +a list of lists of record values as specified by select-all-args. By +default, the records are each represented as lists of attribute +values. The selections argument may be either db-identifiers, literal +strings or view classes. If the argument consists solely of view +classes, the return value will be instances of objects rather than raw +tuples." + (flet ((select-objects (target-args) + (and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (find-class arg nil))) + target-args)))) + (multiple-value-bind (target-args qualifier-args) + (query-get-selections select-all-args) + ;; (cmsg "Qual args = ~s" qualifier-args) + (if (select-objects target-args) + (apply #'find-all target-args qualifier-args) + (let ((expr (apply #'make-query select-all-args))) + (destructuring-bind (&key (flatp nil) + (database *default-database*) + &allow-other-keys) + qualifier-args + (let ((res (query expr :database database))) + (if (and flatp + (= (length (slot-value expr 'selections)) 1)) + (mapcar #'car res) + res))))))))