;;;; *************************************************************************
;;;; 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.cl
+;;;; 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.2 2002/10/14 15:25:15 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;; (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)
+(eval-when (:compile-toplevel)
+ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
-;;; 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
+(in-package #:clsql-sys)
;;; Database handling
(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,
+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
(defun delete-large-object (object-id &key (database *default-database*))
"Deletes the large object in the database"
(database-delete-large-object object-id database))
+
+
+;;; 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))))))