2ch-modeでIDに色付け
Jane Styleでは何回も発言したIDに色が付くようなので、
2ch-modeで同様の機能を実装してみることにした。
ある程度まで書いたところで、すでに似たような機能が
公開されていることに気づいたけど、
せっかく作ったのでこっちも公開。
まあ一応こっちは何種類か色をつけられるということで。
というわけで機能について。
- 発言回数に応じてIDの色を変える（*id-color-alist*参照）
- 携帯から（IDの末尾が"O"）の場合はIDに下線を引く
ことができます。
あと、*2ch-extract-regexp*はxyzzy Part12 290-291、300のものを
微妙に改造してますが、向こうのコードもそのまま使えるはず。
;;; 以下を.2ch/config.lに追加
;;; 二回以上発言している ID の色を変える
(defvar *2ch-extract-regexp*
;; 英数字しかマッチしないので ??? はこの段階で除外される。
(compile-regexp "\\(ID:\\||\\)\\([+/0-9a-zA-Z]+\\)●?\\( BE:.+([0-9]+)\\)?\\(]\\||\\|$\\)"))
(defmacro match-id-str ()
`(match-string 2))
(defmacro match-id-beg ()
`(match-beginning 2))
(defmacro match-id-end ()
`(match-end 2))
;; 発言回数や色を変える（追加する）場合はここを変更
(defvar *id-color-alist*
`((5 . 1) ; 5回以上発言した場合は色1
(2 . 4) ; 2回以上発言した場合は色4
(1 . ,*thread-fgcolor-date*))) ; それ以外はデフォルトの色
(defvar-local thread-id-table nil)
(defun mobile-p (id)
(string-match "O$" id))
(defun map-thread-id (func)
(save-excursion
(goto-char (point-min))
(let (from to id)
(while (multiple-value-setq (from to)
(find-text-attribute 'date :start (point)))
(goto-char from)
(scan-buffer *2ch-extract-regexp* :regexp t :limit to)
(when (setf id (match-id-str))
(goto-char (match-id-beg))
(funcall func id))
(goto-char to)))))
(defun collect-thread-id ()
(setf thread-id-table (make-hash-table :test #'equal :size 997))
(map-thread-id
#'(lambda (id)
(setf (gethash id thread-id-table)
(1+ (or (gethash id thread-id-table) 0))))))
(defun change-id-color ()
(map-thread-id
#'(lambda (id)
(let* ((cnt (gethash id thread-id-table))
(pair (find-if #'(lambda (val) (>= cnt val))
*id-color-alist* :key #'first)))
(set-text-attribute (point) (+ (point) (length id)) 'date
:foreground (rest pair)
:underline (mobile-p id))))))
(defun change-id-color-buffer ()
(collect-thread-id)
(change-id-color))
(add-hook '*thread-show-pre-hook* 'change-id-color-buffer)
ファイラからの削除に Windows の標準機能を使う
xyzzy のファイラは便利なんだけど、
大量のファイルが入ったフォルダを "D" でごみ箱に入れようとすると
ものすごく時間がかかる上、
各ファイルはごみ箱の中にばらばらに入れられて元に戻すのも大変。
ファイラでコンテキストメニューから『削除』を選んでやれば
いいだけなんだけど、それを xyzzy lisp から呼び出せないか調べてみた。
おそらく winapi を使えばいいのだろう。
で、調べてみたところ、どうやら shell32.dll 中にある
SHFileOperation という関数を使えばいいらしい（参考）。
引数が構造体なのでいろいろややこしかったが、
試行錯誤の結果以下のようなコードになった。
;;; ごみ箱へ送るを Windows のシェル API で。
(require "wip/winapi")
(in-package "win-user")
(*define-c-type (char *) LPCTSTR)
(*define-c-type u_short FILEOP_FLAGS)
(*define-c-struct LPSHFILEOPSTRUCT
(HWND hwnd)
(u_int wFunc)
(LPCTSTR pFrom)
(LPCTSTR pTo)
(FILEOP_FLAGS fFlags)
(BOOL fAnyOperationsAborted)
(LPVOID hNameMappings)
(LPCTSTR lpszProgressTitle))
(*define FO_DELETE #x0003)
(*define FOF_ALLOWUNDO #x0040)
(*define FOF_NOCONFIRMATION #x0010)
(define-dll-entry int SHFileOperation ((LPSHFILEOPSTRUCT *)) "shell32" "SHFileOperationA")
(defun filer-delete-api-1 (files)
(let ((fileop (make-LPSHFILEOPSTRUCT))
(filename (si:make-string-chunk (format nil "~{~A\0~}\0" files))))
(setf (LPSHFILEOPSTRUCT-hwnd fileop) 0)
(setf (LPSHFILEOPSTRUCT-wFunc fileop) FO_DELETE)
(setf (LPSHFILEOPSTRUCT-pFrom fileop) filename)
(setf (LPSHFILEOPSTRUCT-pTo fileop) 0)
(setf (LPSHFILEOPSTRUCT-fFlags fileop) (logior FOF_ALLOWUNDO FOF_NOCONFIRMATION))
(setf (LPSHFILEOPSTRUCT-fAnyOperationsAborted fileop) 0)
(setf (LPSHFILEOPSTRUCT-hNameMappings fileop) 0)
(setf (LPSHFILEOPSTRUCT-lpszProgressTitle fileop) 0)
(SHFileOperation fileop)))
(in-package "editor")
;; filer-delete を少し変更
(defun filer-delete-api ()
(long-operation
(let ((marks (filer-get-mark-files)))
(when (and marks
(if *filer-query-delete-precisely*
(filer-query-delete marks)
(yes-or-no-p "~A" (concat "選択されたファイルを削除しまっせ"
(and *filer-delete-mask*
(filer-delete-mask-string *filer-delete-mask*
"\n削除マスク: "))))))
(filer-subscribe-to-reload (filer-get-directory) t)
(let ((if-access-denied (if *filer-delete-read-only-files*
:force :error))
(delete-non-empty-directory
*filer-delete-non-empty-directory*))
(declare (special if-access-denied
delete-non-empty-directory))
;;; (filer-do-delete marks))
(win-user::filer-delete-api-1
(mapcar #'(lambda (path)
(string-right-trim "\\" (map-slash-to-backslash path)))
marks)))
(filer-subscribe-to-reload (filer-get-directory) t)
(message "done.")))))
(define-key filer-keymap #\D 'filer-delete-api)
(in-package "user")xyzzy ファイラで削除するかどうかの確認をするので
Windows のほうでは確認させないようにしたが、
そっちでも確認のダイアログを出したいなら
(setf (LPSHFILEOPSTRUCT-fFlags fileop) (logior FOF_ALLOWUNDO FOF_NOCONFIRMATION))
の部分の FOF_NOCONFIRMATION を削除すればＯＫ。
一応、単一または複数のファイル、ディレクトリで動作確認をした。
ファイル名に空白が入ってたり日本語が入ってたりしても
問題なく動いているみたい。
これで、大量のファイルを含むフォルダを削除しようとして
xyzzy が数分間使えなくなる、ということもなくなるはず。
それにしても、コンテキストメニューでできることをするだけなのに
こんなわけのわからないコードになるとは…。
これは xyzzy の問題じゃなくて Microsoft の API の問題なのかな。
www-mode で Google Scholar
Google の機能の一つに Google Scholar というものがあります。
一言で言うと「論文を検索」してくれるわけなんですが、
ほかにもその論文を引用できるように BibTeX とか Endnote 形式で
保存できたり、その手の人には何かと便利です。
で、それを xyzzy の www-mode から使おうとしたのですが、
Google Scholar での設定が反映されずハマりました。
いろいろ調べてみると、どうやら Google Scholar が送ってくる
クッキーが www-mode にリジェクトされている様子。
Emacs で w3m を使ってる人たちも同様の問題に遭遇していたようで、
それを参考に www-mode に変更を加えてみました。
具体的には以下を .www に書き加えました。
;;; Google Scholar が送ってくるクッキーに対応
(defun cookie-domain-match (domain host)
(or (string-equal domain host)
;; ↓Google Scholar などサブドメインでないのに頭にドットをつけてくるところへの対処
(string-equal domain (concat "." host))
(string-matchp (concat "^[-_0-9a-zA-Z]+" (regexp-quote domain) "$") host)))
;; 一部書き換え
(defun cookie-parse (cookie host file)
(let (name
value
expires
domain
path
parts)
(unless (stringp cookie)
(return-from cookie-parse))
(setq parts (split-string cookie ";" nil " \t\r\n"))
(setq value (pop parts))
(unless value
(msgbox "No value: ~S" value)
(return-from cookie-parse))
(when (< *www-cookie-max-len* (length value))
(msgbox "Cookie is too long.: < ~D ~D"
*www-cookie-max-len*
(length value))
(return-from cookie-parse))
(unless (string-match "\\([^ \t\r\n;,=]+\\)=\\([^ \t\r\n;,]+\\)" value)
(msgbox "Not cookie name & value: ~S" value)
(return-from cookie-parse))
(setq name (match-string 1))
(setq value (match-string 2))
(dolist (part parts)
(if (string-matchp "\\(expires\\|path\\|domain\\|secure\\)\\(=\\(.+\\)\\)?" part)
(let ((k (match-string 1))
v)
(when (match-beginning 2)
(setq v (string-trim " \t\r\n" (match-string 3))))
;(msgbox "~S~%~S" k v)
(cond ((equalp k "expires")
(when v
(setq expires (cookie-parse-date v)))
)
((equalp k "path")
(when v
(setq path v))
)
((equalp k "domain")
(when v
;;; (unless (string-match "\\.[-_0-9a-zA-Z]+\\.[-_0-9a-zA-Z]+$" v) ; -
(unless (string-match "\\.[-_0-9a-zA-Z]+\\.[-_0-9a-zA-Z]+$" v) ; +
(msgbox "Illegal domain in cookie. Ignored. ~S" v)
(return-from cookie-parse))
;;; (if (string-matchp (concat v "$") host) ; -
;;; (setq domain v) ; -
;;; (if *www-cookie-ignore-host-mismatch* ; -
;;; (return-from cookie-parse) ; -
;;; (if *www-cookie-alert-host-mismatch* ; -
;;; (if (cookie-alert-host-mismatch-ok cookie host) ; -
;;; (setq domain v) ; -
;;; (return-from cookie-parse)) ; -
;; RFC 2965 ; +
(unless (string-match "^." v) ; +
(setf v (concat "." v))) ; +
(cond ((cookie-domain-match v host) ; +
(setq domain v)) ; +
(*www-cookie-ignore-host-mismatch* ; +
(return-from cookie-parse)) ; +
((or (not *www-cookie-alert-host-mismatch*) ; +
(cookie-alert-host-mismatch-ok cookie host)) ; +
(setq domain v)) ; +
(t ; +
(return-from cookie-parse)))) ; +
)
((equalp k "secure")
;; https をサポートしていないのでsecure cookieは受付できない
(when *www-http-debug*
(msgbox "Ignore Secure Cookie"))
(return-from cookie-parse)
)))
(msgbox "Not cookie options: ~S" part)))
(unless domain
(setq domain host))
(unless path
(setq path file))
(list domain path name value expires)
))
;; 書き換え
(defun cookie-get (host file)
(let ((cookies
(remove-if (complement
#'(lambda (cookie)
(and (cookie-domain-match (cookie-domain cookie) host)
(string-match (concat "^" (cookie-path cookie)) file))))
*www-cookie-data*)))
(when cookies
(format nil "~{~A~^;~}"
(mapcar #'(lambda (c)
(format nil "~A=~A" (cookie-name c) (cookie-value c)))
cookies)))))
(mapc #'compile '(cookie-add cookie-domain-match cookie-parse cookie-get))ついでに cookie-add にバグらしきものを発見。
クッキーが一つだけしか保存されてなかったので修正してみました。
;; バグ？
(defun cookie-add (cookie)
(let (new
(done nil))
(dolist (d *www-cookie-data*)
(if (cookie-equal-p d cookie)
(progn
(push cookie new)
(setq done t))
;;; (push cookie d))) ; -
(push d new))) ; +
(unless done
(push cookie new))
(let ((cnt (length new)))
(when (< *www-cookie-max-cnt* cnt)
(setq new (butlast new (- cnt *www-cookie-max-cnt*)))))
(setq *www-cookie-data* (reverse new))
(cookie-save)))以上の変更を加えた結果、無事 Scholar 設定が保存されるようになりました。
ここから余談。
Google Scholar（http://scholar.google.com/） が送ってくるクッキーは
Domain=.scholar.google.com となっているわけですが、
RFC2965 を読んで自分が理解した限りだと
これはリジェクトされてしかるべきに思えます。
一方、Internet Explorer や Firefox でアクセスすると何も問題がおきず、
普通にクッキーは保存されます。
この辺どういう仕組みになっているのかはよくわかりませんでした。
delete-trailing-spaces
なんか動作が名前と反対な気がする。
この関数はカーソル位置より前にあるスペースを削除するみたいだけど、
カーソルより前にあるのは leading-spaces で、
trailing-spaces だとカーソル位置に続くスペースになるんじゃないかなあ。
