X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fsql.lisp;h=d46bdcf5c5acdb3401f19b6b400b718f227c5d58;hp=12535e5fc43d4bc0c87725d752425c8a818e4553;hb=ce0e343835a040406678dff74a62d1b0cb56f317;hpb=7d50938ba2db52a713498e49aa1679deae6f0b6b

diff --git a/sql/sql.lisp b/sql/sql.lisp
index 12535e5..d46bdcf 100644
--- a/sql/sql.lisp
+++ b/sql/sql.lisp
@@ -2,15 +2,14 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name:          sql.cl
-;;;; Purpose:       High-level SQL interface
-;;;; Programmers:   Kevin M. Rosenberg based on
-;;;;                 Original code by Pierre R. Mai 
-;;;; Date Started:  Feb 2002
+;;;; 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.1 2002/09/30 10:19:23 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
@@ -18,122 +17,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :clsql-sys)
-
-;;; Modified by KMR 
-;;; - to use CMUCL-COMPAT library 
-;;; - fix format strings in error messages 
-;;; - use field types
-
-
-;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
-
-
-;;; 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-exists is currently ignored.
-If pool is t the 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
-
-(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))
-
-
-
-(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))
-
+(in-package #:clsql-sys)
 
 
 (defun map-query (output-type-spec function query-expression
@@ -243,6 +127,78 @@ specified in output-type-spec and returned like in MAP."
 		    ,@body))
 	     (database-dump-result-set ,result-set ,db)))))))
 
+
+;;; Row processing macro
+
+
+
+(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))))))
+
+(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) "")))
+
+(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))))))
+
 ;;; Marc Battyani : Large objects support
 
 (defun create-large-object (&key (database *default-database*))
@@ -260,3 +216,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))
+
+