(defun dispicon-default-background () "Obtain background color of default face." (let ((rgb (color-values (or (frame-parameter (selected-frame) 'background-color) "White"))))じゃないとダメでした。background-color が nil を返すことあるかな?わかんないけど、無理矢理設定したらエラーになったのでガード付き。frame-background-color って変数聞いたことないのだけど、NTEmacs にはあるのかな?それとも Meadow2 にはあるのかな?
(unix-to-dos-filename "c:/hoge/fuga/foo.doc") => "c:\\hoge\\fuga\\foo.doc" (unix-to-dos-filename "c:\\hoge\\fuga\\foo.doc") => "c:\\hoge\\fuga\\foo.doc"という組み込み関数があるのだけれど、これは NTEmacs にはないのかな?
(add-hook 'mew-syntax-format-hook 'mew-summary-mw32-dropfile)
(add-hook 'mew-message-hook 'mew-message-mw32-dropfile)
(defvar mew-mw32-dropfile-use-icon t
"*Icon 表示の動作設定。icon がなくても dropfile はできる。
t で summary も message も icon 表示。
nil で icon を表示しない。
'summary-only で summary のみ icon 表示。")
(defvar mew-mw32-dropfile-dummies
`(("image/jpeg" . "drop.jpg")
("image/png" . "drop.png")
("image/gif" . "drop.gif")
("image/tiff" . "drop.tif")
("text/html" . "drop.htm")
("text/plain" . "drop.txt"))
"*Dropfile を使うときにファイル名が無いときのテンポラリファイル名。
HTML 中の CID 画像表示などに便利かも。")
(defvar mew-mw32-dropfile-force-denotation t
"*ファイル名がなくても drop できるようにする。
Decode policy が STRICT などのときに良いかも。")
(defun mew-mw32-dropfile (file buf beg end &optional cs)
(with-temp-buffer
(mew-frwlet
mew-cs-dummy (or cs mew-cs-binary)
(insert-buffer-substring-no-properties buf beg end)
(write-region (point-min) (point-max) file nil 'nomsg)))
(dropfile file))
(defun mew-summary-mw32-dropfile ()
"summary の syntax 表示で icon & dropfile."
(when (and (string-match mew-buffer-cache-prefix (buffer-name))
(not (string= ct "RFC822")) ;; 気にするな
(or (not mew-mw32-dropfile-use-icon)
(fboundp 'dispicon))
(fboundp 'dropfile)
window-system)
;; filename は hook 内で bind されている。
(let* ((ctl (mew-syntax-get-ct syntax))
(params (mew-syntax-get-params ctl))
(ct (downcase (if (stringp ctl) ctl (car ctl))))
(buf (current-buffer))
(beg (mew-syntax-get-begin syntax))
(end (mew-syntax-get-end syntax))
(cs (mew-charset-to-cs (mew-syntax-get-param params "charset")))
(map (make-sparse-keymap))
fullname orgfile bmpfile)
(unless filename
(setq filename (or (cdr (assoc ct mew-mw32-dropfile-dummies))
(and mew-mw32-dropfile-force-denotation "drop.dmy"))))
(setq orgfile filename)
(when (and (not cs) (string-match "^text" ct))
(setq cs 'shift_jis-dos))
(when filename
(setq fullname (expand-file-name filename mew-temp-dir))
;; 本当は overlay にしたいが無理。
(when mew-mw32-dropfile-use-icon
(if (string-match "\\.bmp$" (downcase filename))
;; BMP は無理矢理 ICON に中身を表示してみる。
(with-temp-buffer
(mew-flet
(insert-buffer-substring-no-properties buf beg end)
(write-region (point-min) (point-max) fullname nil 'nomsg))
(setq bmpfile (unix-to-dos-filename fullname))
(setq filename
(concat
(dispicon bmpfile 'small
(aref (font-info (face-font 'default (selected-frame))) 3))
" " filename)))
(setq filename
(concat
(dispicon filename 'small
(aref (font-info (face-font 'default (selected-frame))) 3))
" " filename))))
(define-key map [down-mouse-1] `(lambda ()
(interactive)
(mew-mw32-dropfile ,fullname ,buf ,beg ,end
(quote ,cs))))
(add-text-properties 0 (length filename)
`(keymap ,map mouse-face highlight
dropfile ,orgfile
bmpfile ,bmpfile
help-echo "mouse-1: Drop to the other application")
filename)))))
(defadvice mew-summary-execute-external (after mw32-dropfile activate)
"Advice for dropfile."
(let ((win (selected-window))
(mbuf (mew-buffer-message)))
(if (get-buffer-window mbuf)
(set-buffer mbuf)
(mew-window-configure 'message))
(mew-message-mw32-dropfile)
(select-window win)))
(defun mew-message-mw32-dropfile ()
"messge buffer の先頭で icon & dropfile."
(when (and (or (not mew-mw32-dropfile-use-icon)
(fboundp 'dispicon))
(fboundp 'dropfile)
window-system)
(let ((vfld (mew-minfo-get-summary))
filename orgfile map dropfile beg)
(unless (get-text-property (point-min) 'dropfile)
(when (get-buffer vfld)
(save-excursion
(set-buffer vfld)
(end-of-line)
(skip-chars-backward " \r.")
(backward-char 1)
(setq filename (get-text-property (point) 'dropfile))
(setq dropfile (or (get-text-property (point) 'bmpfile) filename))
(setq map (get-text-property (point) 'keymap)))
(when (and filename map)
(setq orgfile filename)
(goto-char (point-min))
(mew-elet
(when (and mew-mw32-dropfile-use-icon
(not (eq mew-mw32-dropfile-use-icon 'summary-only)))
(insert (dispicon dropfile 'large))
(insert " ")
(add-text-properties (point-min) (point)
`(keymap ,map mouse-face highlight
dropfile ,orgfile
help-echo "mouse-1: Drop to the other application")))
(setq beg (point))
(insert filename)
(add-text-properties beg (point)
`(keymap ,map mouse-face highlight
face mew-face-header-from
dropfile ,orgfile
help-echo "mouse-1: Drop to the other application"))
(insert "\n\n"))))))))
(defvar dired-dispicon nil "*Dired の ICON 表示の初期値。")
(make-variable-buffer-local 'dired-dispicon)
(add-hook 'dired-mode-hook
(lambda ()
(define-key dired-mode-map "\C-c\C-d" 'dired-dispicon)))
(defun dired-dispicon (&optional args)
(interactive "P")
(when (eq major-mode 'dired-mode)
(setq dired-dispicon (not dired-dispicon))
(message "Dired dispicon: %s" (if dired-dispicon "ON" "off"))
(revert-buffer)))
(eval-after-load "dired"
'(progn
(defadvice dired-revert (before dired-revert-remove-overlays activate)
"Remove overlays."
(save-excursion
(let ((pos (point-min)))
(while (not (eq (setq pos (next-overlay-change pos)) (point-max)))
(dolist (overlay (overlays-at pos))
(delete-overlay overlay))))))
(defun dired-insert-set-properties (beg end)
(save-excursion
(goto-char beg)
(while (< (point) end)
(condition-case nil
(when (dired-move-to-filename)
(let ((beg (point))
end file map)
(add-text-properties
beg
(setq end (save-excursion
(dired-move-to-end-of-filename)
(point)))
'(mouse-face highlight
help-echo
"mouse-1: visit this file in other window"))
(setq file (buffer-substring beg end)
file (unix-to-dos-filename
(expand-file-name file dired-directory))
map (make-sparse-keymap))
(define-key map [down-mouse-1] `(lambda ()
(interactive)
(dropfile ,file)))
(let ((ovl (make-overlay beg end)))
(if dired-dispicon
(overlay-put ovl 'before-string
(propertize
(dispicon file 'small
(aref (font-info
(face-font 'default (selected-frame)))
3))
'keymap map)))
(overlay-put ovl 'keymap map)
(overlay-put ovl 'evaporate t))))
(error nil))
(forward-line 1))))
))
金曜日は年休をとって三連休にしてほのぼのしていました。日曜日の試合はグランドコンディション不良で中止だったが、その割には忙しかったな。
6月 5日はダンの誕生日でございます。無事に一才。29Kg。
日曜日に友だち家族ともんじゃ焼き屋にいった。満足、満足。
(defvar dired-dispicon nil "*Dired の ICON 表示の初期値。")
(make-variable-buffer-local 'dired-dispicon)
(add-hook 'dired-mode-hook
(lambda ()
(define-key dired-mode-map "\C-c\C-d" 'dired-dispicon)
(dropfile-dired-setup)))
;; dired-mode-hook だと、まだ設定されていないので、dired で各自一度
;; font-lock-fontify-buffer-function
;; font-lock-fontify-region-function
;; を評価して、その値を設定する。
(defvar dropfile-dired-fontify-buffer-function-orig 'jit-lock-refontify)
(defvar dropfile-dired-fontify-region-function-orig 'font-lock-default-fontify-region)
(defun dired-dispicon (&optional args)
(interactive "P")
(when (eq major-mode 'dired-mode)
(setq dired-dispicon (not dired-dispicon))
(message "Dired dispicon: %s" (if dired-dispicon "ON" "off"))
(revert-buffer)))
(defun dropfile-dired-font-lock (&optional beg end)
(let ((buffer-read-only nil)
(inhibit-read-only t)
(after-change-functions nil)
(inhibit-point-motion-hooks t))
(save-excursion
(setq beg (or beg (point-min)))
(setq end (or end (point-max)))
(goto-char beg)
(while (< (point) end)
(condition-case nil
(when (dired-move-to-filename)
(unless (get-text-property (point) 'dropfile)
(let ((beg (point))
end file map)
(add-text-properties
beg
(setq end (save-excursion
(dired-move-to-end-of-filename)
(point)))
'(mouse-face highlight
help-echo
"mouse-1: visit this file in other window"
dropfile t))
(setq file (buffer-substring beg end)
file (unix-to-dos-filename
(expand-file-name file dired-directory))
map (make-sparse-keymap))
(define-key map [down-mouse-1] `(lambda ()
(interactive)
(dropfile ,file)))
(let ((ovl (make-overlay beg end)))
(if dired-dispicon
(overlay-put ovl 'before-string
(propertize
(dropfile-dired-dispicon
file 'small
(aref (font-info
(face-font 'default (selected-frame)))
3))
'keymap map)))
(overlay-put ovl 'keymap map)
(overlay-put ovl 'evaporate t)))))
(error nil))
(forward-line 1))
(set-buffer-modified-p nil))))
;; 一度表示した icon を保持する。
(defvar dropfile-dired-icon-alist nil)
(defvar dropfile-dired-icon-alist-length 1024)
(defun dropfile-dired-dispicon (filename &optional type size depth bgcolor ignore-errors)
(require 'dispicon)
(let* ((name (downcase filename))
(nondir (file-name-nondirectory name))
ext iconkey icon)
(setq type (or type dispicon-default-type))
(setq size (or size dispicon-default-size))
(cond
((or (file-directory-p filename)
(string= nondir ""))
(setq ext "DIR"))
((or (not (string-match "\\." nondir))
(string-match "\\.$" nondir))
(setq ext "TXT"))
((string-match "\\.\\([^.]+\\)$" nondir)
(setq ext (match-string 1 nondir))
(when (member ext '("bmp" "exe" "ico"))
(setq ext name)))
(t
(setq ext "TXT")))
(setq iconkey (format "%s:%s:%d" ext type size))
(setq icon (cdr (assoc iconkey dropfile-dired-icon-alist)))
(if icon
(setq dropfile-dired-icon-alist
(delete (cons iconkey icon) dropfile-dired-icon-alist))
(setq icon (dispicon (unix-to-dos-filename filename)
type size depth bgcolor ignore-errors)))
(setq dropfile-dired-icon-alist
(cons (cons iconkey icon) dropfile-dired-icon-alist))
(when (> (length dropfile-dired-icon-alist) dropfile-dired-icon-alist-length)
(setcdr (nthcdr (1- dropfile-dired-icon-alist-length)
dropfile-dired-icon-alist) nil))
icon))
(defun dropfile-dired-setup ()
(set (make-local-variable 'jit-lock-chunk-size) 200) ;; 趣味にあわせる
(set (make-local-variable 'font-lock-fontify-buffer-function)
'dropfile-dired-fontify-buffer-function)
(set (make-local-variable 'font-lock-fontify-region-function)
'dropfile-dired-fontify-region-function))
(defun dropfile-dired-fontify-buffer-function (&optional beg end)
(let ((ddir (expand-file-name dired-directory)))
(when (or (string-match "^[a-zA-Z]:" ddir)
(string-match "^//[^/]" ddir))
(dropfile-dired-font-lock beg end))
(funcall dropfile-dired-fontify-buffer-function-orig beg end)))
(defun dropfile-dired-fontify-region-function (beg end loudly)
(let ((ddir (expand-file-name dired-directory)))
(when (or (string-match "^[a-zA-Z]:" ddir)
(string-match "^//[^/]" ddir))
(dropfile-dired-font-lock beg end))
(funcall dropfile-dired-fontify-region-function-orig beg end loudly)))
女房が仕事先の送別会(の幹事)なので、子供の相手をするために早く帰ってきた。夕飯はなにか作ってあるだろうと思ったら、なんにもなかったので、うちの近所の中華料理屋サンに親子三人で。
この店、以前はめちゃくちゃまずかったので絶対に行かなかったのだけど、修行を終えて帰ってきた若い人(息子?)に料理人が変わってから『おいしくなったよ』と(友達の料理人に)聞き、たまに行くようになった。確かに(うちの近所の割には)おいしい。
そのうちアーカイブにのると思う([Meadow-develop: 6582] [Meadow-develop: 6584])が、堀口さんの fakecygpty を使って cygwin な gpg をラップしたところ、Meadow からも gpg.el が動いた。
gpg.el は対称暗号を使うのだけど、Windows native な gpg + gpg-agent だと、gpg-agent.exe が落ちちゃって動かなかったのでありました。
ただし、なぜか Mew から使う gpg を fake すると、まったく動かなくなってしまうので注意。Windows native と cygwin と二つの gpg を使わないとだめなのが、ちょっとめんどくさいかも。
恥ずかしながら jit-lock-register って知りませんでした ^^;;; 自前の関数をどんどん追加できるとは。。。
fast-lock と lazy-lock は obsolete になったのね。ちなみに、Emacs21 以降を使っていて、jit-lock 以外の font-lock を使う理由はまったくない(と思う)ので十二分でしょう。
江東区の大会に出張って行ったのだけど負けちまったい。最終回に逆転されて 5-4。結構悔しい。
うーむ、昨日の夜もあった。前日とっ捕まった奴は現行犯逮捕だったのだが、連続放火の犯人かどうかはわかっていない。もう一人?
子供会の役員会があって 22:45 ぐらいに終わったのだが、町会の会館を出たときに、隣の消防車の車庫で消防団の人達が見回りに出動する準備をしていた。ご苦労さまです。
trunk から svn up してインスール。
gpg も mew-win32-gpg をあっさり捨てて cygwin で make した gnupg-1.4.1 に乗り換えた。しかし、有史以来の Mew passphase 入力問題が片付くとは。。。
の smtp を使うと。。。
なのですな。非常時以外は使うのを止めよう
AU のパケット代(ぼくと女房それぞれ 1,000円)が、それぞれ 950円も余りまくっている。どうしよう。。。
会社の伝票処理で最後の最後までいってから、見積り、請求書の組織名が間違っているのを発見され、やり直しになってしまった。調べたら、ぼくが初めから相手の人に大嘘教えているし。。。はぁ。。。
というか、そんな間違えるほどしょっちゅう名称を変えるのがいけない。
年に一度のスパリゾート・ハワイアンズ。温泉でのんびり。うちの子供の面倒はまったく見なくて大丈夫なので、他の家の小さい子の面倒をみていたり。真面目に役員の仕事もしたかな。今回のガイドさんはかわいかった。花丸。
案の定帰りは渋滞していたので、おおむらさんの真似をして渋滞情報でも書こうと思ったのだが、すっかり酔っぱらっていたので、パス ^^;;;
そういえば、つくばエクスプレスの試運転?をしていたなぁ。
ハワイアンズから帰ってきて、すぐに会館にいって獅子揉みの準備など。あまりに腹が減ったので、仲間で帰りにラーメン屋さんへ。さて、私は今日一日で何本ビールを飲んだでしょうか :-)
そういえば、土曜日に息子の自転車のパンク修理を息子と一緒にやった。
「さて、今取り出したタイヤチューブのどこかに穴が開いていますが、どうやって調べたら良いでしょう?」などと、なかなか楽しかった。
パッチとゴムのりが無かったので買った来たのだが、『この缶入りのゴムのり一生無くならないなぁ』と考えていたのだが、息子が引っくり返して、残り 1/3 ほどになってしまいました。
とりあえず、寺西さんに(無理やり)送り付けた。
(add-hook 'Info-mode-hook
(lambda ()
(when (and (boundp 'Info-isearch-search)
(featurep 'migemo))
(set (make-local-variable 'isearch-search-fun-function)
'Info-migemo-isearch-search))))
(defun Info-migemo-isearch-search ()
(if Info-isearch-search
(lambda (string &optional bound noerror count)
(cond
(migemo-do-isearch
(Info-migemo-search string bound noerror count
(unless isearch-forward 'backward))
(point))
(isearch-word
(Info-search (concat "\\b" (replace-regexp-in-string
"\\W+" "\\\\W+"
(replace-regexp-in-string
"^\\W+\\|\\W+$" "" string)) "\\b")
bound noerror count
(unless isearch-forward 'backward)))
(t
(Info-search (if isearch-regexp string (regexp-quote string))
bound noerror count
(unless isearch-forward 'backward))
(point))))
(let ((isearch-search-fun-function nil))
(isearch-search-fun))))
(defun Info-migemo-search (regexp &optional bound noerror count direction)
(when transient-mark-mode
(deactivate-mark))
(let ((backward (eq direction 'backward))
found beg-found give-up
(onode Info-current-node)
(ofile Info-current-file)
(opoint (point))
(opoint-min (point-min))
(opoint-max (point-max))
(ostart (window-start))
(osubfile Info-current-subfile)
(migemo-do-isearch nil))
(setq Info-search-case-fold t)
(save-excursion
(save-restriction
(widen)
(when backward
;; Hide Info file header for backward search
(narrow-to-region (save-excursion
(goto-char (point-min))
(search-forward "\n\^_")
(1- (point)))
(point-max)))
(while (and (not give-up)
(save-match-data
(or (null found)
(if backward
(isearch-range-invisible found beg-found)
(isearch-range-invisible beg-found found))
;; Skip node header line
(and (save-excursion (forward-line -1)
(looking-at "\^_"))
(forward-line (if backward -1 1)))
;; Skip Tag Table node
(save-excursion
(and (search-backward "\^_" nil t)
(looking-at "\^_\nTag Table"))))))
(let (search-spaces-regexp)
(if (if backward
(migemo-backward regexp bound t)
(migemo-forward regexp bound t))
(setq found (point) beg-found (if backward (match-end 0)
(match-beginning 0)))
(setq give-up t))))))
(when (and isearch-mode Info-isearch-search
(not Info-isearch-initial-node)
(not bound)
(or give-up (and found (not (and (> found opoint-min)
(< found opoint-max))))))
(signal 'search-failed (list regexp "initial node")))
;; If no subfiles, give error now.
(if give-up
(if (null Info-current-subfile)
(let (search-spaces-regexp)
(if backward
(migemo-backward regexp)
(migemo-forward regexp)))
(setq found nil)))
(if (and bound (not found))
(signal 'search-failed (list regexp)))
(unless (or found bound)
(unwind-protect
;; Try other subfiles.
(let ((list ()))
(save-excursion
(set-buffer (marker-buffer Info-tag-table-marker))
(goto-char (point-min))
(search-forward "\n\^_\nIndirect:")
(save-restriction
(narrow-to-region (point)
(progn (search-forward "\n\^_")
(1- (point))))
(goto-char (point-min))
;; Find the subfile we just searched.
(search-forward (concat "\n" osubfile ": "))
;; Skip that one.
(forward-line (if backward 0 1))
(if backward (forward-char -1))
;; Make a list of all following subfiles.
;; Each elt has the form (VIRT-POSITION . SUBFILENAME).
(while (not (if backward (bobp) (eobp)))
(if backward
(re-search-backward "\\(^.*\\): [0-9]+$")
(re-search-forward "\\(^.*\\): [0-9]+$"))
(goto-char (+ (match-end 1) 2))
(setq list (cons (cons (+ (point-min)
(read (current-buffer)))
(match-string-no-properties 1))
list))
(goto-char (if backward
(1- (match-beginning 0))
(1+ (match-end 0)))))
;; Put in forward order
(setq list (nreverse list))))
(while list
(message "Searching subfile %s..." (cdr (car list)))
(Info-read-subfile (car (car list)))
(when backward
;; Hide Info file header for backward search
(narrow-to-region (save-excursion
(goto-char (point-min))
(search-forward "\n\^_")
(1- (point)))
(point-max))
(goto-char (point-max)))
(setq list (cdr list))
(setq give-up nil found nil)
(while (and (not give-up)
(save-match-data
(or (null found)
(if backward
(isearch-range-invisible found beg-found)
(isearch-range-invisible beg-found found))
;; Skip node header line
(and (save-excursion (forward-line -1)
(looking-at "\^_"))
(forward-line (if backward -1 1)))
;; Skip Tag Table node
(save-excursion
(and (search-backward "\^_" nil t)
(looking-at "\^_\nTag Table"))))))
(let ((search-spaces-regexp Info-search-whitespace-regexp))
(if (if backward
(migemo-backward regexp nil t)
(migemo-forward regexp nil t))
(setq found (point) beg-found (if backward (match-end 0)
(match-beginning 0)))
(setq give-up t))))
(if give-up
(setq found nil))
(if found
(setq list nil)))
(if found
(message "")
(signal 'search-failed (list regexp))))
(if (not found)
(progn (Info-read-subfile osubfile)
(goto-char opoint)
(Info-select-node)
(set-window-start (selected-window) ostart)))))
(if (and (string= osubfile Info-current-subfile)
(> found opoint-min)
(< found opoint-max))
;; Search landed in the same node
(goto-char found)
(widen)
(goto-char found)
(save-match-data (Info-select-node)))
;; Use string-equal, not equal, to ignore text props.
(or (and (string-equal onode Info-current-node)
(equal ofile Info-current-file))
(and isearch-mode isearch-wrapped
(eq opoint (if isearch-forward opoint-min opoint-max)))
(setq Info-history (cons (list ofile onode opoint)
Info-history)))))
△ おおむらゆう [酔っぱらって温泉に入るといけないんですよ (^^;;]