weblocksの勉強
/clbuild/source/weblocks/examples/にサンプルが入っている。
simple-blogっていうのが入っているので、これを見ながらもう少しweblocksをいじってみたい。
blogというか掲示板というか、まぁ勉強用なので中途半端なアプリを作ってみる。
実際のところ、どう動いているのかさっぱりわかっていないので、examplesのsimpleblogを参考にしてながら少しづづいじる。
まずは単純にuserのメンテナンス部分。
(eval-when (:compile-toplevel :load-toplevel :execute) (require :weblocks) (require :clsql)) (defpackage #:weblocks07 (:use #:common-lisp #:weblocks #:clsql)) (in-package :weblocks07) (weblocks:start-weblocks :debug t) (weblocks:defwebapp weblocks07 :prefix "/weblocks07/") (clsql:def-view-class users () ((id :accessor id :initarg :id :type integer :db-kind :key :db-constraint (:unique :not-nll)) (name :accessor name :initarg :name :type (clsql:varchar 20)))) (weblocks:defstore *sql-store* :clsql '("localhost" "xxx" "xxx" nil) :database-type :postgresql-socket) (ignore-errors (clsql:create-view-from-class 'users)) (Weblocks:Defview users-table-view (:type table :inherit-from '(:scaffold users))) (Weblocks:Defview users-data-view (:type data :inherit-from '(:scaffold users))) (Weblocks:Defview users-form-view (:type form :inherit-from '(:scaffold users))) (defun init-user-session (comp) (setf (weblocks:composite-widgets comp) (make-instance 'gridedit :name 'users-grid :data-class 'users :widget-prefix-fn #'(lambda (&rest args) (declare (ignore args)) (weblocks:with-html (:h1 "ユーザ"))) :view 'users-table-view :item-data-view 'users-data-view :item-form-view 'users-form-view)))
ここまででまずはuserのメンテナンス画面ができる。こんな感じ。
次に投稿をポストできるようにしよう。
(clsql:def-view-class post () ((id :accessor id :initarg :id :type integer :db-kind :key :db-constraint (:unique :not-nll)) (title :accessor title :initarg :title :type (clsql:varchar 100)) (message :accessor message :initarg :message :type (clsql:varchar 500)) (post-time :accessor post-time :initarg :post-time :initform (get-universal-time) :type clsql:universal-time) (user-id :accessor user-id :initarg :user-id :type integer)))
ポストのdaoをdef-view-classで作る。
post-timeに日付、時刻を入れたいのでtypeにclsql:universal-timeを指定したのだけど、これだと更新できない。
うーん。なんでだ。
分からないからもうpost-timeは文字列にしちゃう。
(eval-when (:compile-toplevel :load-toplevel :execute) (require :weblocks) (require :clsql)) (defpackage #:weblocks07 (:use #:common-lisp #:weblocks #:clsql)) (in-package :weblocks07) (weblocks:start-weblocks :debug t) (weblocks:defwebapp weblocks07 :prefix "/weblocks07/") (clsql:def-view-class users () ((id :accessor id :initarg :id :type integer :db-kind :key :db-constraint (:unique :not-nll)) (name :accessor name :initarg :name :type (clsql:varchar 20)))) (clsql:def-view-class post () ((id :accessor id :initarg :id :type integer :db-kind :key :db-constraint (:unique :not-nll)) (title :accessor title :initarg :title :type (clsql:varchar 100)) (message :accessor message :initarg :message :type (clsql:varchar 500)) (post-time :accessor post-time :initarg :post-time :initform (multiple-value-bind (s m h dd mm yy) (decode-universal-time (get-universal-time)) (format nil "~d/~d/~d ~d:~d:~d" yy mm dd h m s)) :type (clsql:varchar 20)) (user-id :accessor user-id :initarg :user-id :type integer))) (weblocks:defstore *sql-store* :clsql '("localhost" "xxx" "xxx" nil) :database-type :postgresql-socket) (ignore-errors (clsql:create-view-from-class 'users)) (ignore-errors (clsql:create-view-from-class 'post)) (Weblocks:Defview users-table-view (:type table :inherit-from '(:scaffold users))) (Weblocks:Defview users-data-view (:type data :inherit-from '(:scaffold users))) (Weblocks:Defview users-form-view (:type form :inherit-from '(:scaffold users))) (Weblocks:Defview post-table-view (:type table :inherit-from '(:scaffold post))) (Weblocks:Defview post-data-view (:type data :inherit-from '(:scaffold post))) (Weblocks:Defview post-form-view (:type form :inherit-from '(:scaffold post))) (defun make-users-gridedit () (make-instance 'gridedit :name 'users-grid :data-class 'users :widget-prefix-fn #'(lambda (&rest args) (declare (ignore args)) (weblocks:with-html (:h1 "ユーザ"))) :view 'users-table-view :item-data-view 'users-data-view :item-form-view 'users-form-view)) (defun make-post-gridedit () (make-instance 'gridedit :name 'post-grid :data-class 'post :widget-prefix-fn #'(lambda (&rest args) (declare (ignore args)) (weblocks:with-html (:h1 "投稿"))) :view 'post-table-view :item-data-view 'post-data-view :item-form-view 'post-form-view)) (defun init-user-session (comp) (setf (weblocks:composite-widgets comp) (make-instance 'composite :widgets (list (make-users-gridedit) (make-post-gridedit)))))
とりあえずはポストできるようになったが、あまりにもひどいできだ。
以下の点を改善したい。
- postのidは内部的に勝手に連番をふるようにする
- Messageをtextareaにする
- post-timeを読み取り専用にする
- postの入力項目は入力必須にする
- user Idはドロップダウンで選択できるようにする
- postの一覧でuser-idは名前で表示する
postのidは内部的に勝手に連番をふるようにする
これは簡単。
(Weblocks:Defview post-form-view (:type form :inherit-from '(:scaffold post)))
を
(Weblocks:Defview post-form-view (:type form :inherit-from '(:scaffold post)) (id :hidep t))
にすればidはweblocksが連番を振ってくれる。
Messageをtextareaにする
これも簡単。Defviewで:present-asをtextareaにすればいい。
(Weblocks:Defview post-form-view (:type form :inherit-from '(:scaffold post)) (id :hidep t) (message :present-as (textarea :cols 50)))
に変える。
post-timeを読み取り専用にする
これはpost-timeのpresent-asをtextに変えればok
(Weblocks:Defview post-form-view (:type form :inherit-from '(:scaffold post)) (id :hidep t) (message :present-as (textarea :cols 50)) (post-time :present-as text))
postの入力項目は入力必須にする
Defviewで(xxx :requiredp t)とすれば入力必須になる・・・んだけど、user-idを入力必須にするとなんでか更新でエラーになる。
まぁuser-idはドロップダウンで入れさせるようにするからここはスルー。
user-Idはドロップダウンで選択できるようにする
ドロップダウンにするにはpresent-asでdropdownを指定。
それの:choicesにusersから一覧を取得する関数を指定すればok。
表示する値と、裏で持つ値は:label-keyと:value-keyで指定できる。みたい。
(defun all-users (&rest args) (declare (ignore args)) (weblocks:find-persistent-objects (class-store 'users) 'users))
(Weblocks:Defview post-form-view (:type form :inherit-from '(:scaffold post)) (id :hidep t) (title :requiredp t) (message :present-as (textarea :cols 50) :requiredp t) (post-time :present-as text) (user-id :present-as (dropdown :choices #'all-users :label-key #'name :value-key #'id) :parse-as integer :requiredp t))
postの一覧でuser-idは名前で表示する
defviewで:readerに表示する値を変換する関数を指定する。
(defgeneric post-user-name (post) (:method ((post post)) (when (user-id post) (name (weblocks:find-persistent-object-by-id (class-store 'users) 'users (user-id post))))))
(Weblocks:Defview post-table-view (:type table :inherit-from '(:scaffold post)) (user-id :reader #'post-user-name))
・・・ただ、これだと、明細一行毎にusersへselectしにいっている。
ホントならこんなのはないなぁ。。。
ここまでのソースがこちら
(eval-when (:compile-toplevel :load-toplevel :execute) (require :weblocks) (require :clsql)) (defpackage #:weblocks07 (:use #:common-lisp #:weblocks #:clsql)) (in-package :weblocks07) (weblocks:start-weblocks :debug t) (weblocks:defwebapp weblocks07 :prefix "/weblocks07/") (clsql:def-view-class users () ((id :accessor id :initarg :id :type integer :db-kind :key :db-constraint (:unique :not-nll)) (name :accessor name :initarg :name :type (clsql:varchar 20)))) (clsql:def-view-class post () ((id :accessor id :initarg :id :type integer :db-kind :key :db-constraint (:unique :not-nll)) (title :accessor title :initarg :title :type (clsql:varchar 100)) (message :accessor message :initarg :message :type (clsql:varchar 500)) (post-time :accessor post-time :initarg :post-time :initform (multiple-value-bind (s m h dd mm yy) (decode-universal-time (get-universal-time)) (format nil "~d/~d/~d ~d:~d:~d" yy mm dd h m s)) :type (clsql:varchar 20)) (user-id :accessor user-id :initarg :user-id :type integer))) (defun all-users (&rest args) (declare (ignore args)) (weblocks:find-persistent-objects (class-store 'users) 'users)) (defgeneric post-user-name (post) (:method ((post post)) (when (user-id post) (name (weblocks:find-persistent-object-by-id (class-store 'users) 'users (user-id post)))))) (weblocks:defstore *sql-store* :clsql '("localhost" "xxx" "xxx" nil) :database-type :postgresql-socket) (ignore-errors (clsql:create-view-from-class 'users)) (ignore-errors (clsql:create-view-from-class 'post)) (Weblocks:Defview users-table-view (:type table :inherit-from '(:scaffold users))) (Weblocks:Defview users-data-view (:type data :inherit-from '(:scaffold users))) (Weblocks:Defview users-form-view (:type form :inherit-from '(:scaffold users))) (Weblocks:Defview post-table-view (:type table :inherit-from '(:scaffold post)) (user-id :reader #'post-user-name)) (Weblocks:Defview post-data-view (:type data :inherit-from '(:scaffold post))) (Weblocks:Defview post-form-view (:type form :inherit-from '(:scaffold post)) (id :hidep t) (title :requiredp t) (message :present-as (textarea :cols 50) :requiredp t) (post-time :present-as text) (user-id :present-as (dropdown :choices #'all-users :label-key #'name :value-key #'id) :parse-as integer :requiredp t)) (defun make-users-gridedit () (make-instance 'gridedit :name 'users-grid :data-class 'users :widget-prefix-fn #'(lambda (&rest args) (declare (ignore args)) (weblocks:with-html (:h1 "ユーザ"))) :view 'users-table-view :item-data-view 'users-data-view :item-form-view 'users-form-view)) (defun make-post-gridedit () (make-instance 'gridedit :name 'post-grid :data-class 'post :widget-prefix-fn #'(lambda (&rest args) (declare (ignore args)) (weblocks:with-html (:h1 "投稿"))) :view 'post-table-view :item-data-view 'post-data-view :item-form-view 'post-form-view)) (defun init-user-session (comp) (setf (weblocks:composite-widgets comp) (make-instance 'composite :widgets (list (make-users-gridedit) (make-post-gridedit)))))
動いている画面がこんなの。
この辺で今日は力尽きた。
1:nのヘッダとボディがあるテーブルを更新したいときにどうするの？とか、まだまだ疑問は尽きないが。
