X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fsql.lisp;h=6bc454724621bf4adbbc76ddfdbae63caff5b9a3;hb=5be31565b7d87b90f0e79a9e61af84ad05e12920;hp=ae4da839514b7b8b32b0a32ee9f696308b41aa85;hpb=8a8ee2d7d791b7a3efaed06420802a925d16fca3;p=clsql.git diff --git a/sql/sql.lisp b/sql/sql.lisp index ae4da83..6bc4547 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -33,8 +33,8 @@ :result-types result-types :field-names field-names)) (defmethod query ((expr sql-object-query) &key (database *default-database*) - (result-types :auto) (flatp nil)) - (declare (ignore result-types)) + (result-types :auto) (flatp nil) (field-names t)) + (declare (ignore result-types field-names)) (apply #'select (append (slot-value expr 'objects) (slot-value expr 'exp) (when (slot-value expr 'refresh) @@ -71,7 +71,10 @@ default value of T, which specifies that minimum sizes are computed. The output stream is given by STREAM, which has a default value of T. This specifies that *STANDARD-OUTPUT* is used." (flet ((compute-sizes (data) - (mapcar #'(lambda (x) (apply #'max (mapcar #'length x))) + (mapcar #'(lambda (x) + (apply #'max (mapcar #'(lambda (y) + (if (null y) 3 (length y))) + x))) (apply #'mapcar (cons #'list data)))) (format-record (record control sizes) (format stream "~&~?" control @@ -80,7 +83,8 @@ value of T. This specifies that *STANDARD-OUTPUT* is used." (let* ((query-exp (etypecase query-exp (string query-exp) (sql-query (sql-output query-exp database)))) - (data (query query-exp :database database)) + (data (query query-exp :database database :result-types nil + :field-names nil)) (sizes (if (or (null sizes) (listp sizes)) sizes (compute-sizes (if titles (cons titles data) data)))) (formats (if (or (null formats) (not (listp formats))) @@ -357,62 +361,85 @@ MAP." (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))))) + (let ((flatp (and (= columns 1) + (typecase query-expression + (string t) + (sql-query + (slot-value query-expression 'flatp)))))) + (when result-set + (unwind-protect + (do ((row (make-list columns))) + ((not (database-store-next-row result-set database row)) + nil) + (if flatp + (apply function row) + (funcall 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))))) - + (let ((flatp (and (= columns 1) + (typecase query-expression + (string t) + (sql-query + (slot-value query-expression 'flatp)))))) + (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 (if flatp + (apply function row) + (funcall function (copy-list 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))))) + (let ((flatp (and (= columns 1) + (typecase query-expression + (string t) + (sql-query + (slot-value query-expression 'flatp)))))) + (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) + (if flatp + (apply function row) + (funcall function (copy-list 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) + (if flatp + (apply function row) + (funcall function (copy-list row)))))) + (database-dump-result-set result-set database)))))) ;;; Row processing macro from CLSQL