sql.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          sql.lisp
   6 ;;;; Purpose:       Low-level SQL routines data for UMLisp
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: sql.lisp,v 1.7 2002/10/18 05:18:43 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UMLisp, is
  13 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
  14 ;;;;
  15 ;;;; UMLisp users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the GNU General Public License.
  17 ;;;; *************************************************************************
  18
  19 (in-package :umlisp)
  20 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  21
  22
  23 (defvar *umls-sql-dsn* "KUMLS2002AC")
  24 (defun umls-sql-dsn ()
  25   *umls-sql-dsn*)
  26 (defun umls-sql-dsn! (dbname)
  27   (sql-disconnect-pooled)
  28   (setq *umls-sql-dsn* dbname))
  29
  30 (defvar *umls-sql-user* "secret")
  31 (defun umls-sql-user ()
  32   *umls-sql-user*)
  33 (defun umls-sql-user! (u)
  34   (sql-disconnect-pooled)
  35   (setq *umls-sql-user* u))
  36
  37 (defvar *umls-sql-passwd* "secret")
  38 (defun umls-sql-passwd ()
  39   *umls-sql-passwd*)
  40 (defun umls-sql-passwd! (p)
  41   (sql-disconnect-pooled)
  42   (setq *umls-sql-passwd* p))
  43
  44 (defvar *umls-sql-host* "localhost")
  45 (defun umls-sql-host ()
  46   *umls-sql-host*)
  47 (defun umls-sql-host! (h)
  48   (sql-disconnect-pooled)
  49   (setq *umls-sql-host* h))
  50
  51 (defvar *umls-sql-type* :mysql)
  52 (defun umls-sql-type ()
  53   *umls-sql-type*)
  54 (defun umls-sql-type! (h)
  55   (sql-disconnect-pooled)
  56   (setq *umls-sql-type* h))
  57
  58 (defun sql-connect ()
  59   "Connect to UMLS database, automatically used pooled connections"
  60   (clsql:connect `(,(umls-sql-host) ,(umls-sql-dsn) ,(umls-sql-user) ,(umls-sql-passwd))
  61                  :database-type *umls-sql-type* :pool t))
  62
  63 (defun sql-disconnect (conn)
  64   "Disconnect from UMLS database, but put connection back into pool"
  65   (clsql:disconnect :database conn))
  66
  67 (defun sql-disconnect-pooled ()
  68   (clsql:disconnect-pooled))
  69
  70 (defmacro with-sql-connection ((conn) &body body)
  71   `(let ((,conn (sql-connect)))
  72      (unwind-protect
  73          (progn ,@body)
  74        (when ,conn (clsql:disconnect :database ,conn)))))
  75
  76 (defun sql (stmt conn)
  77   (if (string-equal "SELECT" (subseq stmt 0 6))
  78       (sql-query stmt conn)
  79     (sql-execute stmt conn)))
  80
  81 (defun sql-query (cmd conn &key (types :auto))
  82   (clsql:query cmd :database conn :types types))
  83
  84 (defun sql-execute (cmd conn)
  85   (clsql:execute-command cmd :database conn))
  86
  87 (defun umls-sql (stmt)
  88   (check-type stmt string)
  89   (with-sql-connection (conn)
  90     (sql stmt conn)))
  91
  92 ;;; Pool of open connections
  93
  94 (defmacro with-mutex-sql ((conn) &body body)
  95   `(let ((,conn (sql-connect)))
  96      (unwind-protect
  97          (progn ,@body)
  98        (when ,conn (sql-disconnect ,conn)))))
  99
 100 (defun mutex-sql-execute (cmd)
 101   (with-mutex-sql (conn)
 102     (sql-execute cmd conn)))
 103
 104 (defun mutex-sql-query (cmd &key (types :auto))
 105   (with-mutex-sql (conn)
 106     (sql-query cmd conn :types types)))