cl-gtk2はgladeで作成したファイルを利用できるようなので遊んで見ました。
ソースコード
(asdf:load-system :cl-gtk2-glib)
(asdf:load-system :cl-gtk2-gdk)
(asdf:load-system :cl-gtk2-cairo)
(asdf:load-system :closure-html)
(asdf:load-system :cxml-stp)
(asdf:load-system :drakma)
(asdf:load-system :cl-ppcre)
(asdf:load-system :cl-interpol)
(defpackage :gtk-user
(:use :cl)
(:export run))
(in-package :gtk-user)
(cl-interpol:enable-interpol-syntax)
(setf drakma:*drakma-default-external-format* :utf-8)
(defun reference-of (node)
(let ((tag (stp:local-name node)))
(cond
((string= tag "a")
(or (stp:attribute-value node "href") ""))
((string= tag "img")
(or (stp:attribute-value node "src") ""))
((string= tag "link")
(or (stp:attribute-value node "href") ""))
((string= tag "script")
(or (stp:attribute-value node "src") ""))
(T ""))))
(defun text-of (node)
(let ((text (stp:string-value node)))
(if (> (length text) 30)
(concatenate 'string (subseq text 0 27 ) "...")
text)))
;; ありそうな文字コードを総当たりで試す。富豪的富豪的。
(defun octets-to-string-by-error-handler (octets)
(let ((formats (list :shift_jis :utf-8 :euc-jp :eucjp
:sjis
:utf-16 :utf-16BE :utf-16le
:utf-32 :utf-32be :utf-32le
:utf-8b )))
(tagbody
:retry
(print formats)
(handler-case
(return-from octets-to-string-by-error-handler
(sb-ext:octets-to-string octets :external-format (pop formats)))
(error (e)
(declare (ignore e))
(if formats
(go :retry)
(error "can't convert octets to string")))))))
(defun get-http-body-string (url)
(multiple-value-bind
(arr code headers url stream)
(drakma:http-request url :external-format-in :binary)
(let ((content-type (cdr (find :content-type headers :test #'string= :key #'car))))
(if content-type
(cl-ppcre:register-groups-bind (charset)
((cl-ppcre:create-scanner #?/charset=(\w+)/ :case-insensitive-mode t)
content-type)
;; todo
(octets-to-string-by-error-handler arr))))))
(defun run ()
(let ((out *standard-output*))
(gtk:within-main-loop
(let* ((builder
(make-instance 'gtk:builder
:from-file "/path/to/GladeTest.glade"))
(window (gtk:builder-get-object builder "ToplevelWindow"))
(entry (gtk:builder-get-object builder "entry1"))
(button (gtk:builder-get-object builder "button1"))
(tree (gtk:builder-get-object builder "treeview1"))
;; treeview1のmodelは後で上書きする
(dummy (gtk:builder-get-object builder "liststore1"))
(liststore (make-instance 'gtk:array-list-store)))
;; treeview1のmodelを上書き
(setf (gtk:tree-view-model tree) liststore)
;; tree-viewの列(model)
(gtk:store-add-column liststore "gchararray" #'stp:local-name)
(gtk:store-add-column liststore "gchararray" #'text-of)
(gtk:store-add-column liststore "gchararray" #'reference-of)
;; tree-viewの列(view)
(let ((col-tag (make-instance 'gtk:tree-view-column :title "タグ"))
(col-text (make-instance 'gtk:tree-view-column :title "text"))
(col-ref (make-instance 'gtk:tree-view-column :title "参照先"))
(cr (make-instance 'gtk:cell-renderer-text)))
(gtk:tree-view-column-pack-start col-tag cr)
(gtk:tree-view-column-add-attribute col-tag cr "text" 0)
(gtk:tree-view-column-pack-start col-text cr)
(gtk:tree-view-column-add-attribute col-text cr "text" 1)
(gtk:tree-view-column-pack-start col-ref cr)
(gtk:tree-view-column-add-attribute col-ref cr "text" 2)
(gtk:tree-view-append-column tree col-tag)
(gtk:tree-view-append-column tree col-text)
(gtk:tree-view-append-column tree col-ref))
;; ボタンクリック時の動作
(gobject:g-signal-connect
button "clicked"
(lambda (b)
(handler-case
(let* ((str (get-http-body-string (gtk:entry-text entry)))
(doc (chtml:parse str (cxml-stp:make-builder))))
(stp:do-recursively (node doc)
(when
(and
(typep node 'stp:element)
(some
(lambda (s) (string-equal s (stp:local-name node)))
'("a" "link" "script" "img")))
(gtk:store-add-item liststore node))))
(error (e)
(let ((diag (make-instance 'gtk:message-dialog
:text (format nil
"error:(~A) ~A"
(gtk:entry-text entry)
e)
:message-type :error)))
(unwind-protect (gtk:dialog-run diag)
(gtk:object-destroy diag)))))))
(gtk:widget-show window)))))
gladeファイル
<?xml version="1.0" encoding="UTF-8"?>
<interface>
<requires lib="gtk+" version="2.16"/>
<!-- interface-naming-policy toplevel-contextual -->
<object class="GtkWindow" id="ToplevelWindow">
<property name="title" translatable="yes">ToplevelWindow</property>
<child>
<object class="GtkVBox" id="vbox3">
<property name="visible">True</property>
<child>
<object class="GtkHBox" id="hbox1">
<property name="height_request">30</property>
<property name="visible">True</property>
<child>
<object class="GtkLabel" id="label5">
<property name="visible">True</property>
<property name="label" translatable="yes">URL:</property>
</object>
<packing>
<property name="expand">False</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="entry1">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="invisible_char">•</property>
</object>
<packing>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkButton" id="button1">
<property name="label" translatable="yes">読み込み</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="position">2</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkTreeView" id="treeview1">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="model">liststore1</property>
</object>
<packing>
<property name="position">1</property>
</packing>
</child>
</object>
</child>
</object>
<object class="GtkListStore" id="liststore1"/>
</interface>
利用しているライブラリはすべてquicklispでインストールできます。
ライブラリのおおまかな内容は以下のとおり。
- cl-gtk2-*** : GTKバインディング
- closure-html : HTMLパーサー
- cxml-stp : DOMに似たもの
- cl-ppcre : 正規表現
- drakma : HTTPクライアント
- cl-interpol : リーダーの拡張。正規表現リテラルに利用。
sb-ext:octets-to-stringを利用しているのでSBCLでのみ動作します。他の処理系で動作ささせる場合、バイト列を文字列に変換する箇所を変更する必要があります。
(gtk-user::run) を評価するとテキストボックス(entry)を持ったウィンドウが表示されます。このテキストボックスにURLを入力して隣のボタンをクリックすると、URLの内容(HTML)を取得し、他のURLへを参照していそうなa/link/img/scriptタグを抜き出してtree-viewに表示します。
わかりづらかった点として、gtk:array-list-storeがCommonLisp側で定義されたクラスだということがありました。 array-list-storeは便利そうだと思いましたが、GTK側に組み込まれているクラスではないので、 Gladeでモデルに指定できない(ような気がします)。
0 件のコメント:
コメントを投稿