X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=d76712c2d6e7726c65b91675fb5ab65fc29a71c9;hp=82f166e1da642108a48556f958bf90abf61c143e;hb=cc1360674fe8976074b6af9e5a9aab63cb078fc7;hpb=b08c25a7a9e56fb125caa9f7d7a56a473615007e diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 82f166e..d76712c 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -248,7 +248,9 @@ (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 (record-caches vd) nil) + (setf (slot-value instance 'view-database) nil) + (values)) (signal-no-database-error vd)))) (defmethod update-instance-from-records ((instance standard-db-object) @@ -307,17 +309,39 @@ (sql-expression :table (view-table class)))) -(defparameter *default-varchar-length* 255) - (defmethod database-get-type-specifier (type args database db-type) (declare (ignore type args database db-type)) - (format nil "VARCHAR(~D)" *default-varchar-length*)) + (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 mediumint () + "An integer smaller than a 32-bit integer, but may be larger than a smallint. This width may vary by SQL implementation." + 'integer) + +(defmethod database-get-type-specifier ((type (eql 'mediumint)) 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." @@ -327,8 +351,9 @@ (declare (ignore args database db-type)) "BIGINT") -(deftype varchar () +(deftype varchar (&optional size) "A variable length string for the SQL varchar type." + (declare (ignore size)) 'string) (defmethod database-get-type-specifier ((type (eql 'varchar)) args @@ -336,13 +361,13 @@ (declare (ignore database db-type)) (if args (format nil "VARCHAR(~A)" (car args)) - (format nil "VARCHAR(~D)" *default-varchar-length*))) + (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 "CHAR(~A)" (car args)) - (format nil "VARCHAR(~D)" *default-varchar-length*))) + (format nil "VARCHAR(~D)" *default-string-length*))) (deftype universal-time () "A positive integer as returned by GET-UNIVERSAL-TIME." @@ -458,13 +483,17 @@ (declare (ignore database db-type)) val) -(defmethod database-output-sql-as-type ((type (eql 'char)) - val database db-type) +(defmethod database-output-sql-as-type ((type (eql 'char)) val database db-type) (declare (ignore database db-type)) (etypecase val (character (write-to-string val)) (string val))) +(defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type) + (declare (ignore database db-type)) + (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)) (read-from-string val)) @@ -501,6 +530,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 @@ -606,7 +643,8 @@ :attribute (gethash :home-key tdbi) :table jc-view-table)) :where jq - :result-types :auto))) + :result-types :auto + :database (view-database object)))) (mapcar #'(lambda (i) (let* ((instance (car i)) (jcc (make-instance jc :view-database (view-database instance)))) @@ -631,7 +669,8 @@ (list instance jcc))) (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table) :from (sql-expression :table jc-view-table) - :where jq))))))) + :where jq + :database (view-database object)))))))) ;;; Remote Joins @@ -701,21 +740,29 @@ maximum of MAX-LEN instances updated in each query." keys)) :result-types :auto :flatp t))) + (dolist (object objects) (when (or force-p (not (slot-boundp object slotdef-name))) - (let ((res (find (slot-value object home-key) results - :key #'(lambda (res) (slot-value res foreign-key)) - :test #'equal))) + (let ((res (remove-if-not #'(lambda (obj) + (equal obj (slot-value + object + home-key))) + results + :key #'(lambda (res) + (slot-value res + foreign-key))))) (when res - (setf (slot-value object slotdef-name) res))))))))))) + (setf (slot-value object slotdef-name) + (if (gethash :set dbi) res (car res))))))))))))) (values)) - + (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 :flatp t :result-types nil))))) + (select jc :where jq :flatp t :result-types nil + :database (view-database object)))))) (defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) @@ -784,10 +831,29 @@ maximum of MAX-LEN instances updated in each query." (join-vals (subseq vals (list-length selects))) (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database))) jclasses))) - ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals) + + ;;(format t "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%" + ;;joins db-vals join-vals selects immediate-selects) + ;; use refresh keyword here (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals)) - (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals)) + (mapc #'(lambda (jo) + ;; find all immediate-select slots and join-vals for this object + (let* ((slots (class-slots (class-of jo))) + (pos-list (remove-if #'null + (mapcar + #'(lambda (s) + (position s immediate-selects + :key #'car + :test #'eq)) + slots)))) + (get-slot-values-from-view jo + (mapcar #'car + (mapcar #'(lambda (pos) + (nth pos immediate-selects)) + pos-list)) + (mapcar #'(lambda (pos) (nth pos join-vals)) + pos-list)))) joins) (mapc #'(lambda (jc) @@ -824,15 +890,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) @@ -854,17 +920,22 @@ maximum of MAX-LEN instances updated in each query." (fullsels (apply #'append (mapcar #'append sels immediate-join-sels))) (sel-tables (collect-table-refs where)) (tables (remove-if #'null - (remove-duplicates (append (mapcar #'table-sql-expr sclasses) - (mapcar #'(lambda (jcs) - (mapcan #'(lambda (jc) - (when jc (table-sql-expr jc))) - jcs)) - immediate-join-classes) - sel-tables) - :test #'tables-equal))) + (remove-duplicates + (append (mapcar #'table-sql-expr sclasses) + (mapcan #'(lambda (jc-list) + (mapcar + #'(lambda (jc) (when jc (table-sql-expr jc))) + jc-list)) + immediate-join-classes) + sel-tables) + :test #'tables-equal))) (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob))) - (listify order-by)))) - + (listify order-by))) + (join-where nil)) + + + ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables) + (dolist (ob order-by-slots) (when (and ob (not (member ob (mapcar #'cdr fullsels) :test #'ref-equal))) @@ -883,25 +954,34 @@ maximum of MAX-LEN instances updated in each query." (mapcar #'(lambda (jclass jslot) (let ((dbi (view-class-slot-db-info jslot))) - (setq where - (append - (list (sql-operation '== - (sql-expression - :attribute (gethash :foreign-key dbi) - :table (view-table jclass)) - (sql-expression - :attribute (gethash :home-key dbi) - :table (view-table vclass)))) - (when where (listify where)))))) + (setq join-where + (append + (list (sql-operation '== + (sql-expression + :attribute (gethash :foreign-key dbi) + :table (view-table jclass)) + (sql-expression + :attribute (gethash :home-key dbi) + :table (view-table vclass)))) + (when join-where (listify join-where)))))) jclasses jslots))) sclasses immediate-join-classes immediate-join-slots) + (when where + (setq where (listify where))) + (cond + ((and where join-where) + (setq where (list (apply #'sql-and where join-where)))) + ((and (null where) (> (length join-where) 1)) + (setq where (list (apply #'sql-and join-where))))) + (let* ((rows (apply #'select (append (mapcar #'cdr fullsels) (cons :from (list (append (when from (listify from)) (listify tables)))) (list :result-types result-types) - (when where (list :where where)) + (when where + (list :where where)) args))) (instances-to-add (- (length rows) (length instances))) (perhaps-extended-instances @@ -923,6 +1003,10 @@ maximum of MAX-LEN instances updated in each query." (defmethod instance-refreshed ((instance standard-db-object))) +(defvar *default-caching* t + "Controls whether SELECT caches objects by default. The CommonSQL +specification states caching is on by default.") + (defun select (&rest select-all-args) "Executes a query on DATABASE, which has a default value of *DEFAULT-DATABASE*, specified by the SQL expressions supplied @@ -968,89 +1052,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 *default-caching*)) + (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 @@ -1075,7 +1159,9 @@ 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 + #+clisp :weak #+clisp :value + #+lispworks :weak-kind #+lispworks :value))) (setf (gethash (compute-records-cache-key targets qualifiers) (record-caches database)) results) results)