sql.lisp

   1 ;;;;  -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Pkg: umlisp -*-
   2 ;; SQL/UMLS database Layer over database backend
   3 ;; Copyright (c) 2001 Kevin M. Rosenberg, M.D.
   4 ;; $Id: sql.lisp,v 1.2 2002/10/08 22:13:41 kevin Exp $
   5
   6 (in-package :umlisp)
   7
   8 (declaim (optimize (speed 1) (safety 3)))
   9
  10 (defvar *umls-sql-dsn* "KUMLS2002AC")
  11 (defun umls-sql-dsn ()
  12   *umls-sql-dsn*)
  13 (defun umls-sql-dsn! (dbname)
  14   (sql-disconnect-pooled)
  15   (setq *umls-sql-dsn* dbname))
  16
  17 (defvar *umls-sql-user* "secret")
  18 (defun umls-sql-user ()
  19   *umls-sql-user*)
  20 (defun umls-sql-user! (u)
  21   (sql-disconnect-pooled)
  22   (setq *umls-sql-user* u))
  23
  24 (defvar *umls-sql-passwd* "secret")
  25 (defun umls-sql-passwd ()
  26   *umls-sql-passwd*)
  27 (defun umls-sql-passwd! (p)
  28   (sql-disconnect-pooled)
  29   (setq *umls-sql-passwd* p))
  30
  31 (defvar *umls-sql-host* "localhost")
  32 (defun umls-sql-host ()
  33   *umls-sql-host*)
  34 (defun umls-sql-host! (h)
  35   (sql-disconnect-pooled)
  36   (setq *umls-sql-host* h))
  37
  38 (defvar *umls-sql-type* :mysql)
  39 (defun umls-sql-type ()
  40   *umls-sql-type*)
  41 (defun umls-sql-type! (h)
  42   (sql-disconnect-pooled)
  43   (setq *umls-sql-type* h))
  44
  45 (defun sql-connect ()
  46   "Connect to UMLS database, automatically used pooled connections"
  47   (clsql:connect `(,(umls-sql-host) ,(umls-sql-dsn) ,(umls-sql-user) ,(umls-sql-passwd))
  48                  :database-type *umls-sql-type* :pool t))
  49
  50 (defun sql-disconnect (conn)
  51   "Disconnect from UMLS database, but put connection back into pool"
  52   (clsql:disconnect :database conn))
  53
  54 (defun sql-disconnect-pooled ()
  55   (clsql:disconnect-pooled))
  56
  57 (defmacro with-sql-connection ((conn) &body body)
  58   `(let ((,conn (sql-connect)))
  59      (unwind-protect
  60          (progn ,@body)
  61        (when ,conn (clsql:disconnect :database ,conn)))))
  62
  63 (defun sql (stmt conn)
  64   (if (string-equal "SELECT" (subseq stmt 0 6))
  65       (sql-query stmt conn)
  66     (sql-execute stmt conn)))
  67
  68 (defun sql-query (cmd conn &key (types :auto))
  69   (clsql:query cmd :database conn :types types))
  70
  71 (defun sql-execute (cmd conn)
  72   (clsql:execute-command cmd :database conn))
  73
  74 (defun umls-sql (stmt)
  75   (check-type stmt string)
  76   (with-sql-connection (conn)
  77     (sql stmt conn)))
  78
  79 ;;; Pool of open connections
  80
  81 (defmacro with-mutex-sql ((conn) &body body)
  82   `(let ((,conn (sql-connect)))
  83      (unwind-protect
  84          (progn ,@body)
  85        (when ,conn (sql-disconnect ,conn)))))
  86
  87 (defun mutex-sql-execute (cmd)
  88   (with-mutex-sql (conn)
  89     (sql-execute cmd conn)))
  90
  91 (defun mutex-sql-query (cmd &key (types :auto))
  92   (with-mutex-sql (conn)
  93     (sql-query cmd conn :types types)))
  94
  95
  96