SchemeQLをGaucheで使ってみました (Gauche-devel-jp) - Gauche

えんどうです。

http://schematics.sourceforge.net/schemeql.html

shiroさんにマクロを教えていただきながら、SchemeQL↑をGaucheで使ってみました。

まず schemeql.scm を checkout します。

 cvs -d :pserver:anony****@cvs*****:/cvsroot/schematics login

 cvs -d :pserver:anony****@cvs*****:/cvsroot/schematics co -r 1.4.2.7 schemeql/sql.scm

PLTのdefine-structやopt-lambdaを使うために、以下を定義します。

;; SchemeQL の sql.scm をとりあえず動くようにするための諸定義
;; SchemeQL の connection.scm、util.scmから持って来ちゃった部分があるのでLGPLです。

(use srfi-9)

(define-macro (define-struct name fields)
  (let ((constructor (string->symbol #`"make-,|name|"))
	(predicate (string->symbol #`",|name|?"))
	(acc&mods (map (lambda (field)
			 (list field
			       (string->symbol #`",|name|-,|field|")
			       (string->symbol #`"set-,|name|-,|field|!")))
		       fields)))
    `(define-record-type
       ,name
       (,constructor , ＠ fields)
       ,predicate
       , ＠ acc&mods)))

(define-macro (opt-lambda formals . body)
  (let ((args (gensym)))
    (let loop ((formals formals)
               (mandatory '())
               (optional  '()))
      (cond ((null? formals)
             `(lambda (,@(reverse! mandatory) . ,args)
                (let-optionals* ,args ,(reverse! optional)
                  , ＠ body)))
            ((pair? (car formals))
             (loop (cdr formals) mandatory (cons (car formals) optional)))
            (else
             (loop (cdr formals) (cons (car formals) mandatory) optional))))))

;; SchemeQLのodbc.scm、connection.scm、util.scmから必要な定義だけもってきます。

;; from odbc.scm
(define driver-roll-cursor
  (opt-lambda (result (orient 'next) (rownum #f))
    (when rownum
      (if (number? rownum)
	  (when (not (memq orient '(absolute relative bookmark)))
	    ;; We ignore rownum if it doesn't make sense.
	    (set! rownum #f))
	  (raise-type-error 'driver-roll-cursor "integer" rownum)))

    (if (extended-result? result)
	(let* ((hstmt (extended-result-hstmt result))
	       (orientation (case orient
			      ((first) 'sql-fetch-first)
			      ((next)  'sql-fetch-next)
			      ((prior) 'sql-fetch-prior)
			      ((last)  'sql-fetch-last)
			      ((absolute) 'sql-fetch-absolute)
			      ((relative) 'sql-fetch-relative)
			      (else
			       (raise (make-schemeql-unknown-orientation
				       (format "Invalid orientation given: ~a" orient)
				       (current-continuation-marks))))))
	       (buffs (extended-result-buffers result))
	       (fetch (lambda (h)
			(if (>= (sister-ver) 3.0)
			    (if rownum
				(sr:fetch-scroll h orientation rownum)
				(sr:fetch-scroll h orientation))
			    (if rownum
				(sr:extended-fetch h orientation rownum)
				(sr:extended-fetch h orientation))))))
	  ;; Note that we re-use the buffers from the `already' open cursor.
	  (set-result-cursor!
	   result
	   (format-list-cursor hstmt buffs fetch))
	  ;; Finally we returned the modified extended-result:
	  result)
	;; Sorry, but if this is not an extended-result, then it is
	;; NOT a cursor.
	(raise-type-error 'driver-roll-cursor "extended-result" result))))

(define driver-close-cursor
  (lambda (result)
    (if (extended-result? result)
	(begin
	  ;; Freeing buffers:
	  (for-each sr:free-buffer! (extended-result-buffers result))
	  ;; Freeing the handle:
	  (if (>= (sister-ver) 3.0)
	      (sr:free-handle (extended-result-hstmt result))
	      (sr:free-stmt (extended-result-hstmt result) 'sql-close))
	  ;; Setting the cursor to a dummy null-cursor
	  (set-result-cursor! result null-cursor))
	(raise-type-error 'driver-close-cursor "extended-result" result))))

;; from connection.scm
(define-struct connection (source user passwd db hdbc support))

;; from util.scm
(define string-or-symbol?
  (lambda (x)
    (or (string? x) (symbol? x))))

  (define join
    (lambda (lst sep)
      (let ((out (open-output-string)))
	(cond ((null? lst) "")
	      ((pair? lst)
	       (display (car lst) out)
	       (let loop ((lst (cdr lst)))
		 (cond ((null? lst) (get-output-string out))
		       (else
			(display sep out)
			(display (car lst) out)
			(loop (cdr lst))))))
	      (else
	       (raise-type-error 'join "list" lst))))))

;; adnmap の定義を下記からもってきます。

;; from <http://cvs.sourceforge.net/viewcvs.py/jscheme/jscheme/src/elf/mbe.scm?rev=1.2>
(define ormap
  (lambda (f l)
    (let loop ((l l))
      (if (null? l) #f
          (or (f (car l)) (loop (cdr l)))))))

(define andmap
  (lambda (f l)
    (let loop ((l l))
      (if (null? l) #t
          (and (f (car l)) (loop (cdr l)))))))

;; checkout した schemeql からロードできるようにします。

(add-load-path "/home/yasuyuki/schemeql")

;; sql.scm を load します。

(load "sql.scm")

;; ためしに drop-table を make してみます。

(define test (drop-table "test"))

;; test を SQL 文字列に変換してみます。

(schemeql-pretty-print test)

上記を評価すると以下が返ります。

 "DROP TABLE test"

SchemeQL がやっているのは、

 - define-sturct でSQLのいろんな構文を定義している
 - それらを make するとstructオブジェクトが返る
 - そのオブジェクトを schemeql-pretty-print に食わせるとSQL文字列が返る

ということのようです。

SchemeQL のライセンスは LGPL なので、
ScmemeQL の派生物を再配布する場合は LGPL が適用されます。

-- 
ENDO Yasuyuki <yasuy****@javao*****>
http://www.javaopen.org/~yasuyuki/ (Personal/Japanese Only)
http://www.javaopen.org/jfriends/ (Japanese Only)

Gauche

[Gauche-devel-jp] SchemeQLをGaucheで使ってみました