X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fsql.lisp;h=c207a8f52221b11de881e0fe543a98e68b025742;hb=0196e0db0edccccab4cd8a0d6309e768a98667fd;hp=125de200816019409c9dfbbb448a08639cf31178;hpb=73d3c42de4eb898508f635362896ddcbc1d5ce7a;p=clsql.git

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 125de20..c207a8f 100644
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -2,14 +2,14 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:         sql.cl
+;;;; Name:         sql.lisp
 ;;;; Purpose:      High-level SQL interface
 ;;;; Authors:      Kevin M. Rosenberg based on code by Pierre R. Mai 
 ;;;; Date Started: Feb 2002
 ;;;;
-;;;; $Id: sql.lisp,v 1.5 2003/05/06 02:27:08 kevin Exp $
+;;;; $Id$
 ;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
 ;;;;
 ;;;; CLSQL users are granted the rights to distribute and use this software
@@ -17,226 +17,79 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(eval-when (:compile-toplevel)
-  (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
-
 (in-package #:clsql-sys)
 
 
-;;; Database handling
-
-(defvar *connect-if-exists* :error
-  "Default value for the if-exists parameter of connect calls.")
-
-(defvar *connected-databases* nil
-  "List of active database objects.")
-
-(defun connected-databases ()
-  "Return the list of active database objects."
-  *connected-databases*)
-
-(defvar *default-database* nil
-  "Specifies the default database to be used.")
-
-(defun find-database (database &optional (errorp t))
-  (etypecase database
-    (database
-     ;; Return the database object itself
-     database)
-    (string
-     (or (find database (connected-databases)
-	       :key #'database-name
-	       :test #'string=)
-	 (when errorp
-	   (cerror "Return nil."
-		   'clsql-simple-error
-		   :format-control "There exists no database called ~A."
-		   :format-arguments (list database)))))))
-
-(defun connect (connection-spec
-		&key (if-exists *connect-if-exists*)
-		(database-type *default-database-type*)
-		(pool nil))
-  "Connects to a database of the given database-type, using the type-specific
-connection-spec. 
-If pool is t the connection will be taken from the general pool,
-if pool is a conn-pool object the connection will be taken from this pool.
-"
-  (if pool
-    (acquire-from-pool connection-spec database-type pool)
-    (let* ((db-name (database-name-from-spec connection-spec database-type))
-	   (old-db (unless (eq if-exists :new) (find-database db-name nil)))
-	   (result nil))
-      (if old-db
-	(case if-exists
-;	    (:new
-;	     (setq result
-;	       (database-connect connection-spec database-type)))
-	  (:warn-new
-	   (setq result
-		 (database-connect connection-spec database-type))
-	   (warn 'clsql-exists-warning :old-db old-db :new-db result))
-	  (:error
-	   (restart-case
-		 (error 'clsql-exists-error :old-db old-db)
-	       (create-new ()
-		   :report "Create a new connection."
-		 (setq result
-		   (database-connect connection-spec database-type)))
-	       (use-old ()
-		   :report "Use the existing connection."
-		 (setq result old-db))))
-	  (:warn-old
-	   (setq result old-db)
-	   (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
-	  (:old
-	   (setq result old-db)))
-	(setq result
-	      (database-connect connection-spec database-type)))
-      (when result
-	(pushnew result *connected-databases*)
-	(setq *default-database* result)
-	result))))
-
-
-(defun disconnect (&key (database *default-database*))
-  "Closes the connection to database. Resets *default-database* if that
-database was disconnected and only one other connection exists.
-if the database is from a pool it will be released to this pool."
-  (if (conn-pool database)
-      (release-to-pool database)
-    (when (database-disconnect database)
-      (setq *connected-databases* (delete database *connected-databases*))
-      (when (eq database *default-database*)
-	(setq *default-database* (car *connected-databases*)))
-      (change-class database 'closed-database)
-      t)))
-
-;;; Basic operations on databases
-
-(defgeneric query (expression &key database types))
-(defmethod query (query-expression &key (database *default-database*)  
-		  types)
-  "Execute the SQL query expression query-expression on the given database.
-Returns a list of lists of values of the result of that expression."
-  (database-query query-expression database types))
+;;; Row processing macro
+
+(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))))))
 
 
-(defgeneric execute-command (expression &key database))
-(defmethod execute-command (sql-expression &key (database *default-database*))
-  "Execute the SQL command expression sql-expression on the given database.
-Returns true on success or nil on failure."
-  (database-execute-command sql-expression database))
-
-
-
-(defun map-query (output-type-spec function query-expression
-		  &key (database *default-database*)
-		  (types nil))
-  "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."
-  ;; DANGER Will Robinson: Parts of the code for implementing
-  ;; map-query (including the code below and the helper functions
-  ;; called) are highly CMU CL specific.
-  ;; KMR -- these have been replaced with cross-platform instructions above
-  (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 types))
-      (list 
-       (map-query-to-list function query-expression database 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 types))
-      (t
-       (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
-              function query-expression :database database :types types)))))
-
-(defun map-query-for-effect (function query-expression database types)
-  (multiple-value-bind (result-set columns)
-      (database-query-result-set query-expression database :full-set nil
-				 :types 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 types)
-  (multiple-value-bind (result-set columns)
-      (database-query-result-set query-expression database :full-set nil
-				 :types 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 types)
-  (multiple-value-bind (result-set columns rows)
-      (database-query-result-set query-expression database :full-set t
-				 :types 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)))))
-
-(defmacro do-query (((&rest args) query-expression
-		     &key (database '*default-database*)
-		     (types nil))
-		    &body body)
-  (let ((result-set (gensym))
-	(columns (gensym))
-	(row (gensym))
-	(db (gensym)))
-    `(let ((,db ,database))
-       (multiple-value-bind (,result-set ,columns)
-	   (database-query-result-set ,query-expression ,db
-				      :full-set nil :types ,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)))))))
-
 ;;; Marc Battyani : Large objects support
 
 (defun create-large-object (&key (database *default-database*))
@@ -254,3 +107,5 @@ specified in output-type-spec and returned like in MAP."
 (defun delete-large-object (object-id &key (database *default-database*))
   "Deletes the large object in the database"
   (database-delete-large-object object-id database))
+
+