X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Ffdml.lisp;h=943a1577ccf3538e50261e4db344d9029706cff3;hp=79fa18ef342bff10d97815b90920b303e5cac1e7;hb=e15b72fefebeee46a83d357db2813031edcc6fbd;hpb=fdd069770e32d0cfa4b66d6e5cfd4540197660ba diff --git a/sql/fdml.lisp b/sql/fdml.lisp index 79fa18e..943a157 100644 --- a/sql/fdml.lisp +++ b/sql/fdml.lisp @@ -62,24 +62,6 @@ (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 (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))) - (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)) - (when (eq :oracle (database-type database)) - (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))) (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) (database *default-database*)) @@ -195,12 +177,11 @@ 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." +ATTRIBUTES and AV-PAIRS 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 is nil. In the third, ATTRIBUTES and VALUES +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))) @@ -211,120 +192,8 @@ of (attribute value) pairs." (execute-command stmt :database database))) -;; iteration - -;; output-sql - -(defmethod database-output-sql ((str string) database) - (declare (ignore database) - (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3)) - (type (simple-array * (*)) str)) - (let ((len (length str))) - (declare (type fixnum len)) - (cond ((= len 0) - +empty-string+) - ((and (null (position #\' str)) - (null (position #\\ str))) - (concatenate 'string "'" str "'")) - (t - (let ((buf (make-string (+ (* len 2) 2) :initial-element #\'))) - (do* ((i 0 (incf i)) - (j 1 (incf j))) - ((= i len) (subseq buf 0 (1+ j))) - (declare (type integer i j)) - (let ((char (aref str i))) - (cond ((eql char #\') - (setf (aref buf j) #\\) - (incf j) - (setf (aref buf j) #\')) - ((eql char #\\) - (setf (aref buf j) #\\) - (incf j) - (setf (aref buf j) #\\)) - (t - (setf (aref buf j) char)))))))))) - -(let ((keyword-package (symbol-package :foo))) - (defmethod database-output-sql ((sym symbol) database) - (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)) - "'Y'") - -(defmethod database-output-sql ((num number) database) - (declare (ignore database)) - (princ-to-string num)) - -(defmethod database-output-sql ((arg list) database) - (if (null arg) - "NULL" - (format nil "(~{~A~^,~})" (mapcar #'(lambda (val) - (sql-output val database)) - arg)))) - -(defmethod database-output-sql ((arg vector) database) - (format nil "~{~A~^,~}" (map 'list #'(lambda (val) - (sql-output val database)) - arg))) - -(defmethod database-output-sql ((self wall-time) database) - (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)) - "NULL" - (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) - (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 database) - (write-string (database-output-sql expr database) *sql-stream*) - (values)) - -(defmethod output-sql ((expr list) database) - (if (null expr) - (write-string +null-string+ *sql-stream*) - (progn - (write-char #\( *sql-stream*) - (do ((item expr (cdr item))) - ((null (cdr item)) - (output-sql (car item) database)) - (output-sql (car item) database) - (write-char #\, *sql-stream*)) - (write-char #\) *sql-stream*))) - t) - -#+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) @@ -483,7 +352,8 @@ computed for each field." ;;; Row processing macro from CLSQL -(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body) +(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-"))