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.3 2003/05/14 05:29:48 kevin Exp $
  11 ;;;;
  12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
  13 ;;;; *************************************************************************
  14
  15 (in-package :hyperobject)
  16 (eval-when (:compile-toplevel :execute)
  17   (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
  18
  19 (defvar *ho-sql-db* "ho")
  20 (defun ho-sql-db ()
  21   *ho-sql-db*)
  22 (defun ho-sql-db! (dbname)
  23   (sql-disconnect-pooled)
  24   (setq *ho-sql-db* dbname))
  25
  26 (defvar *ho-sql-user* "secret")
  27 (defun ho-sql-user ()
  28   *ho-sql-user*)
  29 (defun ho-sql-user! (u)
  30   (sql-disconnect-pooled)
  31   (setq *ho-sql-user* u))
  32
  33 (defvar *ho-sql-passwd* "secret")
  34 (defun ho-sql-passwd ()
  35   *ho-sql-passwd*)
  36 (defun ho-sql-passwd! (p)
  37   (sql-disconnect-pooled)
  38   (setq *ho-sql-passwd* p))
  39
  40 (defvar *ho-sql-host* "localhost")
  41 (defun ho-sql-host ()
  42   *ho-sql-host*)
  43 (defun ho-sql-host! (h)
  44   (sql-disconnect-pooled)
  45   (setq *ho-sql-host* h))
  46
  47 (defvar *ho-sql-type* :mysql)
  48 (defun ho-sql-type ()
  49   *ho-sql-type*)
  50 (defun ho-sql-type! (h)
  51   (sql-disconnect-pooled)
  52   (setq *ho-sql-type* h))
  53
  54 (defun sql-connect ()
  55   "Connect to HO database, automatically used pooled connections"
  56   (clsql:connect `(,(ho-sql-host) ,(ho-sql-db) ,(ho-sql-user) ,(ho-sql-passwd))
  57                  :database-type *ho-sql-type* :pool t))
  58
  59 (defun sql-disconnect (conn)
  60   "Disconnect from HO database, but put connection back into pool"
  61   (clsql:disconnect :database conn))
  62
  63 (defun sql-disconnect-pooled ()
  64   (clsql:disconnect-pooled))
  65
  66 (defmacro with-sql-connection ((conn) &body body)
  67   `(let ((,conn (sql-connect)))
  68      (unwind-protect
  69          (progn ,@body)
  70        (when ,conn (clsql:disconnect :database ,conn)))))
  71
  72 (defun sql-query (cmd conn &key (types :auto))
  73   (clsql:query cmd :database conn :types types))
  74
  75 (defun sql-execute (cmd conn)
  76   (clsql:execute-command cmd :database conn))
  77
  78 ;;; Pool of open connections
  79
  80 (defmacro with-mutex-sql ((conn) &body body)
  81   `(let ((,conn (sql-connect)))
  82      (unwind-protect
  83          (progn ,@body)
  84        (when ,conn (sql-disconnect ,conn)))))
  85
  86 (defun mutex-sql-execute (cmd)
  87   (with-mutex-sql (conn)
  88     (sql-execute cmd conn)))
  89
  90 (defun mutex-sql-query (cmd &key (types :auto))
  91   (with-mutex-sql (conn)
  92     (sql-query cmd conn :types types)))