Gauche-dbd-pg を使うにあたって

自分で使うためにいくつかユーティリティ的なものを書いた。粗末だけど取りあえず動いてます。取りあえずさらしておくことに。

そういえば、dbi-connect には undocumented な auto-commit キーワード引数があるっぽい。

with-connection

(use dbi)
(use gauche.parameter)

(define *db* (make-parameter #f))
(define *dsn* (make-parameter #f))
(define *username* (make-parameter #f))
(define *password* (make-parameter #f))

(define-syntax with-connection
  (syntax-rules ()
    ((_ (*db* dsn) . body)
     (with-connection
      (*db* dsn (lambda (dsn)
                  (dbi-connect dsn)))
      . body))
    ((_ (*db* dsn username password) . body)
     (with-connection
      (*db* dsn (lambda (dsn)
                  (dbi-connect dsn
                               :username username
                               :password password)))
      . body))
    ((_ (*db* dsn connector) . body)
     (parameterize
         ((*db* (connector dsn)))
       (guard (e (else
                  (dbi-close (*db*))
                  (raise e)))
         (begin0
             (begin . body)
           (dbi-close (*db*))))))))

.NET の ConnectionStringBuilder みたいなのが欲しいなと思って。
dsn

(use util.match)

(define-class <dsn> ()
  ((platform :init-keyword :platform :initi-value #f)
   (dbname :init-keyword :dbname :init-value #f)
   (host :init-keyword :host :init-value #f)
   (port :init-keyword :port :init-value #f)
   (dsn :init-keyword :dsn :init-value #f)))

(define (%ref-join obj name delim)
  (if-let1 v (~ obj name)
           (string-append
            (symbol->string name) delim v)
           v))

(define-method build! ((con <dsn>))
  (let1 g (cut %ref-join con <> "=")
    (let ((platform (string-append
                     "dbi" ":" (or (~ con 'platform) "")))
          (dbname (g 'dbname))
          (host (g 'host))
          (port (g 'port)))
      (let1 constr (string-append
                    platform
                    (if-let1 dbname dbname
                             (string-append ":" dbname)
                             ""))
        (when host
          (set! constr (string-append constr ";" host)))
        (when port
          (set! constr (string-append constr ";" port)))
        constr))))

(define (build-dsn platform . keys)
  (let-keywords* keys ((dbname #f)(host #f)(port #f))
    (build! (apply make <dsn>
                   :platform platform keys))))

(define (%split-constring constring splitter)
  (let1 splitted (string-split constring splitter)
    (match splitted
      ((base)(values base #f #f))
      ((base host)(values base host #f))
      ((base host port)(values base host port))
      (else (values #f #f #f)))))

(define (%split-base base splitter)
  (let1 splitted (string-split base splitter)
    (match splitted
      ((dbi)(values dbi #f #f))
      ((dbi platform)(values dbi platform #f))
      ((dbi platform dbname)(values dbi platform dbname))
      (else (values #f #f #f)))))

(define-method decompose! ((con <dsn>) constring)
  (let1 v (^n (list-ref (string-split n "=") 1))
    (receive (base host port)
        (%split-constring constring ";")
      (when base
        (receive (dbi platform dbname)
            (%split-base base ":")
          (set! (~ con 'platform) platform)
          (set! (~ con 'dbname)(v dbname))))
      (when host
        (set! (~ con 'host)(v host)))
      (when port
        (set! (~ con 'port)(v port)))
      con)))

transaction, call-with-transaction など。なぜだか transaction クラスを作りました。connection もクラスにしとけばよかったかなと思います。

(use dbi)

(define-class <transaction> ()
  ((connection :init-keyword :connection)
   (begin-query :init-keyword :begin-query :init-value #f)
   (commit-query :init-keyword :commit-query :init-value #f)
   (rollback-query :init-keyword :rollback-query :init-value #f)
   (state :init-keyword :state :init-value 'ready)))

(define-class <pg-transaction> (<transaction>)())

(define-method initialize ((tran <pg-transaction>) initargs)
  (next-method)
  (set! (~ tran 'begin-query) "begin;")
  (set! (~ tran 'commit-query) "commit;")
  (set! (~ tran 'rollback-query) "rollback;"))

(define-method transaction-begin ((tran <transaction>))
  (rlet1 r (dbi-do (~ tran 'connection)(~ tran 'begin-query))
         (set! (~ tran 'state) 'begin)))

(define-method transaction-commit ((tran <transaction>))
  (rlet1 r (dbi-do (~ tran 'connection)(~ tran 'commit-query))
         (set! (~ tran 'state) 'committed)))

(define-method transaction-rollback ((tran <transaction>))
  (rlet1 r (dbi-do (~ tran 'connection)(~ tran 'rollback-query))
         (set! (~ tran 'state) 'rollbacked)))

(define (call-with-transaction proc)
  (let1 tran (make <pg-transaction>
               :connection (*db*))
    (guard (e ((<dbi-error> e)
               (transaction-rollback tran)
               (raise e))
              (else (raise e)))
      (transaction-begin tran)
      (rlet1 r (proc tran)
             (unless (let1 state (~ tran 'state)
                       (or (eq? state 'commeted)
                           (eq? state 'rollbacked)))
               (transaction-commit tran))))))

使う前に少し設定が必要になりますね。

(use file.util)
(use util.list)

(define-constant +server-bin-dir+ "/some/foo/bar")
(define-constant +db-config+
  (load-config (build-path +server-bin-dir+ "conf/db.conf")))

(define (init-module-dbi)
  (let* ((platform (assoc-ref +db-config+ 'db-platform))
         (host (assoc-ref +db-config+ 'db-host))
         (port (assoc-ref +db-config+ 'db-port))
         (dbname (assoc-ref +db-config+ 'db-dbname))
         (user (assoc-ref +db-config+ 'db-user))
         (password (assoc-ref +db-config+ 'db-password)))
    ;; dbi
    (*dsn* (build-dsn platform
                      :host host
                      :port port
                      :dbname dbname))
    (*username* user)
    (*password* password)))

db.conf は例えばこんなの。load-config はここに載ってませんが、load-config で db.conf 読み込むと alist になるような手続きです。

;; -*- mode:scheme; coding:utf-8 -*-

(db-platform "pg")
(db-host "hogehoge.com")
(db-port "5432")
(db-dbname "fuga")
;; (db-user "postgres")
;; (db-password "")

with-connection は with-db を参考にしました。

• Gauche:CGI:スケジュール予定表:Shiro版

他

• vallog: cygwin に gauche-dbd-pg
• vallog: serversman(centos) に postgreSQL に Gauche-dbd-pg