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

○ お休み

金曜日は年休をとって三連休にしてほのぼのしていました。日曜日の試合はグランドコンディション不良で中止だったが、その割には忙しかったな。

○ たんたんたんたんじょーび

6月 5日はダンの誕生日でございます。無事に一才。29Kg。

○ 火付け

○ もんじゃ焼き

日曜日に友だち家族ともんじゃ焼き屋にいった。満足、満足。

○ 迷惑メール振り分けサービス

○ dired with dispicon

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