猫熊は燃えつきた？！日記

○ 三連休

なのだがうちで結構働いている。が、進捗しない。

○ 土曜日

葛西のイトーヨーカ堂で買い物したりした。ヨドバシカメラからデジカメの退院の連絡があったけど、もうひとつ頼んでいるものがそろったら取りに行こう。

○ 野球

日曜日に初練習。軽くやって、あまりに寒いので "コーヒ飲もうね" って入ったサイゼリヤ篠崎店なのに、1500ml入りイタリアワインを白赤合わせて 5本飲んでしまったよ。昔はサイゼリヤって千葉と東京東部にしかなかったけど、今はすごいたくさんあるよな。

○ *Mew refile view* buffer

ダイレクトメールで "*Mew refile view* buffer" に色がつかないとの指摘あり。とりあえず積極的に色をつけるようにして、パッチをその方に送った。Mew-dist にパッチを送るかどうか考え中。

○ Yet another mew-summary-overricde-body

できたのだが、もう少し熟成期間が必要か。水戸さんの同等のもの[Mew-dist 3031] refileと効果は同じだけど。

;; fancy-refile-body
(defvar mew-override-fancy-setup nil)
;; (setq mew-summary-form-body-starter nil)
 
(defvar mew-override-fancy-body-open "<")
(defvar mew-override-fancy-body-prefix1 ?\ )
(defvar mew-override-fancy-body-prefix2 ?.)
(defvar mew-override-fancy-body-close ">")
(defvar mew-override-fancy-body-regex0 nil)
(defvar mew-override-fancy-body-regex1 nil)
(defvar mew-override-fancy-body-regex2 nil)
 
(setq mew-override-fancy-body-regex0
      (concat (regexp-quote mew-override-fancy-body-open)
	      "[^" (regexp-quote mew-override-fancy-body-open) "]+"
	      (regexp-quote mew-override-fancy-body-close)))
 
(setq mew-override-fancy-body-regex1
      (concat (regexp-quote (string mew-override-fancy-body-prefix2))
	      (regexp-quote (string mew-override-fancy-body-prefix1)) "+"
	      "\\(" mew-override-fancy-body-regex0 "\\)"))
 
(setq mew-override-fancy-body-regex2
      (concat "^[^\r]+"
	      "\\(" (regexp-quote (string mew-override-fancy-body-prefix2))
	      (regexp-quote (string mew-override-fancy-body-prefix1)) "+"
	      mew-override-fancy-body-regex0 "\\)\r"))
 
(defface mew-face-fancy-body nil
  "*Face to highlight the fancy body"
  :group 'mew-highlight)
 
(mew-face-spec-set
 'mew-face-fancy-body
 '((((class color) (type tty)) (:foreground "blue"))
   (((class color) (background light)) (:foreground "medium blue"))
   (((class color) (background dark))  (:foreground "dodger blue"))
   (t (:underline t))))
 
;; (mew-face-spec-set
;;  'mew-face-fancy-body
;;  '((((class color) (type tty)) (:foreground "green"))
;;    (((class color) (background light)) (:foreground "green yellow"))
;;    (((class color) (background dark))  (:foreground "LimeGreen"))
;;    (t (:underline t))))
 
(unless mew-override-fancy-setup
  (setq mew-override-fancy-setup t)
  (defalias 'mew-summary-refile-override-body 'mew-summary-refile-override-fancy-body)
  (defalias 'mew-summary-refile-remove-body 'mew-summary-refile-remove-fancy-body)
  (if mew-xemacs-p
      (progn
	(defalias 'mew-line-beginning-position 'point-at-bol)
	(defalias 'mew-line-end-position 'point-at-eol))
    (defalias 'mew-line-beginning-position 'line-beginning-position)
    (defalias 'mew-line-end-position 'line-end-position)))
 
(add-hook 'mew-thread-display-hook 'mew-thread-refile-override-fancy-body)
 
