X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=dc4f7bb3b2512246e96163a7aeb325e848e2b6e6;hp=960dbd288282f10a36940849d8a909a2e3d123f3;hb=f97c6c182c9746cd6adbdacf8cdfebbaadef3c37;hpb=81631609ae02879280f2b4f4da74475c67b0a32c diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 960dbd2..dc4f7bb 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -87,14 +87,11 @@ ;; Called by 'get-slot-values-from-view' ;; -(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 (specified-type slotdef)) - (*update-context* (cons (type-of instance) slot-name))) + (slot-type (specified-type slotdef))) (cond ((and value (null slot-reader)) (setf (slot-value instance slot-name) (read-sql-value value (delistify slot-type) @@ -251,7 +248,8 @@ (if vd (let ((qualifier (key-qualifier-for-instance instance :database vd))) (delete-records :from vt :where qualifier :database vd) - (setf (slot-value instance 'view-database) nil)) + (setf (slot-value instance 'view-database) nil) + (values)) (signal-no-database-error vd)))) (defmethod update-instance-from-records ((instance standard-db-object) @@ -309,15 +307,32 @@ (error "No view-table for class ~A" classname)) (sql-expression :table (view-table class)))) + (defmethod database-get-type-specifier (type args database db-type) (declare (ignore type args database db-type)) - "VARCHAR(255)") + (format nil "VARCHAR(~D)" *default-string-length*)) (defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type) (declare (ignore database db-type)) (if args (format nil "INT(~A)" (car args)) - "INT")) + "INT")) + +(deftype tinyint () + "An 8-bit integer, this width may vary by SQL implementation." + 'integer) + +(defmethod database-get-type-specifier ((type (eql 'tinyint)) args database db-type) + (declare (ignore args database db-type)) + "INT") + +(deftype smallint () + "An integer smaller than a 32-bit integer, this width may vary by SQL implementation." + 'integer) + +(defmethod database-get-type-specifier ((type (eql 'smallint)) args database db-type) + (declare (ignore args database db-type)) + "INT") (deftype bigint () "An integer larger than a 32-bit integer, this width may vary by SQL implementation." @@ -326,26 +341,23 @@ (defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type) (declare (ignore args database db-type)) "BIGINT") - -(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args - database db-type) - (declare (ignore database db-type)) - (if args - (format nil "VARCHAR(~A)" (car args)) - "VARCHAR(255)")) -(defmethod database-get-type-specifier ((type (eql 'simple-string)) args +(deftype varchar () + "A variable length string for the SQL varchar type." + 'string) + +(defmethod database-get-type-specifier ((type (eql 'varchar)) args database db-type) (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - "VARCHAR(255)")) + (format nil "VARCHAR(~D)" *default-string-length*))) (defmethod database-get-type-specifier ((type (eql 'string)) args database db-type) (declare (ignore database db-type)) (if args - (format nil "VARCHAR(~A)" (car args)) - "VARCHAR(255)")) + (format nil "CHAR(~A)" (car args)) + (format nil "VARCHAR(~D)" *default-string-length*))) (deftype universal-time () "A positive integer as returned by GET-UNIVERSAL-TIME." @@ -367,16 +379,11 @@ (declare (ignore database args db-type)) "INT8") -(deftype raw-string (&optional len) - "A string which is not trimmed when retrieved from the database" +#+ignore +(deftype char (&optional len) + "A lisp type for the SQL CHAR type." `(string ,len)) -(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database db-type) - (declare (ignore database db-type)) - (if args - (format nil "VARCHAR(~A)" (car args)) - "VARCHAR")) - (defmethod database-get-type-specifier ((type (eql 'float)) args database db-type) (declare (ignore database db-type)) (if args @@ -389,10 +396,35 @@ (format nil "FLOAT(~A)" (car args)) "FLOAT")) +(deftype generalized-boolean () + "A type which outputs a SQL boolean value, though any lisp type can be stored in the slot." + t) + (defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type) (declare (ignore args database db-type)) "BOOL") +(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database db-type) + (declare (ignore args database db-type)) + "BOOL") + +(defmethod database-get-type-specifier ((type (eql 'number)) args database db-type) + (declare (ignore database db-type)) + (cond + ((and (consp args) (= (length args) 2)) + (format nil "NUMBER(~D,~D)" (first args) (second args))) + ((and (consp args) (= (length args) 1)) + (format nil "NUMBER(~D)" (first args))) + (t + "NUMBER"))) + +(defmethod database-get-type-specifier ((type (eql 'char)) args database db-type) + (declare (ignore database db-type)) + (if args + (format nil "CHAR(~D)" (first args)) + "CHAR(1)")) + + (defmethod database-output-sql-as-type (type val database db-type) (declare (ignore type database db-type)) val) @@ -406,14 +438,12 @@ (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type) (declare (ignore database db-type)) - (if (keywordp val) - (symbol-name val) - (if val - (concatenate 'string - (package-name (symbol-package val)) - "::" - (symbol-name val)) - ""))) + (if val + (concatenate 'string + (package-name (symbol-package val)) + "::" + (symbol-name val)) + "")) (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type) (declare (ignore database db-type)) @@ -435,19 +465,24 @@ (declare (ignore database db-type)) (if val "t" "f")) +(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database db-type) + (declare (ignore database db-type)) + (if val "t" "f")) + (defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type) (declare (ignore database db-type)) val) -(defmethod database-output-sql-as-type ((type (eql 'simple-string)) - val database db-type) +(defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type) (declare (ignore database db-type)) - val) + (etypecase val + (character (write-to-string val)) + (string val))) -(defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) - val database db-type) +(defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type) (declare (ignore database db-type)) - val) + (let ((*read-default-float-format* (type-of val))) + (format nil "~F" val))) (defmethod read-sql-value (val type database db-type) (declare (ignore type database db-type)) @@ -457,18 +492,14 @@ (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'simple-string)) database db-type) +(defmethod read-sql-value (val (type (eql 'varchar)) database db-type) (declare (ignore database db-type)) val) -(defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type) +(defmethod read-sql-value (val (type (eql 'char)) database db-type) (declare (ignore database db-type)) - val) - -(defmethod read-sql-value (val (type (eql 'raw-string)) database db-type) - (declare (ignore database db-type)) - val) - + (schar val 0)) + (defmethod read-sql-value (val (type (eql 'keyword)) database db-type) (declare (ignore database db-type)) (when (< 0 (length val)) @@ -479,8 +510,7 @@ (declare (ignore database db-type)) (when (< 0 (length val)) (unless (string= val (symbol-name-default-case "NIL")) - (intern (symbol-name-default-case val) - (symbol-package *update-context*))))) + (read-from-string val)))) (defmethod read-sql-value (val (type (eql 'integer)) database db-type) (declare (ignore database db-type)) @@ -490,6 +520,14 @@ (parse-integer val))) (number val))) +(defmethod read-sql-value (val (type (eql 'smallint)) database db-type) + (declare (ignore database db-type)) + (etypecase val + (string + (unless (string-equal "NIL" val) + (parse-integer val))) + (number val))) + (defmethod read-sql-value (val (type (eql 'bigint)) database db-type) (declare (ignore database db-type)) (etypecase val @@ -511,7 +549,19 @@ (declare (ignore database db-type)) (equal "t" val)) -(defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type) +(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type) + (declare (ignore database db-type)) + (equal "t" val)) + +(defmethod read-sql-value (val (type (eql 'number)) database db-type) + (declare (ignore database db-type)) + (etypecase val + (string + (unless (string-equal "NIL" val) + (read-from-string val))) + (number val))) + +(defmethod read-sql-value (val (type (eql 'universal-time)) database db-type) (declare (ignore database db-type)) (unless (eq 'NULL val) (etypecase val @@ -801,15 +851,15 @@ maximum of MAX-LEN instances updated in each query." View Classes VIEW-CLASSES are passed as arguments to SELECT." (declare (ignore all set-operation group-by having offset limit inner-join on) (optimize (debug 3) (speed 1))) - (labels ((ref-equal (ref1 ref2) - (equal (sql ref1) - (sql ref2))) - (table-sql-expr (table) - (sql-expression :table (view-table table))) - (tables-equal (table-a table-b) - (when (and table-a table-b) - (string= (string (slot-value table-a 'name)) - (string (slot-value table-b 'name)))))) + (flet ((ref-equal (ref1 ref2) + (string= (sql-output ref1 database) + (sql-output ref2 database))) + (table-sql-expr (table) + (sql-expression :table (view-table table))) + (tables-equal (table-a table-b) + (when (and table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name)))))) (remf args :from) (remf args :where) (remf args :flatp) @@ -945,89 +995,89 @@ a list of lists. If FLATP is t and only one result is returned for each record selected in the query, the results are returned as elements of a list." - (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) - (unless (or *default-database* (getf qualifier-args :database)) - (signal-no-database-error nil)) - - (cond - ((select-objects target-args) - (let ((caching (getf qualifier-args :caching t)) - (result-types (getf qualifier-args :result-types :auto)) - (refresh (getf qualifier-args :refresh nil)) - (database (or (getf qualifier-args :database) *default-database*)) - (order-by (getf qualifier-args :order-by))) - (remf qualifier-args :caching) - (remf qualifier-args :refresh) - (remf qualifier-args :result-types) - - - ;; Add explicity table name to order-by if not specified and only - ;; one selected table. This is required so FIND-ALL won't duplicate - ;; the field - (when (and order-by (= 1 (length target-args))) - (let ((table-name (view-table (find-class (car target-args)))) - (order-by-list (copy-seq (listify order-by)))) - - (loop for i from 0 below (length order-by-list) - do (etypecase (nth i order-by-list) - (sql-ident-attribute - (unless (slot-value (nth i order-by-list) 'qualifier) - (setf (slot-value (nth i order-by-list) 'qualifier) table-name))) - (cons - (unless (slot-value (car (nth i order-by-list)) 'qualifier) - (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name))))) - (setf (getf qualifier-args :order-by) order-by-list))) - - (cond - ((null caching) - (apply #'find-all target-args - (append qualifier-args (list :result-types result-types)))) - (t - (let ((cached (records-cache-results target-args qualifier-args database))) - (cond - ((and cached (not refresh)) - cached) - ((and cached refresh) - (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto))))) - (setf (records-cache-results target-args qualifier-args database) results) - results)) - (t - (let ((results (apply #'find-all target-args (append qualifier-args - '(:result-types :auto))))) - (setf (records-cache-results target-args qualifier-args database) results) - results)))))))) - (t - (let* ((expr (apply #'make-query select-all-args)) - (specified-types - (mapcar #'(lambda (attrib) - (if (typep attrib 'sql-ident-attribute) - (let ((type (slot-value attrib 'type))) - (if type - type - t)) - t)) - (slot-value expr 'selections)))) - (destructuring-bind (&key (flatp nil) - (result-types :auto) - (field-names t) - (database *default-database*) - &allow-other-keys) - qualifier-args - (query expr :flatp flatp - :result-types - ;; specifying a type for an attribute overrides result-types - (if (some #'(lambda (x) (not (eq t x))) specified-types) - specified-types - result-types) - :field-names field-names - :database database)))))))) + (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) + (unless (or *default-database* (getf qualifier-args :database)) + (signal-no-database-error nil)) + + (cond + ((select-objects target-args) + (let ((caching (getf qualifier-args :caching t)) + (result-types (getf qualifier-args :result-types :auto)) + (refresh (getf qualifier-args :refresh nil)) + (database (or (getf qualifier-args :database) *default-database*)) + (order-by (getf qualifier-args :order-by))) + (remf qualifier-args :caching) + (remf qualifier-args :refresh) + (remf qualifier-args :result-types) + + ;; Add explicity table name to order-by if not specified and only + ;; one selected table. This is required so FIND-ALL won't duplicate + ;; the field + (when (and order-by (= 1 (length target-args))) + (let ((table-name (view-table (find-class (car target-args)))) + (order-by-list (copy-seq (listify order-by)))) + + (loop for i from 0 below (length order-by-list) + do (etypecase (nth i order-by-list) + (sql-ident-attribute + (unless (slot-value (nth i order-by-list) 'qualifier) + (setf (slot-value (nth i order-by-list) 'qualifier) table-name))) + (cons + (unless (slot-value (car (nth i order-by-list)) 'qualifier) + (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name))))) + (setf (getf qualifier-args :order-by) order-by-list))) + + (cond + ((null caching) + (apply #'find-all target-args + (append qualifier-args + (list :result-types result-types :refresh refresh)))) + (t + (let ((cached (records-cache-results target-args qualifier-args database))) + (cond + ((and cached (not refresh)) + cached) + ((and cached refresh) + (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto :refresh ,refresh))))) + (setf (records-cache-results target-args qualifier-args database) results) + results)) + (t + (let ((results (apply #'find-all target-args (append qualifier-args + `(:result-types :auto :refresh ,refresh))))) + (setf (records-cache-results target-args qualifier-args database) results) + results)))))))) + (t + (let* ((expr (apply #'make-query select-all-args)) + (specified-types + (mapcar #'(lambda (attrib) + (if (typep attrib 'sql-ident-attribute) + (let ((type (slot-value attrib 'type))) + (if type + type + t)) + t)) + (slot-value expr 'selections)))) + (destructuring-bind (&key (flatp nil) + (result-types :auto) + (field-names t) + (database *default-database*) + &allow-other-keys) + qualifier-args + (query expr :flatp flatp + :result-types + ;; specifying a type for an attribute overrides result-types + (if (some #'(lambda (x) (not (eq t x))) specified-types) + specified-types + result-types) + :field-names field-names + :database database)))))))) (defun compute-records-cache-key (targets qualifiers) (list targets @@ -1052,9 +1102,34 @@ as elements of a list." (unless (record-caches database) (setf (record-caches database) (make-hash-table :test 'equal - #+allegro :values #+allegro :weak))) + #+allegro :values #+allegro :weak + #+lispworks :weak-kind #+lispworks :value))) (setf (gethash (compute-records-cache-key targets qualifiers) (record-caches database)) results) results) + +;;; Serialization functions + +(defun write-instance-to-stream (obj stream) + "Writes an instance to a stream where it can be later be read. +NOTE: an error will occur if a slot holds a value which can not be written readably." + (let* ((class (class-of obj)) + (alist '())) + (dolist (slot (ordered-class-slots (class-of obj))) + (let ((name (slot-definition-name slot))) + (when (and (not (eq 'view-database name)) + (slot-boundp obj name)) + (push (cons name (slot-value obj name)) alist)))) + (setq alist (reverse alist)) + (write (cons (class-name class) alist) :stream stream :readably t)) + obj) + +(defun read-instance-from-stream (stream) + (let ((raw (read stream nil nil))) + (when raw + (let ((obj (make-instance (car raw)))) + (dolist (pair (cdr raw)) + (setf (slot-value obj (car pair)) (cdr pair))) + obj))))