sql/functional.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          functional.cl
   6 ;;;; Purpose:       Functional interface
   7 ;;;; Programmer:    Pierre R. Mai
   8 ;;;;
   9 ;;;; Copyright (c) 1999-2001 Pierre R. Mai
  10 ;;;;
  11 ;;;; $Id: functional.cl,v 1.8 2002/09/17 17:16:43 kevin Exp $
  12 ;;;;
  13 ;;;; This file is part of CLSQL.
  14 ;;;;
  15 ;;;; CLSQL is free software; you can redistribute it and/or modify
  16 ;;;; it under the terms of the GNU General Public License (version 2) as
  17 ;;;; published by the Free Software Foundation.
  18 ;;;;
  19 ;;;; CLSQL is distributed in the hope that it will be useful,
  20 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;;;; GNU General Public License for more details.
  23 ;;;;
  24 ;;;; You should have received a copy of the GNU General Public License
  25 ;;;; along with CLSQL; if not, write to the Free Software Foundation, Inc.,
  26 ;;;; 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  27 ;;;; *************************************************************************
  28
  29 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  30 (in-package :clsql-sys)
  31
  32
  33 ;;;; This file implements the more advanced functions of the
  34 ;;;; functional SQL interface, which are just nicer layers above the
  35 ;;;; basic SQL interface.
  36
  37 (defun insert-records
  38     (&key into attributes values av-pairs query (database *default-database*))
  39   "Insert records into the given table according to the given options."
  40   (cond
  41     ((and av-pairs (or attributes values))
  42      (error "Supply either av-pairs or values (and possibly attributes) to call of insert-records."))
  43     ((and (or av-pairs values) query)
  44      (error
  45       "Supply either query or values/av-pairs to call of insert-records."))
  46     ((and attributes (not query)
  47           (or (not (listp values)) (/= (length attributes) (length values))))
  48      (error "You must supply a matching values list when using attributes in call of insert-records."))
  49     (query
  50      (execute-command
  51       (format nil "insert into ~A ~@[(~{~A~^,~}) ~]~A" into attributes query)
  52       :database database))
  53     (t
  54      (execute-command
  55       (multiple-value-bind (attributes values)
  56           (if av-pairs
  57               (values (mapcar #'first av-pairs) (mapcar #'second av-pairs))
  58               (values attributes values))
  59         (format nil "insert into ~A ~@[(~{~A~^,~}) ~]values (~{'~A'~^,~})"
  60                 into attributes values))
  61       :database database))))
  62
  63 (defun delete-records (&key from where (database *default-database*))
  64   "Delete the indicated records from the given database."
  65   (execute-command (format nil "delete from ~A ~@[where ~A ~]" from where)
  66                    :database database))
  67
  68 (defun update-records (table &key attributes values av-pairs where (database *default-database*))
  69   "Update the specified records in the given database."
  70   (cond
  71     ((and av-pairs (or attributes values))
  72      (error "Supply either av-pairs or values (and possibly attributes) to call of update-records."))
  73     ((and attributes
  74           (or (not (listp values)) (/= (length attributes) (length values))))
  75      (error "You must supply a matching values list when using attributes in call of update-records."))
  76     ((or (and attributes (not values)) (and values (not attributes)))
  77      (error "You must supply both values and attributes in call of update-records."))
  78     (t
  79      (execute-command
  80       (format nil "update ~A set ~:{~A = '~A'~:^, ~}~@[ where ~A~]"
  81               table
  82               (or av-pairs
  83                   (mapcar #'list attributes values))
  84               where)
  85       :database database))))
  86
  87 (defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
  88   "Evaluate the body in an environment, where `db-var' is bound to the
  89 database connection given by `connection-spec' and `connect-args'.
  90 The connection is automatically closed or released to the pool on exit from the body."
  91   (let ((result (gensym "result-")))
  92     (unless db-var (setf db-var '*default-database*))
  93     `(let ((,db-var (connect ,connection-spec ,@connect-args))
  94            (,result nil))
  95       (unwind-protect
  96            (let ((,db-var ,db-var))
  97              (setf ,result (progn ,@body)))
  98         (disconnect :database ,db-var))
  99       ,result)))