X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fsql.lisp;h=0a0d2f3fef16dc5c4663f6a1c3e2d51d2ff2cd1d;hb=8c6c643e3debe875bd14408cc3129d8148dfd125;hp=0397bd031ca01984702a667bd031bba537fd824c;hpb=279b34c9e8e28545c8f2a0959acb01d90138eeda;p=clsql.git diff --git a/sql/sql.lisp b/sql/sql.lisp index 0397bd0..0a0d2f3 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -12,7 +12,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) ;;; Basic operations on databases @@ -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) @@ -45,7 +45,7 @@ (defun truncate-database (&key (database *default-database*)) (unless (typep database 'database) - (clsql-base::signal-no-database-error database)) + (signal-no-database-error database)) (unless (is-database-open database) (database-reconnect database)) (when (db-type-has-views? (database-underlying-type database)) @@ -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))) @@ -116,7 +120,7 @@ table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." (av-pairs nil) (subquery nil)) (unless into - (error 'clsql-sql-syntax-error :reason ":into keyword not supplied")) + (error 'sql-user-error :message ":into keyword not supplied")) (let ((insert (make-instance 'sql-insert :into into))) (with-slots (attributes values query) insert @@ -134,8 +138,8 @@ table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." (setf attributes attrs) (setf query subquery)) (t - (error 'clsql-sql-syntax-error - :reason "bad or ambiguous keyword combination."))) + (error 'sql-user-error + :message "bad or ambiguous keyword combination."))) insert))) (defun delete-records (&key (from nil) @@ -357,59 +361,154 @@ 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 + +(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body) + (let ((d (gensym "DISTINCT-")) + (bind-fields (loop for f in fields collect (car f))) + (w (gensym "WHERE-")) + (o (gensym "ORDER-BY-")) + (frm (gensym "FROM-")) + (l (gensym "LIMIT-")) + (q (gensym "QUERY-"))) + `(let ((,frm ,from) + (,w ,where) + (,d ,distinct) + (,l ,limit) + (,o ,order-by)) + (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l))) + (loop for tuple in (query ,q) + collect (destructuring-bind ,bind-fields tuple + ,@body)))))) + +(defun query-string (fields from where distinct order-by limit) + (concatenate + 'string + (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" + (if distinct "distinct " "") (field-names fields) + (from-names from)) + (if where (format nil " where ~{~A~^ ~}" + (where-strings where)) "") + (if order-by (format nil " order by ~{~A~^, ~}" + (order-by-strings order-by))) + (if limit (format nil " limit ~D" limit) ""))) + +(defun lisp->sql-name (field) + (typecase field + (string field) + (symbol (string-upcase (symbol-name field))) + (cons (cadr field)) + (t (format nil "~A" field)))) + +(defun field-names (field-forms) + "Return a list of field name strings from a fields form" + (loop for field-form in field-forms + collect + (lisp->sql-name + (if (cadr field-form) + (cadr field-form) + (car field-form))))) + +(defun from-names (from) + "Return a list of field name strings from a fields form" + (loop for table in (if (atom from) (list from) from) + collect (lisp->sql-name table))) + + +(defun where-strings (where) + (loop for w in (if (atom (car where)) (list where) where) + collect + (if (consp w) + (format nil "~A ~A ~A" (second w) (first w) (third w)) + (format nil "~A" w)))) + +(defun order-by-strings (order-by) + (loop for o in order-by + collect + (if (atom o) + (lisp->sql-name o) + (format nil "~A ~A" (lisp->sql-name (car o)) + (lisp->sql-name (cadr o)))))) + + +