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

○ いつまでも Mew を使おう！！

最近、世知辛い世の中になってきて、会社で MUA は Becky! をこういう設定で使うように、というお触れが出ている。ちなみに「こういう設定」というのは

• 送信前の送付先アドレス確認チェック
• 送信時の添付ファイルチェック
• グループアドレス使用禁止

だ。Becky! のグループアドレスというのは、hoge で送信したら、hoge に登録してある fooさんも barさんもみんな同時に送信するというものらしいが、それと同等のものは現在の Mew はそもそも対応していないと思うので前者二つに対応してみた

○ mew-draft-check-whom

もともとは、送付先アドレスチェックのために作って、後から添付ファイルの機能も入れたのでこんな名前。

(defvar mew-draft-check-whom-always-ask nil
  "宛先に関係なくいつでも質問するときは non-nil")
 
(defvar mew-draft-check-whom-attaches t
  "添付ファイルのチェックをしない時は nil")
 
(defvar mew-buffer-whom "*Mew whom*")
 
(add-hook 'mew-make-message-hook 'mew-draft-check-whom)
 
(defadvice mew-header-make-message (around ask-address activate)
  (mew-draft-check-whom)
  ad-do-it)
 
(defadvice mew-header-send-message (around ask-address activate)
  (mew-draft-check-whom)
  ad-do-it)
 
(defun mew-draft-check-whom-ask (addr case)
  (or mew-draft-check-whom-always-ask
      (progn
	(setq addr (downcase (or (mew-addrstr-parse-address addr) addr)))
	(let ((domain (and (string-match "@\\(.+\\)$" addr)
			   (downcase (mew-match-string 1 addr)))))
	  (not (or (not domain)
		   (member addr (mew-safe-addresses case))
		   (member domain (member domain (mew-safe-domains case)))))))))
 
