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

近代化

さて、ここまで駆け足で作ってきたのだが、改めて見直してみると 色々気になることがある。

• 生成されるHTMLドキュメントにdoctype宣言がない。ので行儀が悪い。
• 予定を見るだけでもtextareaが表示されるのは何だなあ。
• 予定のある日と無い日くらいはカレンダーで見分けたい
• dbへのアクセス部分がなんか汚い

そこで、気になるところをちょこまか直していってみよう。 ここで肝心なのは、インクリメンタルに変更してゆくこと、 つまり、常に動く状態にしつつ変えて行くことである。 一度にいくつものことがらを変えようとしたり、全く動かない状態に してしまうより、いつでも動いているものを手元に持っておく方が ずっと気が楽だ。

dbまわりの抽象化

現在は、dbアクセスが必要になったところでdbをオープンしている。 これは必要最小限しかdbに触らないという意味では好ましいのだけれど、 例えば予定のある日をカレンダーで色つけしたい、なんてことを 考えるとそこでまたdbのオープンが必要になったりして、 コードがちらかってくる。性能はたいして問題にならないスクリプトだし、 コマンドの処理を行っている時は常にデータベースがオープンされている ようにしてもあまり問題はないだろう。

さて、オープンされてるデータベースはあちこちから参照されるから、 グローバルに見えていてほしい。グローバル変数を使ってもいいんだけど、 グローバルな状態を変数に直接置いとくのは、なんとなく後ろめたい。 だってグローバル変数は使わない方がいいって習わなかった?

パラメータを使うと、後ろめたさを感じずにグローバルな状態を扱うことができる。

(use gauche.parameter)

