From 90011694c27b5b22673a34cb6948a2a721a9b6cd Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 5 May 2004 15:02:31 +0000 Subject: [PATCH 1/1] r9250: make :target-slot joins many times more efficient --- ChangeLog | 4 ++++ TODO | 5 ----- sql/classes.lisp | 31 ++++++++++++++++++++-------- sql/objects.lisp | 49 +++++++++++++++++++++++++++++++++++++------- tests/test-init.lisp | 7 +++++++ 5 files changed, 76 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index 540d6b6..9f02b2a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,10 @@ * TODO: New section on optimizations, especially optimizing JOINs. * sql/objects.lisp: Have :target-slot return of list of lists rather than a list of cons pairs to be conformant with CommonSQL. + Make :target-slot much more efficient by using a SQL inner join + statement and just requiring one SQL query. + * sql/classes.lisp: Add :inner-join and :on slots to sql-query class + and process them for query output-sql. 4 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.10.11 diff --git a/TODO b/TODO index fee5fe3..04aa9d9 100644 --- a/TODO +++ b/TODO @@ -47,11 +47,6 @@ COMMONSQL SPEC OPTIMIZATIONS * Revisit result-type list creation,perhaps caching -* Use an inner join for :target-slot in SELECTS rather than multiple - queries. For example, in the test suite: - SELECT address.addressid,address.street_number,... FROM address - INNER JOIN employee_address ON employe_address.address_id=address.address_id - AND emplid= POSSIBLE EXTENSIONS diff --git a/sql/classes.lisp b/sql/classes.lisp index 4c11dbe..1be0e0b 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -417,6 +417,12 @@ :initform nil) (order-by-descending :initarg :order-by-descending + :initform nil) + (inner-join + :initarg :inner-join + :initform nil) + (on + :initarg :on :initform nil)) (:documentation "An SQL SELECT query.")) @@ -428,7 +434,8 @@ (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by - :order-by-descending :set-operation :where :offset :limit)) + :order-by-descending :set-operation :where :offset :limit + :inner-join :on)) (defun query-arg-p (sym) (member sym *select-arguments*)) @@ -455,7 +462,7 @@ uninclusive, and the args from that keyword to the end." (apply #'select args) (destructuring-bind (&key all flatp set-operation distinct from where group-by having order-by order-by-descending - offset limit &allow-other-keys) + offset limit inner-join on &allow-other-keys) arglist (if (null selections) (error "No target columns supplied to select statement.")) @@ -466,13 +473,14 @@ uninclusive, and the args from that keyword to the end." :distinct distinct :from from :where where :limit limit :offset offset :group-by group-by :having having :order-by order-by - :order-by-descending order-by-descending)))))) + :order-by-descending order-by-descending + :inner-join inner-join :on on)))))) (defvar *in-subselect* nil) (defmethod output-sql ((query sql-query) database) (with-slots (distinct selections from where group-by having order-by - order-by-descending limit offset) + order-by-descending limit offset inner-join on) query (when *in-subselect* (write-string "(" *sql-stream*)) @@ -484,10 +492,17 @@ uninclusive, and the args from that keyword to the end." (output-sql distinct database) (write-char #\Space *sql-stream*))) (output-sql (apply #'vector selections) database) - (write-string " FROM " *sql-stream*) - (if (listp from) - (output-sql (apply #'vector from) database) - (output-sql from database)) + (when from + (write-string " FROM " *sql-stream*) + (if (listp from) + (output-sql (apply #'vector from) database) + (output-sql from database))) + (when inner-join + (write-string " INNER JOIN " *sql-stream*) + (output-sql inner-join database)) + (when on + (write-string " ON " *sql-stream*) + (output-sql on database)) (when where (write-string " WHERE " *sql-stream*) (let ((*in-subselect* t)) diff --git a/sql/objects.lisp b/sql/objects.lisp index 9641c51..e72e53a 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -712,7 +712,9 @@ superclass of the newly-defined View Class." (when jq (select jc :where jq :flatp t :result-types nil))))) -;; FIXME: Create a single join query for efficiency +;; this works, but is inefficient requiring (+ 1 n-rows) +;; SQL queries +#+ignore (defun fault-join-target-slot (class object slot-def) (let* ((res (fault-join-slot-raw class object slot-def)) (dbi (view-class-slot-db-info slot-def)) @@ -733,6 +735,35 @@ superclass of the newly-defined View Class." (mapcar (lambda (obj) (cons obj (slot-value obj ts))) res)))) +(defun fault-join-target-slot (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (jc (gethash :join-class dbi)) + (tdbi (view-class-slot-db-info + (find ts (class-slots (find-class jc)) + :key #'slot-definition-name))) + (jq (join-qualifier class object slot-def)) + (key (slot-value object (gethash :home-key dbi)))) + (when jq + (let ((res + (find-all (list ts) + :inner-join (sql-expression :attribute jc) + :on (sql-operation + '== + (sql-expression :attribute (gethash :foreign-key tdbi) :table ts) + (sql-expression :attribute (gethash :home-key tdbi) :table jc)) + :where jq + :result-types :auto))) + (mapcar #'(lambda (i) + (let* ((instance (car i)) + (jcc (make-instance jc :view-database (view-database instance)))) + (setf (slot-value jcc (gethash :foreign-key dbi)) + key) + (setf (slot-value jcc (gethash :home-key tdbi)) + (slot-value instance (gethash :foreign-key tdbi))) + (list instance jcc))) + res))))) + (defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) (ts (gethash :target-slot dbi))) @@ -787,15 +818,19 @@ superclass of the newly-defined View Class." (apply #'sql-and jc) jc)))))) -(defun find-all (view-classes &rest args &key all set-operation distinct from - where group-by having order-by order-by-descending offset limit - refresh flatp result-types (database *default-database*)) +(defun find-all (view-classes + &rest args + &key all set-operation distinct from where group-by having + order-by order-by-descending offset limit refresh + flatp result-types inner-join on + (database *default-database*)) "Called by SELECT to generate object query results when the View Classes VIEW-CLASSES are passed as arguments to SELECT." - (declare (ignore all set-operation group-by having offset limit result-types) + (declare (ignore all set-operation group-by having offset limit inner-join on) (optimize (debug 3) (speed 1))) (remf args :from) (remf args :flatp) + (remf args :additional-fields) (remf args :result-types) (labels ((table-sql-expr (table) (sql-expression :table (view-table table))) @@ -861,7 +896,7 @@ superclass of the newly-defined View Class." (cons :from (list (append (when from (listify from)) (listify tables)))) - (list :result-types nil) + (list :result-types result-types) args))) (mapcar #'(lambda (r) (build-objects r sclasses sels)) res)))) @@ -907,7 +942,7 @@ ENABLE-SQL-READER-SYNTAX." (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) (if (select-objects target-args) - (apply #'find-all target-args qualifier-args) + (apply #'find-all target-args qualifier-args) (let* ((expr (apply #'make-query select-all-args)) (specified-types (mapcar #'(lambda (attrib) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index f4268d7..41437f5 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -542,3 +542,10 @@ (push test-form test-forms))))) (values (nreverse test-forms) (nreverse skip-tests)))) + +(defun rl () + "Rapid load for interactive testing." + (when *default-database* + (disconnect :database *default-database*)) + (test-connect-to-database :postgresql (car (postgresql-spec (read-specs)))) + (test-initialise-database)) -- 2.34.1