GaucheでRDBプログラミング：Gaucheでメタプログラミング（3）（5/5 ページ）
Lispの一種であるScheme。いくつかある処理系の中でも気軽にスクリプトを書けるGaucheでLispの世界を体験してみよう（編集部）
スロット作成メソッドの定義
<orm>クラスのsetup-slotsメソッドはインスタンスの生成時にカラム定義などの情報を取得し、動的にスロットを作成しています。引数には<orm>クラスのインスタンスではなく、<orm>クラス（の子クラス）そのものを受け取るので<orm- meta>クラスが指定されています。
setup-slotsの処理ですが、すでに初期化済みの場合は何もせずclassを戻します。初期化されていない場合は、DB接続の取得、テーブル名の取得、カラム名リストの取得を行い、カラム名リストを使いスロット定義したクラスを再定義し、再定義されたクラスにDB接続などの情報をクラス変数に設定します。
Gaucheのオブジェクトシステムでは、動的にクラス定義が変更される場合の動作も規定されています。再定義された場合、旧定義クラスのインスタンスが持っているredefinedスロットに再定義された新クラス（へのポインター）が入っています。setup-slotsでは初期化を行った場合は、redefinedスロットにある新クラスを戻します。
クラス変数の参照（代入）には、class-slot-ref関数が使われます。
(define-method setup-slots ((class <orm-meta>))
(if (class-slot-bound? class 'initialized)
class
(let* ((db-conn (or (class-slot-bound? class 'db-conn) (db-connect)))
(table-name (class-name->table-name class))
(column-names (db-column-name-list db-conn table-name))
(new-class #f))
(redefine-slots class column-names)
(set! new-class (slot-ref class 'redefined))
(set! (class-slot-ref new-class 'db-conn) db-conn)
(set! (class-slot-ref new-class 'table-name) table-name)
(set! (class-slot-ref new-class 'column-names) column-names)
(set! (class-slot-ref new-class 'initialized) #t)
new-class)))
class-name->table-nameは、クラス名からテーブル名に変換した文字列を戻します。正規表現を使って<>を外し"s"を付けて複数形にしています。ActiveRecordでは複数形への変換は不規則な名詞にも対応していますが、ここでは省略しています。
string-append、regexp-replace、symbol->string、class-name関数の意味は名前から推察できると思うので省略します、詳細はユーザーリファレンスを参照してください。
(define-method class-name->table-name ((class <orm-meta>)) (string-append (regexp-replace #/<(.+)>/ (symbol->string (class-name class)) "\\1") "s"))
redefine-slotsはスロット定義のあるclassを再定義しています。define-classはマクロなのでdefine-classでの定義のS式を組み立て、引数をプログラムとして実行するeval関数で動的に定義を実行しています。
スロット定義を作る前半部分のlambdaでは、引数nが"name"の場合は(name :init-keyword :name :accessor name-of)となるようなS式を作ります。mapの実行が終わると、slots変数に全カラム名に対応したスロット定義のリストが入ります。
let1マクロは変数が1つだけのletスペシャルフォームです。class-name、class-direct-supers関数は引数で指定されたクラスの名前、直接のスーパークラスを取得します。
`は準クオート（Quasiquote）と呼ばれ、'クオート同様にS式をすぐに評価せずデータとして扱いたい場合に使いますが、準クオートではS式内の,の次のS式のみは評価されます。
例えば、`(1 2 ,(+ 2 3))は(1 2 5)になります。準クオートはマクロ定義など動的にプログラムを定義するコード内にプログラムのひな型を書くのによく使われます。
(define-method redefine-slots ((class <orm-meta>) slots-names)
(let1 slots (map (lambda(n)
`(,(string->symbol n) :init-keyword ,(make-keyword n)
:accessor ,(string->symbol #`",|n|-of")))
slots-names)
(eval `(define-class ,(class-name class)
( ,(class-name (car (class-direct-supers class))) )
,slots)
(interaction-environment))))
<orm>メソッド
<orm>ではテーブルの全データをリストとして取得するall、ID指定で1つのレコードを取得するfind、インスタンスをテーブルに書き込むsaveメソッドを提供しています。allとfindメソッドはクラスメソッドで、saveはインスタンスメソッドです。
allは、まずカラムに対応するスロットが作成されていない場合は作成するようにsetup-slotsを呼び出しています。スロットが作成された場合、クラスは再定義され、仮引数で与えられたclassとは別のものになるので、setup-slotsの値を変数classに代入しています。次にSELECT文を実行し、レコードを取得し、その値をmake-with-db-values関数でレコードごとにclassのインスタンスを作成し、SELECT結果を代入しています。
(define-method all ((class <orm-meta>))
(set! class (setup-slots class))
(let* ((result (db-select (class-slot-ref class 'db-conn)
(class-slot-ref class 'table-name)))
(column-getter (relation-accessor result)))
(map (lambda(row) (make-with-db-values class row column-getter))
result)))
findは取得されるレコードが1件なのがallとの違いです。first-elementでSELECT結果の最初の要素のみを取得しています。
(define-method find ((class <orm-meta>)(id <integer>))
(set! class (setup-slots class))
(let* ((result (db-select-by-key (class-slot-ref class 'db-conn)
(class-slot-ref class 'table-name)
"id" id))
(column-getter (relation-accessor result)))
(make-with-db-values class (first-element result) column-getter)))
saveはidスロットの値があるかないかでINSERTとUPDATEを切り替えています。slot-bound?関数はスロットに値があれば#t（真）を戻します。値のないスロットを参照するとエラーになるので注意しましょう。column-slot-hashはカラム名と対応するスロットの値をハッシュとして戻します。
(define-method save ((object <orm>))
(if (slot-bound? object 'id)
(db-update (slot-ref object 'db-conn)
(slot-ref object 'table-name)
(column-slot-hash object)
"id"
(slot-ref object 'id))
(db-insert (slot-ref object 'db-conn)
(slot-ref object 'table-name)
(column-slot-hash object)))
#t)
make-with-db-values関数は、(make <palyer> :no 3 :name 'YAMADA,taro')のようなインスタンス作成を実行します。ここで使っているfold関数は、(fold + 10 '(1 2 3))の値が10+1+2+3で16になるように、第2引数を初期値とし、第3引数のリストの要素を順に第1引数の関数に適応した値を戻します。これを使い初期値のリストを組み立てています。
最後でapply関数を使ってmakeを実行しています。通常関数の呼び出しは(+ 1 2 3)のように(関数名引数1 引数2……)と書きますが、applyを使うと(apply + '(1 2 3))のように(apply 関数名 引数リスト)と書け、引数を1つのリストとして渡せるので引数がすでにリストとして組み立てられている場合に便利です。
(define-method make-with-db-values ((class <orm-meta>) row column-getter)
(let1 init-values (fold (lambda(c r)
(list* (make-keyword c) (column-getter row c) r))
()
(class-slot-ref class 'column-names))
(apply make (cons class init-values))))
first-elementはコレクションからfindを使い最初の要素のみを取得しています。(lambda(el) #t)はいつでも#t（真）を戻すので、findで最初の要素が取得できます。
(define-method first-element ((coll <collection>)) (find (lambda(el) #t) coll))
column-slot-hashはカラム名と対応するスロットの値をハッシュとして戻します。ただし、値のないスロットは無視されます。ハッシュの作成はmake-hash-tableで行います。引数にはハッシュのキーの比較関数を指定します。ハッシュの参照、代入には専用の関数もありますが、ここでは汎用のrefやset!メソッドを使ってみました。
(define-method column-slot-hash ((object <orm>))
(let1 hash (make-hash-table 'string=?)
(for-each
(lambda(col)
(if (slot-bound? object (string->symbol col))
(set! (ref hash col)
(slot-ref object (string->symbol col)))))
(slot-ref object 'column-names))
hash))
DBIインターフェイス
RDB操作は、DBI関数を直接使わずに<orm>メソッドの定義を分かりやすくするために一皮かぶせています。これらの関数についてはあまりに説明することはないと思います。いままでに説明していない関数も出てきますが、ユーザーリファレンスで調べながらコードを読んでみてください。
(define (db-connect)
(dbi-connect *data-source-name*))
(define (db-column-name-list db-conn table-name)
(let1 result (dbi-do db-conn
#`"SELECT * FROM ,table-name LIMIT 1")
(vector->list (relation-column-names result))))
(define (db-select db-conn table-name)
(dbi-do db-conn #`"SELECT * FROM ,table-name"))
(define (db-select-by-key db-conn table-name key-column key-value)
(let* ((sql #`"SELECT * FROM ,table-name WHERE ,key-column = ?")
(query (dbi-prepare db-conn sql)))
(dbi-execute query key-value)))
(define (db-update db-conn table-name attr-hash key-column key-value)
(let* ((assign (string-join (map (lambda(c) #`",c = ?") (hash-table-keys attr-hash)) ","))
(sql #`"UPDATE ,table-name SET ,assign WHERE ,key-column = ?")
(query (dbi-prepare db-conn sql)))
(apply dbi-execute (cons query (append (hash-table-values attr-hash) (list key-value))))))
(define (db-insert db-conn table-name attr-hash)
(let* ((places (map (lambda(c) "?") (hash-table-keys attr-hash)))
(sql #`"INSERT INTO ,table-name (,(string-join (hash-table-keys attr-hash) \",\")) VALUES (,(string-join places \",\"))")
(query (dbi-prepare db-conn sql)))
(apply dbi-execute (cons query (hash-table-values attr-hash)))))
今回はRDBプログラミングを行うためにORマッパーを作ってみました。ここではGaucheのオブジェクトシステムを使ってみましたが、JavaやC++などのオブジェクトシステムとはかなり違うことを感じていただけたと思います。オブジェクト指向の実装方式はJavaやC++などのオブジェクトシステムが唯一ではないのです。
ORマッパーはそれなりの大きさになりましたが、Javaなどで作るのに比べたらかなり少ないコードでできたと思います。これは、Gaucheの持つオブジェクトシステムの柔軟さ、クラス定義なども動的に行えることに加え、map、foldなどのイテレータもコンパクトなコードを作るのに役立っているからです。
Copyright © ITmedia, Inc. All Rights Reserved.
関連記事
- いまさらアルゴリズムを学ぶ意味
コーディングに役立つ！ アルゴリズムの基本（1） コンピュータに「3の倍数と3の付く数字」を判断させるにはどうしたらいいか。発想力を鍛えよう - Zope 3の魅力に迫る
Zope 3とは何ぞや？（1） Pythonで書かれたWebアプリケーションフレームワーク「Zope 3」。ほかのソフトウェアとは一体何が違っているのか？ - 貧弱環境プログラミングのススメ
柴田 淳のコーディング天国 高性能なIT機器に囲まれた環境でコンピュータの動作原理に触れることは可能だろうか。貧弱なPC上にビットマップの直線をどうやって引く？ - Haskellプログラミングの楽しみ方
のんびりHaskell（1） 関数型言語に分類されるHaskell。C言語などの手続き型言語とまったく異なるプログラミングの世界に踏み出してみよう - ちょっと変わったLisp入門
Gaucheでメタプログラミング（1） Lispの一種であるScheme。いくつかある処理系の中でも気軽にスクリプトを書けるGaucheでLispの世界を体験してみよう