classic/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-classic)
  21
  22
  23 ;;; Row processing macro
  24
  25 (defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
  26   (let ((d (gensym "DISTINCT-"))
  27         (bind-fields (loop for f in fields collect (car f)))
  28         (w (gensym "WHERE-"))
  29         (o (gensym "ORDER-BY-"))
  30         (frm (gensym "FROM-"))
  31         (l (gensym "LIMIT-"))
  32         (q (gensym "QUERY-")))
  33     `(let ((,frm ,from)
  34            (,w ,where)
  35            (,d ,distinct)
  36            (,l ,limit)
  37            (,o ,order-by))
  38       (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
  39         (loop for tuple in (query ,q)
  40               collect (destructuring-bind ,bind-fields tuple
  41                    ,@body))))))
  42
  43 (defun query-string (fields from where distinct order-by limit)
  44   (concatenate
  45    'string
  46    (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
  47            (if distinct "distinct " "") (field-names fields)
  48            (from-names from))
  49    (if where (format nil " where ~{~A~^ ~}"
  50                      (where-strings where)) "")
  51    (if order-by (format nil " order by ~{~A~^, ~}"
  52                         (order-by-strings order-by)))
  53    (if limit (format nil " limit ~D" limit) "")))
  54
  55 (defun lisp->sql-name (field)
  56   (typecase field
  57     (string field)
  58     (symbol (string-upcase (symbol-name field)))
  59     (cons (cadr field))
  60     (t (format nil "~A" field))))
  61
  62 (defun field-names (field-forms)
  63   "Return a list of field name strings from a fields form"
  64   (loop for field-form in field-forms
  65         collect
  66         (lisp->sql-name
  67          (if (cadr field-form)
  68              (cadr field-form)
  69              (car field-form)))))
  70
  71 (defun from-names (from)
  72   "Return a list of field name strings from a fields form"
  73   (loop for table in (if (atom from) (list from) from)
  74         collect (lisp->sql-name table)))
  75
  76
  77 (defun where-strings (where)
  78   (loop for w in (if (atom (car where)) (list where) where)
  79         collect
  80         (if (consp w)
  81             (format nil "~A ~A ~A" (second w) (first w) (third w))
  82             (format nil "~A" w))))
  83
  84 (defun order-by-strings (order-by)
  85   (loop for o in order-by
  86         collect
  87         (if (atom o)
  88             (lisp->sql-name o)
  89             (format nil "~A ~A" (lisp->sql-name (car o))
  90                     (lisp->sql-name (cadr o))))))
  91
  92
  93
  94 ;;; These functions are not exported. If you application depends on these
  95 ;;; functions consider using the clsql package using has further support.
  96
  97 (defun list-tables (&key (database *default-database*))
  98   "List all tables in *default-database*, or if the :database keyword arg
  99 is given, the specified database.  If the keyword arg :system-tables
 100 is true, then it will not filter out non-user tables.  Table names are
 101 given back as a list of strings."
 102   (database-list-tables database))
 103
 104
 105 (defun list-attributes (table &key (database *default-database*))
 106   "List the attributes of TABLE in *default-database, or if the
 107 :database keyword is given, the specified database.  Attributes are
 108 returned as a list of strings."
 109   (database-list-attributes table database))
 110
 111 (defun attribute-type (attribute table &key (database *default-database*))
 112   "Return the field type of the ATTRIBUTE in TABLE.  The optional
 113 keyword argument :database specifies the database to query, defaulting
 114 to *default-database*."
 115   (database-attribute-type attribute table database))
 116
 117 (defun create-sequence (name &key (database *default-database*))
 118   (database-create-sequence name database))
 119
 120 (defun drop-sequence (name &key (database *default-database*))
 121   (database-drop-sequence name database))
 122
 123 (defun sequence-next (name &key (database *default-database*))
 124   (database-sequence-next name database))
 125
 126