(defun mew-draft-check-whom ()
  "Display expanded short names and attaches in other window."
  (interactive)
  (let ((buf (current-buffer))
	(case (mew-tinfo-get-case))
        (destination-list
         (mew-uniq-list (append '("From:") mew-destination:-list
                                '("Reply-to:" "Newsgroups:" "Fcc:"
                                  "Resent-To:" "Resent-Cc:"
				  "Resent-Dcc:" "Resent-Bcc:"))))
	(wincfg (current-window-configuration))
	(ask nil)
        to-cc field head pos attaches)
    (mapc (lambda (list)
	    (setq to-cc (cons (cons list (mew-header-get-value list)) to-cc)))
	  destination-list)
    (setq to-cc (nreverse to-cc))
    (when (and mew-draft-check-whom-attaches
	       (setq pos (next-single-property-change (point-min) 'mew-attach-begin)))
      (goto-char pos)
      (forward-line 1)
      (setq pos (point))
      (mew-attach-next)
      (while (not (= (point) pos))
	(setq pos (point))
	(when (mew-attach-not-line012-1-dot)
	  (let* ((nums (mew-syntax-nums))
		 (syntax (mew-syntax-get-entry mew-encode-syntax nums))
		 (name (mew-syntax-get-file syntax))
		 (cdpl (mew-syntax-get-cdp syntax))
		 (ctl (mew-syntax-get-ct syntax))
		 (cdpname (mew-syntax-get-filename cdpl ctl)))
	    (unless (string-match "/$" name)
	      (if (or (not cdpname) (string= name cdpname))
		  (setq attaches (cons (cons nums name) attaches))
		(setq attaches (cons (cons nums (format "%s (%s)" cdpname name)) attaches))))))
	(mew-attach-next))
      (setq attaches (nreverse attaches)))
    (message "Checking recipients ... ")
    (get-buffer-create mew-buffer-whom)
    (switch-to-buffer-other-window mew-buffer-whom)
    (mew-erase-buffer)
    (while to-cc
      (setq field (car (car to-cc)))
      (setq head (cdr (car to-cc)))
      (setq to-cc (cdr to-cc))
      (when head
        (setq head (mew-replace-white-space head))
        (setq head (mew-split head ?,))
        (insert (format "%s %s\n" field (car head)))
	(setq ask (or ask (mew-draft-check-whom-ask (car head) case)))
        (setq head (cdr head))
        (while (setq field (car head))
	  (setq ask (or ask (mew-draft-check-whom-ask (car head) case)))
          (when (string-match "^ +" field)
            (setq field (substring field (match-end 0))))
          (insert (format "\t%s\n" field))
          (setq head (cdr head)))))
    (goto-char (point-min))
    (while (re-search-forward ",\\([ \t]*[^\n]\\)" nil t)
      (goto-char (match-beginning 1))
      (insert "\n")
      (when (looking-at "^[ \t]+")
        (delete-region (match-beginning 0) (match-end 0)))
      (insert "\t"))
    (goto-char (point-min))
    (insert (propertize "ヘッダーチェック" 'face 'mew-face-header-warning))
    (insert "\n")
    (mew-highlight-header-region (point) (point-max))
    (when attaches
      (goto-char (point-max))
      (insert "\n")
      (insert (propertize "添付ファイル" 'face 'mew-face-header-warning))
      (insert "\n")
      (dolist (alist attaches)
	(let ((nums (car alist))
	      (file (cdr alist)))
	  (insert (format "%s\t%s\n"
			  (propertize (concat (mapconcat 'number-to-string nums ".") ".")
				      'face 'mew-face-header-marginal)
			  (propertize file 'face 'mew-face-header-from))))))
    (goto-char (point-min))
    (pop-to-buffer buf)
    (mew-buffers-setup (buffer-name))
    ;;
    (when (or ask attaches)
      (pop-to-buffer mew-buffer-whom)
      (unless (pos-visible-in-window-p (point-max) (selected-window))
	(delete-other-windows))
      (unwind-protect
	  (unless (y-or-n-p "Sure? ")
	    (cond
	     ((and ask attaches)
	      (error "Edit address or attaches"))
	     (ask
	      (error "Edit address"))
	     (attaches
	      (error "Edit attaches"))
	     (t
	      (error "Edit something"))))
	(set-window-configuration wincfg)))))
 
;; 必要ないかも
(add-hook 'mew-send-hook
	  (lambda ()
	    (when (get-buffer mew-buffer-whom)
	      (kill-buffer mew-buffer-whom))))

○ arc-mode でパスワード付き ZIP を扱う

mew-dist で話が出ていたので作ってみた。が、mew-dist に出せるほどの自信はない。ぼく自身も arc-mode は view ぐらいしか使わないし、以下すべての arc-mode に関して日本語ファイルの対応は適当。view できるファイルは出来るし、view 出来ないファイルは出来ない(が差がわかんないの)。

(defvar archive-extract-passwd nil)
(make-variable-buffer-local 'archive-extract-passwd)
 
(defadvice archive-zip-extract (around zip-passwd activate compile)
  (if (equal (car archive-zip-extract) "unzip")
      (let ((args (append (cdr archive-zip-extract) (list archive name)))
	    (passwd (with-current-buffer (get-buffer archive-superior-buffer)
		      archive-extract-passwd))
	    enc)
	(if passwd
	    (setq enc t)
	  (with-temp-buffer
	    (let ((case-fold-search nil)
		  (coding-system-for-write
		   (or (and (boundp 'archive-file-name-coding-system)
			    archive-file-name-coding-system)
		       file-name-coding-system))
		  (coding-system-for-read
		   (or (and (boundp 'archive-file-name-coding-system)
			    archive-file-name-coding-system)
		       file-name-coding-system)))
	      ;; zipinfo mode
	      (apply 'call-process "unzip" nil (current-buffer) nil
		     (list "-Z" archive name))
	      (goto-char (point-min))
	      (when (and (re-search-forward "[0-9] \\([tTbB]\\)[^ ] " nil t)
			 (string= (upcase (match-string 1)) (match-string 1)))
		(setq enc t)))))
	(when enc
	  (unless passwd
	    (setq passwd (setq passwd (read-passwd "ZIP passwd: "))))
	  (setq args (append (list "-P" passwd) args)))
	(let ((coding-system-for-write
	       (or (and (boundp 'archive-file-name-coding-system)
			archive-file-name-coding-system)
		   file-name-coding-system))
	      (coding-system-for-read
	       (or (and (boundp 'archive-file-name-coding-system)
			archive-file-name-coding-system)
		   file-name-coding-system)))
	  (apply 'call-process "unzip" nil
		 t  ;; emacs-24 (if stderr-file (list t stderr-file) t)
		 nil args))
	(if (zerop (buffer-size))
	    (with-current-buffer (get-buffer archive-superior-buffer)
	      (when enc
		(message "may be password wrong"))
	      (setq archive-extract-passwd nil)
	      (setq ad-return-value nil))
	  (with-current-buffer (get-buffer archive-superior-buffer)
	    (setq archive-extract-passwd passwd)
	    (setq ad-return-value t))))
    ad-do-it))

○ LHA の directory セパレータ '\' 対応

ついでなので、Windows のアーカイバ で作った lzh を unix とか cygwin の lha で view するもの

(defadvice archive-extract-by-stdout (before fix-lha activate)
  (when (string= "lha" (car command))
    (let ((tmp name))
      (setq name "")
      (while (string-match "\\\\" tmp)
	(setq name (concat name (substring tmp 0 (match-beginning 0)) "/"))
	(setq tmp (substring tmp (match-end 0))))
      (setq name (concat name tmp))
      (setq name (encode-coding-string name default-file-name-coding-system)))))

○ 日本語のファイルが含まれる zip/lha にちょっとだけ対応

(add-hook 'archive-zip-mode-hook 'my-archive-set-cs)
(add-hook 'archive-lzh-mode-hook 'my-archive-set-cs)
 
(defun my-archive-set-cs ()
  (make-local-variable 'file-name-coding-system)
  (setq file-name-coding-system 'shift_jis))
 
(when (< emacs-major-version 23)
  (defadvice archive-summarize-files (before set-multibyte activate compile)
    (set-buffer-multibyte t)))