;;;; -*- 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
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
(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)))))
+
+
projects / clsql.git / blobdiff