(define db (make-parameter #f))

いや、そもそも「グローバル変数」云々ってのはSchemeだとちょっと意味が 怪しくて、というのは関数定義だってグローバルな変数へのlambdaクロージャの 束縛にすぎないからね。気持ちが悪いのは、グローバルな束縛がプログラムの 実行中に変化してゆくこと---そのために特定時点でのプログラムの意味を 把握するのが難しくなること、なんだ。

(このことは、ひとことでは説明しにくいけれど、ひとつ例をあげてみよう。 この開発の最初の頃にやったように、低レベルの細かい関数を書いた時に それをインタラクティブに実行して確かめてみるってことはよくやるよね。 もしそこで、そういう低レベル関数の動作がたくさんのグローバル変数に 依存してたとしたら? 関数のデバッグ中なんかに、途中のエラーによって グローバル変数の状態が意図しない値になってしまうことは良くある。 その状態で低レベル関数を走らせて、思うように動かなくて悩むことになる)。

パラメータは、グローバルな状態を関数で包むようなものだ。上のように 書いておくと、 関数呼び出し(db)でパラメータの現在の値が返されて、 (db <value>) でパラメータにあらたな値を与えることができる。

もっとも、(db <value>)で無秩序に値を変更してしまっては、グローバル変数と 同じことになるので、どうしても必要な場合以外は避けたほうがいい。 替わりに、parameterizeというマクロを使う。

(parameterize (db <value>)
  body ...)

このマクロは、bodyの実行中「だけ」パラメータdbの値を<value>に変える。 bodyが終了したり、エラーで脱出したりした時にはdbの値はparameterize 呼び出し前の値に復元される。(さらに、継続を使ったコルーチン呼び出しで 制御が外側に移った時にもdbの値は復元される。もういちどbody内の継続が 呼び出されれば、再びdbの値は<value>になる)。

他にもparameterはいくつか便利な機能があるので、GaucheRefj:gauche.parameter を参照されたし。

さて、parameterの話ばかりしててもしかたない。もうひとつ大事なのは、 何があっても開いたデータベースは閉じることだ。そのへんをマクロに閉じ込めて しまおう。ついでに、DBのキーを生成するところも低レベルで汚いから 関数にして抽象化しておく。

(define-syntax with-db
  (syntax-rules ()
    ((with-db (db path) . body)
     (parameterize ((db (dbm-open <gdbm> :path path :rw-mode :write)))
       (with-error-handler (lambda (e) (dbm-close (db)) (raise e))
         (lambda ()
           (begin0
            (begin . body)
            (dbm-close (db)))))))))

(define (db-key y m d) #`",|y|-,|m|-,|d|")

このマクロによって、main関数の方でコマンドの処理をこんなふうに囲っておけば：

    (with-db (db *db-name*)
       (if (and y m d)
         (if (equal? cmd "e")
           (cmd-change-plan y m d plan)
           (cmd-show-plan y m d))
         (cmd-show-calendar y m))

各コマンド内では (db) でオープンされたdbが得られるというわけだ。 例えばcmd-change-planはこんなふうになる。

(define (cmd-change-plan y m d plan)
  (dbm-put! (db) (db-key y m d) plan)
  (cgi-header :status "302 Moved"
              :location #`"?y=,|y|&m=,|m|&d=,|d|"))

cmd-show-planも同様に変えればよい。

予定のある日に色をつける

さて、これで主要な処理中はどこでもデータベースにアクセスできるようになった。 予定のある日に色をつけるには、日付のセルを生成する関数内で 予定の有無を調べて処理を変えればいい。

(define (date-cell year month date)
  (if date
    (html:a :href #`"?y=,|year|&m=,|month|&d=,|date|"
            (if (dbm-exists? (db) (db-key year month date))
              (html:span :class "planned" date)
              date))
    ""))

ここではあくまでお行儀良く、spanで囲っといてCSSで色をつけさせることにしよう。

(define *style* "
  span.planned {
    background-color : #ffcccc;
  }
 ")

(define (page . content)
  `(,(cgi-header
      :content-type #`"text/html; char-set=,(gauche-character-encoding)")
    ,(html-doctype :type :xhtml-1.0-transitional)
    ,(html:html
      (html:head (html:title "簡易スケジュール表")
                 (html:style :type "text/css" *style*))
      (apply html:body content))))

CSSを*style*で定義しといて、pageの定義を変えてそれをhead内に 埋め込むようにしてみた。ついでに、doctypeも生成するようにしている。

予定表示と編集の分離

さてあとひとつ、予定の表示にtextareaを使わないようにしてみよう。 cmd-show-planは予定をpreタグで表示するだけにする。

(define (cmd-show-plan y m d)
  (let1 plan (dbm-get (db) (db-key y m d) "")
    (page
     (calendar (make-month m y))
     (html:p #`",|y|年,|m|月,|d|日の予定")
     (html:pre (html-escape-string plan))
     (html:a :href #`"?y=,|y|&m=,|m|&d=,|d|&c=e" "[予定を編集]"))))

で、「予定を編集」リンクがクリックされたら、textareaで表示。 前回までと違って、 c=e で編集ウィンドウにしたから、コミットは c=c で やることにしよう。

(define (cmd-edit-plan y m d)
  (let1 plan (dbm-get (db) (db-key y m d) "")
    (page
     (html:form
      (html:p #`",|y|年,|m|月,|d|日の予定")
      (html:input :type "hidden" :name "c" :value "c")
      (html:input :type "hidden" :name "y" :value (x->string y))
      (html:input :type "hidden" :name "m" :value (x->string m))
      (html:input :type "hidden" :name "d" :value (x->string d))
      (html:p (html:textarea :rows 8 :cols 40 :name "p"
                             (html-escape-string plan)))
      (html:p (html:input :type "submit" :name "submit" :value "変更"))))))

これで、mainをこんなふうにしとけばいい。

(define (main args)
  (cgi-main
   (lambda (params)
     (let ((y (cgi-get-parameter "y" params :convert x->integer))
           (m (cgi-get-parameter "m" params :convert x->integer))
           (d (cgi-get-parameter "d" params :convert x->integer))
           (cmd (cgi-get-parameter "c" params))
           (plan (cgi-get-parameter "p" params
                                    :convert (cut ces-convert <> "*jp"))))
       (with-db (db *db-name*)
         (if (and y m d)
           (cond 
            ((equal? cmd "e")
             (cmd-edit-plan y m d))
            ((equal? cmd "c")
             (cmd-change-plan y m d plan))
            (else
             (cmd-show-plan y m d)))
           (cmd-show-calendar y m))
         )))))

予定の消去

一度でも予定を入れちゃうと、カレンダーに色がついて、このままでは それを消すことができない。間違って予定を入れちゃったらちょっと不便。 そこでついでに、予定を消せるようにもしとく。 予定の編集画面で、全部テキストを消してコミットしたらdbから消すことにする。

(define (cmd-change-plan y m d plan)
  (if (and plan (not (string=? plan "")))
    (dbm-put! (db) (db-key y m d) plan)
    (dbm-delete! (db) (db-key y m d)))
  (cgi-header :status "302 Moved"
              :location #`"?y=,|y|&m=,|m|&d=,|d|"))

まとめ

ここまでまとめるとこんな感じ。

#!/usr/bin/env gosh
(use srfi-1)
(use srfi-19)
(use util.list)
(use text.html-lite)
(use gauche.sequence)
(use gauche.charconv)
(use gauche.parameter)
(use dbm.gdbm)
(use www.cgi)

(define *db-name* "/home/shiro/data/cal.data")

(define *style* "
  span.planned {
    background-color : #ffcccc;
  }
 ")

;;;
;;; Calendar Logic
;;;
(define (make-month m y)
  (make-date 0 0 0 0 1 m y (date-zone-offset (current-date))))

(define (first-day-of-month date)
  (make-month (date-month date) (date-year date)))

(define (days-of-month date)
  (inexact->exact
   (- (date->modified-julian-day (next-month date))
      (date->modified-julian-day (first-day-of-month date)))))

(define (next-month date)
  (if (= (date-month date) 12)
    (make-month 1 (+ (date-year date) 1))
    (make-month (+ (date-month date) 1) (date-year date))))

(define (prev-month date)
  (if (= (date-month date) 1)
    (make-month 12 (- (date-year date) 1))
    (make-month (- (date-month date) 1) (date-year date))))

;; returns list slices for calendar. 
(define (date-slices-of-month date)
  (slices (append (make-list (date-week-day (first-day-of-month date)) #f)
                  (iota (days-of-month date) 1))
          7 #t #f))

;;;
;;; DB
;;;
(define db (make-parameter #f))

(define-syntax with-db
  (syntax-rules ()
    ((with-db (db path) . body)
     (parameterize ((db (dbm-open <gdbm> :path path :rw-mode :write)))
       (with-error-handler (lambda (e) (dbm-close (db)) (raise e))
         (lambda ()
           (begin0
            (begin . body)
            (dbm-close (db)))))))))

(define (db-key y m d) #`",|y|-,|m|-,|d|")

;;;
;;; Display
;;;
(define (month->link date content)
  (html:a :href #`"?y=,(date-year date)&m=,(date-month date)" content ))

(define (date-cell year month date)
  (if date
    (html:a :href #`"?y=,|year|&m=,|month|&d=,|date|"
            (if (dbm-exists? (db) (db-key year month date))
              (html:span :class "planned" date)
              date))
    ""))

(define (calendar date)
  (html:table
   (html:tr (html:td (month->link (prev-month date) "←"))
            (html:td :colspan 5 :align "center"
                     #`",(date-year date)/,(date-month date)")
            (html:td (month->link (next-month date) "→")))
   (html:tr (map html:td "日月火水木金土"))
   (map (lambda (w)
          (html:tr
           (map (lambda (d)
                  (html:td (date-cell (date-year date) (date-month date) d)))
                w)))
        (date-slices-of-month date))))

(define (page . content)
  `(,(cgi-header
      :content-type #`"text/html; char-set=,(gauche-character-encoding)")
    ,(html-doctype :type :xhtml-1.0-transitional)
    ,(html:html
      (html:head (html:title "簡易スケジュール表")
                 (html:style :type "text/css" *style*))
      (apply html:body content))))

;;;
;;; Commands
;;;
(define (cmd-show-calendar y m)
  (page
   (if (and y m (<= 1 m 12) (<= 1753 y))
     (calendar (make-month m y))
     (calendar (current-date)))))

(define (cmd-show-plan y m d)
  (let1 plan (dbm-get (db) (db-key y m d) "")
    (page
     (calendar (make-month m y))
     (html:p #`",|y|年,|m|月,|d|日の予定")
     (html:pre (html-escape-string plan))
     (html:a :href #`"?y=,|y|&m=,|m|&d=,|d|&c=e" "[予定を編集]"))))

(define (cmd-edit-plan y m d)
  (let1 plan (dbm-get (db) (db-key y m d) "")
    (page
     (html:form
      (html:p #`",|y|年,|m|月,|d|日の予定")
      (html:input :type "hidden" :name "c" :value "c")
      (html:input :type "hidden" :name "y" :value (x->string y))
      (html:input :type "hidden" :name "m" :value (x->string m))
      (html:input :type "hidden" :name "d" :value (x->string d))
      (html:p (html:textarea :rows 8 :cols 40 :name "p"
                             (html-escape-string plan)))
      (html:p (html:input :type "submit" :name "submit" :value "変更"))))))

(define (cmd-change-plan y m d plan)
  (if (and plan (not (string=? plan "")))
    (dbm-put! (db) (db-key y m d) plan)
    (dbm-delete! (db) (db-key y m d)))
  (cgi-header :status "302 Moved"
              :location #`"?y=,|y|&m=,|m|&d=,|d|"))

;;;
;;; Main entry
;;;
(define (main args)
  (cgi-main
   (lambda (params)
     (let ((y (cgi-get-parameter "y" params :convert x->integer))
           (m (cgi-get-parameter "m" params :convert x->integer))
           (d (cgi-get-parameter "d" params :convert x->integer))
           (cmd (cgi-get-parameter "c" params))
           (plan (cgi-get-parameter "p" params
                                    :convert (cut ces-convert <> "*jp"))))
       (with-db (db *db-name*)
         (if (and y m d)
           (cond 
            ((equal? cmd "e")
             (cmd-edit-plan y m d))
            ((equal? cmd "c")
             (cmd-change-plan y m d plan))
            (else
             (cmd-show-plan y m d)))
           (cmd-show-calendar y m))
         )))))

;; Local variables:
;; mode: scheme
;; end: