X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fsql.lisp;h=ae4da839514b7b8b32b0a32ee9f696308b41aa85;hp=e18452e35dc6941a30de6c10d689bf60ab75ccd3;hb=8a8ee2d7d791b7a3efaed06420802a925d16fca3;hpb=5a6f424f3c8920f8f11bbf1e3aed6b4c2c7e6af8 diff --git a/sql/sql.lisp b/sql/sql.lisp index e18452e..ae4da83 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -1,26 +1,25 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: sql.lisp -;;;; Updated: <04/04/2004 12:05:32 marcusp> -;;;; ====================================================================== +;;;; ************************************************************************* ;;;; -;;;; Description ========================================================== -;;;; ====================================================================== +;;;; $Id$ ;;;; ;;;; The CLSQL Functional Data Manipulation Language (FDML). ;;;; -;;;; ====================================================================== +;;;; 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-sys) - ;;; Basic operations on databases - (defmethod database-query-result-set ((expr %sql-expression) database - &key full-set types) + &key full-set result-types) (database-query-result-set (sql-output expr database) database - :full-set full-set :types types)) + :full-set full-set :result-types result-types)) (defmethod execute-command ((expr %sql-expression) &key (database *default-database*)) @@ -28,11 +27,36 @@ (values)) - (defmethod query ((expr %sql-expression) &key (database *default-database*) - (result-types nil) (flatp nil)) + (result-types :auto) (flatp nil) (field-names t)) (query (sql-output expr database) :database database :flatp flatp - :result-types result-types)) + :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)) + (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) + (signal-no-database-error database)) + (unless (is-database-open database) + (database-reconnect database)) + (when (db-type-has-views? (database-underlying-type database)) + (dolist (view (list-views :database database)) + (drop-view view :database database))) + (dolist (table (list-tables :database database)) + (drop-table table :database database)) + (dolist (index (list-indexes :database database)) + (drop-index index :database database)) + (dolist (seq (list-sequences :database database)) + (drop-sequence seq :database database))) (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) (database *default-database*)) @@ -55,7 +79,7 @@ value of T. This specifies that *STANDARD-OUTPUT* is used." (mapcan #'(lambda (s f) (list s f)) sizes record))))) (let* ((query-exp (etypecase query-exp (string query-exp) - (sql-query (sql-output query-exp)))) + (sql-query (sql-output query-exp database)))) (data (query query-exp :database database)) (sizes (if (or (null sizes) (listp sizes)) sizes (compute-sizes (if titles (cons titles data) data)))) @@ -91,11 +115,11 @@ table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." (vals nil) (av-pairs nil) (subquery nil)) - (if (null into) + (unless into (error 'clsql-sql-syntax-error :reason ":into keyword not supplied")) - (let ((ins (make-instance 'sql-insert :into into))) + (let ((insert (make-instance 'sql-insert :into into))) (with-slots (attributes values query) - ins + insert (cond ((and vals (not attrs) (not query) (not av-pairs)) (setf values vals)) ((and vals attrs (not subquery) (not av-pairs)) @@ -112,7 +136,7 @@ table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." (t (error 'clsql-sql-syntax-error :reason "bad or ambiguous keyword combination."))) - ins))) + insert))) (defun delete-records (&key (from nil) (where nil) @@ -124,12 +148,11 @@ from which the records are to be removed, and defaults to (let ((stmt (make-instance 'sql-delete :from from :where where))) (execute-command stmt :database database))) -(defun update-records (table &key - (attributes nil) - (values nil) - (av-pairs nil) - (where nil) - (database *default-database*)) +(defun update-records (table &key (attributes nil) + (values nil) + (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." @@ -178,10 +201,11 @@ condition is true." (let ((keyword-package (symbol-package :foo))) (defmethod database-output-sql ((sym symbol) database) - (declare (ignore database)) - (if (equal (symbol-package sym) keyword-package) - (concatenate 'string "'" (string sym) "'") - (symbol-name sym)))) + (convert-to-db-default-case + (if (equal (symbol-package sym) keyword-package) + (concatenate 'string "'" (string sym) "'") + (symbol-name sym)) + database))) (defmethod database-output-sql ((tee (eql t)) database) (declare (ignore database)) @@ -207,6 +231,10 @@ condition is true." (declare (ignore database)) (db-timestring self)) +(defmethod database-output-sql ((self duration) database) + (declare (ignore database)) + (format nil "'~a'" (duration-timestring self))) + (defmethod database-output-sql (thing database) (if (or (null thing) (eq 'null thing)) @@ -216,17 +244,18 @@ condition is true." "No type conversion to SQL for ~A is defined for DB ~A." :format-arguments (list (type-of thing) (type-of database))))) -(defmethod output-sql-hash-key ((arg vector) &optional database) + +(defmethod output-sql-hash-key ((arg vector) database) (list 'vector (map 'list (lambda (arg) (or (output-sql-hash-key arg database) (return-from output-sql-hash-key nil))) arg))) -(defmethod output-sql (expr &optional (database *default-database*)) +(defmethod output-sql (expr database) (write-string (database-output-sql expr database) *sql-stream*) - t) + (values)) -(defmethod output-sql ((expr list) &optional (database *default-database*)) +(defmethod output-sql ((expr list) database) (if (null expr) (write-string +null-string+ *sql-stream*) (progn @@ -239,4 +268,220 @@ condition is true." (write-char #\) *sql-stream*))) t) +(defmethod describe-table ((table sql-create-table) + &key (database *default-database*)) + (database-describe-table + database + (convert-to-db-default-case + (symbol-name (slot-value table 'name)) database))) + +#+nil +(defmethod add-storage-class ((self database) (class symbol) &key (sequence t)) + (let ((tablename (view-table (find-class class)))) + (unless (tablep tablename) + (create-view-from-class class) + (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 +attributes of each record resulting from QUERY-EXPRESSION. The +return value is determined by the result of executing BODY. The +default value of DATABASE is *DEFAULT-DATABASE*." + (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 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." + (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) + (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))))) + +;;; 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)))))) + +