X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fsql.lisp;h=057c135774ae2b4252c275bfa469ad2b8426b3a9;hp=273b8498d55eff1982ef69dd46aa397125b42640;hb=4c89485f5cdb21a334de9c35adfded30db0c75e7;hpb=b43e20a168dae4ae9d176ebc0fbf18ea6e4517dc diff --git a/sql/sql.lisp b/sql/sql.lisp index 273b849..057c135 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 @@ -32,11 +32,24 @@ (query (sql-output expr database) :database database :flatp flatp :result-types result-types :field-names field-names)) +(defmethod query ((expr sql-object-query) &key (database *default-database*) + (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) + (list :refresh (sql-output expr database))) + (when (or flatp (slot-value expr 'flatp) ) + (list :flatp t)) + (list :database database)))) + (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 (eq :oracle (database-type database)) + (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database))) (when (db-type-has-views? (database-underlying-type database)) (dolist (view (list-views :database database)) (drop-view view :database database))) @@ -49,18 +62,25 @@ (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) (database *default-database*)) - "The PRINT-QUERY function takes a symbolic SQL query expression and -formatting information and prints onto STREAM a table containing the -results of the query. A list of strings to use as column headings is -given by TITLES, which has a default value of NIL. The FORMATS -argument is a list of format strings used to print each attribute, and -has a default value of T, which means that ~A or ~VA are used if sizes -are provided or computed. The field sizes are given by SIZES. It has a -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." + "Prints a tabular report of the results returned by the SQL +query QUERY-EXP, which may be a symbolic SQL expression or a +string, in DATABASE which defaults to *DEFAULT-DATABASE*. The +report is printed onto STREAM which has a default value of t +which means that *STANDARD-OUTPUT* is used. The TITLE argument, +which defaults to nil, allows the specification of a list of +strings to use as column titles in the tabular output. SIZES +accepts a list of column sizes, one for each column selected by +QUERY-EXP, to use in formatting the tabular report. The default +value of t means that minimum sizes are computed. FORMATS is a +list of format strings to be used for printing each column +selected by QUERY-EXP. The default value of FORMATS is t meaning +that ~A is used to format all columns or ~VA if column sizes are +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 @@ -69,7 +89,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))) @@ -86,14 +107,21 @@ value of T. This specifies that *STANDARD-OUTPUT* is used." (av-pairs nil) (query nil) (database *default-database*)) - "Inserts a set of values into a table. The records created contain -values for attributes (or av-pairs). The argument VALUES is a list of -values. If ATTRIBUTES is supplied then VALUES must be a corresponding -list of values for each of the listed attribute names. If AV-PAIRS is -non-nil, then both ATTRIBUTES and VALUES must be nil. If QUERY is -non-nil, then neither VALUES nor AV-PAIRS should be. QUERY should be a -query expression, and the attribute names in it must also exist in the -table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." + "Inserts records into the table specified by INTO in DATABASE +which defaults to *DEFAULT-DATABASE*. There are five ways of +specifying the values inserted into each row. In the first VALUES +contains a list of values to insert and ATTRIBUTES, AV-PAIRS and +QUERY are nil. This can be used when values are supplied for all +attributes in INTO. In the second, ATTRIBUTES is a list of column +names, VALUES is a corresponding list of values and AV-PAIRS and +QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil +and AV-PAIRS is an alist of (attribute value) pairs. In the +fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a +symbolic SQL query expression in which the selected columns also +exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil +and ATTRIBUTES is a list of column names and QUERY is a symbolic +SQL query expression which returns values for the specified +columns." (let ((stmt (make-sql-insert :into into :attrs attributes :vals values :av-pairs av-pairs :subquery query))) @@ -105,7 +133,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 @@ -123,17 +151,16 @@ 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) (where nil) (database *default-database*)) - "Deletes rows from a database table specified by FROM in which the -WHERE condition is true. The argument DATABASE specifies a database -from which the records are to be removed, and defaults to -*default-database*." + "Deletes records satisfying the SQL expression WHERE from the +table specified by FROM in DATABASE specifies a database which +defaults to *DEFAULT-DATABASE*." (let ((stmt (make-instance 'sql-delete :from from :where where))) (execute-command stmt :database database))) @@ -142,9 +169,17 @@ from which the records are to be removed, and defaults to (av-pairs nil) (where nil) (database *default-database*)) - "Changes the values of existing fields in TABLE with columns -specified by ATTRIBUTES and VALUES (or AV-PAIRS) where the WHERE -condition is true." + "Updates the attribute values of existing records satsifying +the SQL expression WHERE in the table specified by TABLE in +DATABASE which defaults to *DEFAULT-DATABASE*. There are three +ways of specifying the values to update for each row. In the +first, VALUES contains a list of values to use in the update and +ATTRIBUTES, AV-PAIRS and QUERY are nil. This can be used when +values are supplied for all attributes in TABLE. In the second, +ATTRIBUTES is a list of column names, VALUES is a corresponding +list of values and AV-PAIRS and QUERY are nil. In the third, +ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is an alist +of (attribute value) pairs." (when av-pairs (setf attributes (mapcar #'car av-pairs) values (mapcar #'cadr av-pairs))) @@ -228,10 +263,11 @@ condition is true." (if (or (null thing) (eq 'null thing)) "NULL" - (error 'clsql-simple-error - :format-control - "No type conversion to SQL for ~A is defined for DB ~A." - :format-arguments (list (type-of thing) (type-of database))))) + (error 'sql-user-error + :message + (format nil + "No type conversion to SQL for ~A is defined for DB ~A." + (type-of thing) (type-of database))))) (defmethod output-sql-hash-key ((arg vector) database) @@ -272,3 +308,239 @@ condition is true." (when sequence (create-sequence-from-class class))))) +;;; Iteration + + +(defmacro do-query (((&rest args) query-expression + &key (database '*default-database*) (result-types :auto)) + &body body) + "Repeatedly executes BODY within a binding of ARGS on the +fields of each row selected by the SQL query QUERY-EXPRESSION, +which may be a string or a symbolic SQL expression, in DATABASE +which defaults to *DEFAULT-DATABASE*. The values returned by the +execution of BODY are returned. RESULT-TYPES is a list of symbols +which specifies the lisp type for each field returned by +QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned +as strings whereas the default value of :auto means that the lisp +types are automatically computed for each field." + (let ((result-set (gensym "RESULT-SET-")) + (qe (gensym "QUERY-EXPRESSION-")) + (columns (gensym "COLUMNS-")) + (row (gensym "ROW-")) + (db (gensym "DB-"))) + `(let ((,qe ,query-expression)) + (typecase ,qe + (sql-object-query + (dolist (,row (query ,qe)) + (destructuring-bind ,args + ,row + ,@body))) + (t + ;; Functional query + (let ((,db ,database)) + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,qe ,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 :auto)) + "Map the function FUNCTION over the attribute values of each +row selected by the SQL query QUERY-EXPRESSION, which may be a +string or a symbolic SQL expression, in DATABASE which defaults +to *DEFAULT-DATABASE*. The results of the function are collected +as specified in OUTPUT-TYPE-SPEC and returned like in +MAP. RESULT-TYPES is a list of symbols which specifies the lisp +type for each field returned by QUERY-EXPRESSION. If RESULT-TYPES +is nil all results are returned as strings whereas the default +value of :auto means that the lisp types are automatically +computed for each field." + (typecase query-expression + (sql-object-query + (map output-type-spec #'(lambda (x) (apply function x)) + (query query-expression))) + (t + ;; Functional query + (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) + (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) + (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) + (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)))))) + + +