X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=base%2Fbasic-sql.lisp;h=eaccc03315e1770b8139e0be2a10cbd27bd7a757;hp=df5d93b840c27ae9218718668b9bc5e0b5294806;hb=9bbed78051e80e6ab76ae47834136035602bbbf1;hpb=ce0e343835a040406678dff74a62d1b0cb56f317 diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp index df5d93b..eaccc03 100644 --- a/base/basic-sql.lisp +++ b/base/basic-sql.lisp @@ -1,8 +1,18 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* -;;;; $Id: $ +;;;; +;;;; $Id$ +;;;; +;;;; Base SQL functions +;;;; +;;;; 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-base-sys) +(in-package #:clsql-base) ;;; Query @@ -20,16 +30,17 @@ one result per row. Returns a list of lists of values of the result of that expression and a list of field names selected in sql-exp.")) (defmethod query ((query-expression string) &key (database *default-database*) - (result-types nil) (flatp nil)) - (record-sql-command query-expression database) - (let* ((res (database-query query-expression database result-types)) - (res (if (and flatp (= (length - (slot-value query-expression 'selections)) - 1)) - (mapcar #'car res) - res))) - (record-sql-result res database) - res)) + (result-types :auto) (flatp nil) (field-names t)) + (record-sql-action query-expression :query database) + (multiple-value-bind (rows names) (database-query query-expression database result-types + field-names) + (let ((result (if (and flatp (= 1 (length (car rows)))) + (mapcar #'car rows) + rows))) + (record-sql-action result :result database) + (if field-names + (values result names) + result)))) ;;; Execute @@ -44,9 +55,116 @@ pair.")) (defmethod execute-command ((sql-expression string) &key (database *default-database*)) - (record-sql-command sql-expression database) + (record-sql-action sql-expression :command database) (let ((res (database-execute-command sql-expression database))) - (record-sql-result res database)) + (record-sql-action res :result database)) (values)) +(defmacro do-query (((&rest args) query-expression + &key (database '*default-database*) (result-types nil)) + &body body) + "Repeatedly executes BODY within a binding of ARGS on the attributes +of each record resulting from QUERY. The return value is determined by +the result of executing BODY. The default value of DATABASE is +*DEFAULT-DATABASE*." + (let ((result-set (gensym)) + (columns (gensym)) + (row (gensym)) + (db (gensym))) + `(let ((,db ,database)) + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,query-expression ,db + :full-set nil :result-types ,result-types) + (when ,result-set + (unwind-protect + (do ((,row (make-list ,columns))) + ((not (database-store-next-row ,result-set ,db ,row)) + nil) + (destructuring-bind ,args ,row + ,@body)) + (database-dump-result-set ,result-set ,db))))))) + +(defun map-query (output-type-spec function query-expression + &key (database *default-database*) + (result-types nil)) + "Map the function over all tuples that are returned by the query in +query-expression. The results of the function are collected as +specified in output-type-spec and returned like in MAP." + (macrolet ((type-specifier-atom (type) + `(if (atom ,type) ,type (car ,type)))) + (case (type-specifier-atom output-type-spec) + ((nil) + (map-query-for-effect function query-expression database result-types)) + (list + (map-query-to-list function query-expression database result-types)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector base-string + simple-base-string) + (map-query-to-simple output-type-spec function query-expression database result-types)) + (t + (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database :result-types result-types))))) + +(defun map-query-for-effect (function query-expression database result-types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :result-types result-types) + (when result-set + (unwind-protect + (do ((row (make-list columns))) + ((not (database-store-next-row result-set database row)) + nil) + (apply function row)) + (database-dump-result-set result-set database))))) + +(defun map-query-to-list (function query-expression database result-types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :result-types result-types) + (when result-set + (unwind-protect + (let ((result (list nil))) + (do ((row (make-list columns)) + (current-cons result (cdr current-cons))) + ((not (database-store-next-row result-set database row)) + (cdr result)) + (rplacd current-cons (list (apply function row))))) + (database-dump-result-set result-set database))))) + + +(defun map-query-to-simple (output-type-spec function query-expression database result-types) + (multiple-value-bind (result-set columns rows) + (database-query-result-set query-expression database :full-set t + :result-types result-types) + (when result-set + (unwind-protect + (if rows + ;; We know the row count in advance, so we allocate once + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec rows)) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + result) + (declare (fixnum index)) + (setf (aref result index) + (apply function row))) + ;; Database can't report row count in advance, so we have + ;; to grow and shrink our vector dynamically + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec 100)) + (allocated-length 100) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + (cmucl-compat:shrink-vector result index)) + (declare (fixnum allocated-length index)) + (when (>= index allocated-length) + (setq allocated-length (* allocated-length 2) + result (adjust-array result allocated-length))) + (setf (aref result index) + (apply function row)))) + (database-dump-result-set result-set database))))) + +