(defun mew-summary-refile-override-fancy-body (folders-str)
  (save-excursion
    (let* ((flds (concat (make-string 2 mew-override-fancy-body-prefix1)
			 mew-override-fancy-body-open
			 folders-str
			 mew-override-fancy-body-close))
	   (fldsw (string-width flds))
	   invs invsw beg end)
      (mew-summary-refile-remove-fancy-body)
      (while (> fldsw (/ (mew-scan-width) 3))
	(setq flds (concat (make-string 2 mew-override-fancy-body-prefix1)
			   mew-override-fancy-body-open
			   (setq folders-str
				 (substring folders-str
					    0 (* 2 (/ (string-width folders-str) 3))))
			   "..."
			   mew-override-fancy-body-close))
	(setq fldsw (string-width flds)))
      (beginning-of-line)
      (if (search-forward "\r" (mew-line-end-position) t)
	  (setq end (match-beginning 0))
	(setq end (mew-line-end-position)))
      (setq beg end)
      (goto-char beg)
      (while (> fldsw
		(setq invsw (string-width (setq invs (mew-buffer-substring beg end)))))
	(forward-char -1)
	(setq beg (point)))
      (when (< fldsw invsw)
	(setq flds (concat (make-string (- invsw fldsw) mew-override-fancy-body-prefix1)
			   flds)))
      (setq flds (concat (string mew-override-fancy-body-prefix2)
			 (substring flds 1)))
      (goto-char end)
      (mew-elet
       (if mew-xemacs-p
	   (let ((pos (point)))
	     (insert flds)
	     (set-text-properties pos (point) nil))
	 (insert-and-inherit flds))
       (put-text-property beg end 'invisible t)
       (goto-char end)
       (when (looking-at mew-override-fancy-body-regex1)
	 (setq ovl (mew-overlay-make (match-beginning 1) (match-end 1)))
	 (overlay-put ovl 'face 'mew-face-fancy-body)
	 (overlay-put ovl 'evaporate t))))))
 
(defun mew-summary-refile-remove-fancy-body ()
  (save-excursion
    (beginning-of-line)
    (when (looking-at mew-override-fancy-body-regex2)
      (let ((end (match-beginning 1))
	    beg)
	(mew-elet
	 (delete-region end (match-end 1))
	 (when (and (get-text-property end 'invisible)
		    (setq beg (previous-single-property-change
				end 'invisible nil (mew-line-beginning-position)))
		    (not (eq beg (mew-line-beginning-position))))
	   (remove-text-properties beg end '(invisible nil))))))))
 
(defun mew-thread-refile-override-fancy-body ()
  (let ((ofld (mew-thread-to-folder (mew-summary-folder-name 'ext)))
	refalst msg flds)
    (save-excursion
      (when (get-buffer ofld)
	(save-excursion
	  (set-buffer ofld)
	  (setq refalst (mew-sinfo-get-refile)))
	(while refalst
	  (setq msg (car (car refalst)))
	  (setq flds (mapconcat 'identity (cdr (car refalst)) ","))
	  (goto-char (point-min))
	  (when (re-search-forward (mew-regex-sumsyn-msg msg) nil t)
	    (mew-summary-refile-override-fancy-body flds))
 	  (setq refalst (cdr refalst)))))))

○ line-beginning-position(), line-end-position()

あぁ、これは XEmacs には無いんだと思い出す。 point-at-bol(), point-at-eol() って、もう何年も書いたこと無かった。

○ プリンプリン物語

あら、やっているのね。今子供が見ている。リアルタイムではさすがにもう見る年齢じゃなかったけど、ちょっと懐かしいな。

個人的には、五人と一匹探偵団、七瀬さんシリーズ、タイムトラベラー、オヨヨ大統領などの少年ドラマシリーズ(で良いんだよな？)が見たいし、子供に見せたい。

○ mew-nmz

うーむ、まだまだ続くな。。。

○ 息抜き

息抜きかどうかわからないけど、丸山さんのリクエストでこんなのを作ってみた。(ちょっと改善)

(0) mew-nmz とかで、検索したキーをメッセージ中でハイライト表示します。
(1) ある程度自動に引数を処理します。これ以上は勘弁。
(2) "kk" を押すと regexp を変更できます。
    やめたいときは "kk" で "" を入力。"prefix kk" でも OK。
(3) mew-summary-find-keyword-down|up() と同じ local 変数を使って
    いるので、M-n, M-p が変なときも同様に "kk" で修正します。
    ちなみに、最初にキーを聞いてくれなくなります。
(4) defadvice で呼んでいる mew-message-highlight-keyword-get()
    の引数はお使いのものに変えてください。

といった感じ。

(defface mew-message-highlight-keyword-face
  '((((class color) (background light))
     (:background "dark khaki" :bold t :underline t))
    (((class color) (background dark))
     (:background "blue" :bold t :underline t))
    (t (:bold t :underline t)))
  "*Face of mew-message-highlight-keyword."
  :group 'mew-highlight)
 
(add-hook 'mew-summary-mode-hook
	  (lambda ()
	    (define-key mew-summary-mode-map "kk" 'mew-message-highlight-keyword-set)))
 
(defun mew-message-highlight-keyword-set (&optional args)
  (interactive "P")
  (when (mew-summary-or-virtual-p)
    (if args
	(progn
	  (mew-sinfo-set-find-key nil)
          (message "Reset highlight keyword")
	  (and (mew-sinfo-get-disp-msg)
	       (mew-summary-display 'redisplay)))
      (let* ((hist (copy-sequence mew-input-pick-pattern-hist))
	     (key (read-string "Keyword: "
			       (or (mew-sinfo-get-find-key)
				   (car mew-input-pick-pattern-hist))
			       'hist)))
	(if (string= key "")
	    (mew-sinfo-set-find-key nil)
	  (mew-sinfo-set-find-key key))
	(and (mew-sinfo-get-disp-msg)
	     (mew-summary-display 'redisplay))))))
 
(defadvice mew-nmz-search-mark (after keyword-get activate)
  (mew-message-highlight-keyword-get 'namazu))
 
(defadvice mew-nmz-virtual (after keyword-get activate)
  (when (mew-virtual-p)
    (mew-message-highlight-keyword-get 'namazu)))
 
(defadvice mew-summary-pick-mark (after keyword-get activate)
  (mew-message-highlight-keyword-get 'mew))
 
(defadvice mew-summary-grep-mark (after keyword-get activate)
  (mew-message-highlight-keyword-get 'grep))
  ;; (mew-message-highlight-keyword-get 'mew))
 
(defadvice mew-summary-virtual-with-internal (after keyword-get activate)
  (when (mew-virtual-p)
    (mew-message-highlight-keyword-get 'mew)))
 
(defadvice mew-summary-virtual-with-external (after keyword-get activate)
  (when (mew-virtual-p)
    (mew-message-highlight-keyword-get 'grep)))
    ;; (mew-message-highlight-keyword-get 'mew)))
 
(defun mew-message-highlight-keyword-get (type)
  (let* ((key (car mew-input-pick-pattern-hist))
	 (keys (mew-split key ? ))
	 regex)
    (cond
     ((eq type 'namazu)
      (let ((frags '("(" ")" "and" "or" "not")))
	(while frags
	  (setq keys (delete (car frags) keys))
	  (setq frags (cdr frags)))
	(setq regex (regexp-opt (mapcar
				 (lambda (x)
				   (if (string-match "^\\+[^:]+:\\(.+\\)$" x)
				       (setq x (match-string 1 x)))
				   (if (string-match "^[\"{]?\\(.+\\)[\"}]?$" x)
				       (setq x (match-string 1 x)))
				   (let (tmp)
				     (while (string-match "\\*" x)
				       (setq tmp (concat tmp (substring x 0 (match-beginning 0))))
				       (setq x (substring x (match-end 0))))
				     (setq tmp (concat tmp x))
				     (setq x tmp))
				   (regexp-quote x))
				 keys)))))
     ((eq type 'mew)
      (let ((frags '("(" ")" "&" "|" "!")))
	(while frags
	  (setq keys (delete (car frags) keys))
	  (setq frags (cdr frags)))
	(setq regex (regexp-opt (mapcar
				 (lambda (x)
				   (cond
				    ((string-match "!?==?\\(.+\\)$" x)
				     (regexp-quote (match-string 1 x)))
				    ((string-match "^(?\\(.+\\))?$" x)
				     (regexp-quote (match-string 1 x)))
				    (t
				     (regexp-quote x))))
				 keys)))))
     (t	;; 'grep
      (setq regex key)))
    (if (or (not regex) (string= regex ""))
	(mew-sinfo-set-find-key nil)
      (mew-sinfo-set-find-key regex))))
 
(defun mew-message-highlight-keyword ()
  (let ((buf (mew-minfo-get-summary))
	key)
    (when (and buf (buffer-name (get-buffer buf)))
      (save-excursion
	(set-buffer buf)
	(setq key (mew-sinfo-get-find-key)))
      (when key
	(save-excursion
	  (goto-char (or (mew-header-end) (point-min)))
	  (while (re-search-forward key
				    (min (point-max) mew-highlight-body-max-size)
				    t)
	    (put-text-property (match-beginning 0) (match-end 0)
			       'face 'mew-message-highlight-keyword-face)))))))
 
(add-hook 'mew-message-hook 'mew-message-highlight-keyword)

○ 野球

日曜日、今年最初の野球の練習。練習終了後、仲間の自宅で飲んだのだが、近来稀に見るレベルの大酔っぱらいになってしまった。

○ ドッグラン+ドッグカフェ

月曜日に行ってきた。有料だけあって、おしゃれだ。会員になるかどうかは不明。

○ dird から gpg.el

今日の小ネタということで、dired から gpg.el を使って、暗号化/平文化するものを作ってみた。

 (defvar gpg-file-cache-time 1 "*Minute of alive time of passphase.")
 
 (add-hook 'dired-mode-hook
 	  (lambda ()
 	    (define-key dired-mode-map "\C-cg" 'dired-do-gpg)))
 
 (defun dired-do-gpg ()
   (interactive)
   (let (files)
     (dired-map-over-marks-check
      (lambda ()
        (setq files (cons (dired-get-filename) files))
        nil)
      nil 'GPG nil)
     (if (not files)
 	(message "No files")
       (while files
 	(gpg-file (car files))
 	(setq files (cdr files)))
       (revert-buffer))))
 
 (defvar gpg-file-buffer-kill-timer nil)
 
 (defun gpg-file (&optional file)
   (interactive)
   (require 'gpg)
   (when gpg-file-buffer-kill-timer
     (cancel-timer gpg-file-buffer-kill-timer)
     (setq gpg-file-buffer-kill-timer nil))
   (setq file (expand-file-name (or file (read-file-name "File: " ))))
   (let ((buf (get-buffer-create " *gpg-tmp*"))
 	dec gfile pro)
     (when (string-match gpg-regex-suffix file)
       (setq file (substring file 0 (match-beginning 0)))
       (setq dec t))
     (setq gfile (concat file ".gpg"))
     (cond
      ((and (not dec)
 	   (not (and (file-exists-p file)
 		     (file-readable-p file)
 		     (file-writable-p gfile))))
       (message "%s can not gpg" file))
      ((and dec
 	   (not (and (file-exists-p gfile)
 		     (file-readable-p gfile)
 		     (file-writable-p file))))
       (message "%s can not gpg" file))
      ((or (file-directory-p file) (file-directory-p gfile))
       (message "%s is directory" file))
      (t
       (when (interactive-p)
 	(message "%s %s..." (if dec "decryption" "encryption") file))
       (if dec
 	  (if (file-exists-p file) (delete-file file))
 	(if (file-exists-p gfile) (delete-file gfile)))
       (save-excursion
 	(set-buffer buf)
 	(setq pro
 	      (if dec
 		  (setq pro (gpg-start-process gpg-process-decryption buf gpg-program
 					       "-d" "--yes" "--output" file gfile))
 		(gpg-start-process gpg-process-encryption buf gpg-program
 				   "-c" "--cipher-algo" gpg-cipher
 				   "--yes" "--output" gfile file)))
 	(set-process-filter   pro 'gpg-filter)
 	(set-process-sentinel pro 'gpg-sentinel)
 	(setq gpg-rendezvous t)
 	(while gpg-rendezvous
 	  (sit-for 0.1)
 	  (discard-input))
 	(when (and (file-exists-p file) (file-exists-p gfile))
 	  (if dec
 	      (delete-file gfile)
 	    (delete-file file)))
 	(setq gpg-file-buffer-kill-timer
 	      (run-at-time (* gpg-file-cache-time 60) nil 'gpg-file-buffer-kill))
 	(when (interactive-p)
 	  (message "%s %s...done" (if dec "decryption" "encryption") file)))))))
       
 (defun gpg-file-buffer-kill ()
   (when gpg-file-buffer-kill-timer
     (cancel-timer gpg-file-buffer-kill-timer)
     (setq gpg-file-buffer-kill-timer nil))
   (let ((buf " *gpg-tmp*"))
     (if (and buf (get-buffer buf)) (kill-buffer buf))))

○ 使い方

M-x gpg-file しても良いし、dired で "C-cg" しても良い。指定したファイル名に ".gpg" という suffix がついていたら平文化するし、なければ暗号化する。

デフォルトだと一分間 passphrase を覚えているが、覚えている間は全部同じ passphrase を使って暗号化/平文化を行なうのがちょっと弱い。

○ egg-pobox Zaurus 向けパッケージ

丸山さんちで、egg-pobox 関連が全部揃うようになっている。素早い。
これから egg-pobox.el を変えるときは、ちゃんと考えてからやらないと ^^;;;

○ 退院

というわけで、昨日の夜、ダンが退院してきた。
「傷口を舐めなければ必要ない」と言われたのだけど、とりあえず数日はカラー付けておこう、ということで、動物病院から借りてきた。ちょっと大き目(というかぴったり着けちゃうとそれなりに苦しいの)で、タオルのアシスト付き。

お腹の具合はどんな感じ？というと、思いっきり剃毛してこんな感じ。傷口は 20cm10cm ちょっとかな。ほとんどタヌキ。

けど、本人(本犬？)はいたって元気なので、夕方のお散歩であったクッキーちゃんとニコニコ。

○ どうも

画像が思ったところに配置できない ^^;;;

○ ちなみに

ダンのお腹の中からは「今回の発端となったおもちゃ」「洗濯バサミの破片(金属付き)」「たくさんの木屑」が出てきましたよ。もともと拾い食いの癖があるんだけど、厳しく躾けなければ。。。