sql/sql.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:         sql.lisp
   6 ;;;; Purpose:      High-level SQL interface
   7 ;;;; Authors:      Kevin M. Rosenberg based on code by Pierre R. Mai
   8 ;;;; Date Started: Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg
  13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
  14 ;;;;
  15 ;;;; CLSQL users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (in-package #:clsql-sys)
  21
  22
  23 ;;; Row processing macro
  24
  25
  26
  27 (defun lisp->sql-name (field)
  28   (typecase field
  29     (string field)
  30     (symbol (string-upcase (symbol-name field)))
  31     (cons (cadr field))
  32     (t (format nil "~A" field))))
  33
  34 (defun field-names (field-forms)
  35   "Return a list of field name strings from a fields form"
  36   (loop for field-form in field-forms
  37         collect
  38         (lisp->sql-name
  39          (if (cadr field-form)
  40              (cadr field-form)
  41              (car field-form)))))
  42
  43 (defun from-names (from)
  44   "Return a list of field name strings from a fields form"
  45   (loop for table in (if (atom from) (list from) from)
  46         collect (lisp->sql-name table)))
  47
  48
  49 (defun where-strings (where)
  50   (loop for w in (if (atom (car where)) (list where) where)
  51         collect
  52         (if (consp w)
  53             (format nil "~A ~A ~A" (second w) (first w) (third w))
  54             (format nil "~A" w))))
  55
  56 (defun order-by-strings (order-by)
  57   (loop for o in order-by
  58         collect
  59         (if (atom o)
  60             (lisp->sql-name o)
  61             (format nil "~A ~A" (lisp->sql-name (car o))
  62                     (lisp->sql-name (cadr o))))))
  63
  64 (defun query-string (fields from where distinct order-by limit)
  65   (concatenate
  66    'string
  67    (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
  68            (if distinct "distinct " "") (field-names fields)
  69            (from-names from))
  70    (if where (format nil " where ~{~A~^ ~}"
  71                      (where-strings where)) "")
  72    (if order-by (format nil " order by ~{~A~^, ~}"
  73                         (order-by-strings order-by)))
  74    (if limit (format nil " limit ~D" limit) "")))
  75
  76 (defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
  77   (let ((d (gensym "DISTINCT-"))
  78         (bind-fields (loop for f in fields collect (car f)))
  79         (w (gensym "WHERE-"))
  80         (o (gensym "ORDER-BY-"))
  81         (frm (gensym "FROM-"))
  82         (l (gensym "LIMIT-"))
  83         (q (gensym "QUERY-")))
  84     `(let ((,frm ,from)
  85            (,w ,where)
  86            (,d ,distinct)
  87            (,l ,limit)
  88            (,o ,order-by))
  89       (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
  90         (loop for tuple in (query ,q)
  91               collect (destructuring-bind ,bind-fields tuple
  92                    ,@body))))))
  93
  94 ;;; Marc Battyani : Large objects support
  95
  96 (defun create-large-object (&key (database *default-database*))
  97   "Creates a new large object in the database and returns the object identifier"
  98   (database-create-large-object database))
  99
 100 (defun write-large-object (object-id data &key (database *default-database*))
 101   "Writes data to the large object"
 102   (database-write-large-object object-id data database))
 103
 104 (defun read-large-object (object-id &key (database *default-database*))
 105   "Reads the large object content"
 106   (database-read-large-object object-id database))
 107
 108 (defun delete-large-object (object-id &key (database *default-database*))
 109   "Deletes the large object in the database"
 110   (database-delete-large-object object-id database))
 111
 112