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

○ 報告事項 :-)

dispicon.el ですが、ぼくの Meadow 3.00-dev だと

(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 にはあるのかな？
あと、全般的な話で Meadow には Mule for Win32 の昔から

(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 にはないのかな？
エクスプローラの縮小版表示もこれまたわからんない ^^;;;
というわけでいまのところわからないことだらけでございます。

○ Mew 向け dispicon & dropfile

ではでは、Mew 向け dispicon & dropfile。まだ改造が入るかも。shimbun で持ってきた text/html などでは ":" するとちょっとだけ楽しいかも。なのですが、昨日書いたように本質とは関係ないところで無駄な努力をしているので汚いですな。

(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"))))))))

○ dispicon & dropfile in dired

こちらに書かれている『dired でアイコン表示とドラッグアンドドロップを実現』もちょっと改造してみた。dropfile は使いたいけど、いつも icon 出ていると遅くてたまらない ;-p ので、"C-cC-d" で icon 表示がトグルします。ちなみに、file を消しても大丈夫です :-)

(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))))
     ))