connect.lisp

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