[Common Lisp] SQL その2

結局のところこんなふうになった。

(defaction todo ()
  (default-template (:title "TODO リスト")
    (html (:h1 "TODO リスト do-query #q")
          (:form
           (:input :type :text :name :q))
          (:table :border 1
                  (do-query
                      ((append #q(select * from todo)
                               (when @q #q(where content like :param)))
                       :param (string+ "%" @q "%"))
                    (html (:tr (:td $id)
                               (:td $content)
                               (:td $done))))))))

#q リーダマクロで SQL をそのまま書けるようにした。懐かしの埋め込み SQL だ。コンマとシングルクォートを set-macro-character しただけだが、結構 SQL をまともに read できそう。さすが Common Lisp.

SQL 中のパラメータはキーワードシンボルにして、キーワード引数で指定する。

検索結果は alist にしておいて $ で始まるシンボルで参照する。なので $ で始まるシンボルは (ASSOC "CONTENT" #:ASSOC1320 :TEST #'STRING-EQUAL) な感じにマクロ展開する。

• SQL 文は入力によって検索条件が変わるので実行時でないとクエリが確定しない。
• select * を使うと検索結果の列名はクエリ実行でないと分からない。

というような理由で実行時にがんばってしまうコードをはくマクロとなってしまった。効率悪そう。でも某フレームワークでは eval 使いまくっているって噂だから、まあいいか。

(defmacro with-db (var &body body)
  `(clsql:with-database (,var *connection-spec*
                              :database-type *database-type*
                              :if-exists :new
                              :pool t
                              :make-default nil)
     ,@body))

(defun |#q-quote-reader| (stream char)
  (declare (ignore char))
  (with-output-to-string (out)
    (loop for c = (read-char stream t nil t)
          until (and (char= #\' c)
                     (char/= #\' (peek-char nil stream nil #\a t)))
          do (progn
               (write-char c out)
               (when (char= c #\')
                 (read-char stream))))))

(defun |#q-reader| (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (let ((*readtable* (copy-readtable nil)))
    (set-macro-character #\, {(declare (ignore _x _y)) :|,|})
    (set-macro-character #\' #'|#q-quote-reader|)
    `(quote ,(read stream t nil t))))

(set-dispatch-macro-character #\# #\q #'|#q-reader|)

(defgeneric >sql (x)
  (:method (x)
    (princ-to-string x))
  (:method ((x string))
    (string+ #\' (cl-ppcre:regex-replace-all "'" x "''") #\'))
  (:method ((x symbol))
    (substitute #\_ #\- (symbol-name x))))

(defun sexp>sql (sexp)
  (with-output-to-string (out)
    (loop for i in sexp
          do (typecase i
               (symbol (princ (>sql i) out))
               (list
                  (princ "(" out)
                  (princ (sexp>sql i) out)
                  (princ ")" out))
               (t (princ (>sql i) out)))
          do (princ " " out))))

(defun substitute-query-parameters (query parameters)
  (if parameters
      (substitute-query-parameters
       `(substitute ,(cadr parameters) ,(car parameters) ,query)
       (cddr parameters))
      query))

(defun make-query-result-assoc (row fields)
  (loop for r in row
        for f in fields
        collect (cons f r)))

(defmacro! do-query ((query &rest params) &body body)
  (labels ((result-symbol-p (x)
             (and (symbolp x) (head-p x "$")))
           (key-string (x)
             (subseq (symbol-name x) 1))
           (walk-body (body assoc)
             (if (atom body)
                 (if (result-symbol-p body)
                     `(cdr (assoc ,(key-string body) ,assoc
                                  :test #'string-equal))
                     body)
                 (cons (walk-body (car body) assoc)
                       (walk-body (cdr body) assoc)))))
    `(multiple-value-bind (,g!result ,g!field-names)
         (clsql-sys:query (sexp>sql
                           ,(substitute-query-parameters query params)))
       (loop for ,g!row in ,g!result
             for ,g!assoc = (make-query-result-assoc ,g!row ,g!field-names)
             do ,@(walk-body body g!assoc)))))