トップ 最新 追記

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

最近なんにもやっていませんが、なにかやったらこちらに置くようにしています。
2002|12|
2003|01|02|03|04|05|06|07|08|09|10|11|12|
2004|01|02|03|04|05|06|07|08|09|10|11|12|
2005|01|02|03|04|05|06|07|08|09|10|11|12|
2006|01|02|03|04|05|06|07|08|09|10|11|12|
2007|01|02|03|04|05|06|07|08|09|10|11|12|
2008|01|02|03|04|05|06|07|08|09|10|11|12|
2009|01|02|03|04|05|06|07|08|09|10|11|12|
2010|01|02|03|04|05|06|07|08|
2011|09|
2012|02|

2010-05-18 (Tue) [長年日記]

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

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

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

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

○ mew-draft-check-whom

もともとは、送付先アドレスチェックのために作って、後から添付ファイルの機能も入れたのでこんな名前。 
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

(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 出来ないファイルは出来ない(が差がわかんないの)。 
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

(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 するもの 
1
2
3
4
5
6
7
8
9

(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 にちょっとだけ対応

1
2
3
4
5
6
7
8
9
10

(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)))
[ツッコミを入れる]
書いている人: 白井秀行 (mailto:ｓｈｉｒａｉ＠ｍｅａｄｏｗｙ。ｏｒｇ)
訪問して下さった人: 今日: 人, 昨日: , 過去: 人 (2007年5月10日から)
RDF Feed
Generated by tDiary version 3.1.0.20110801
Powered by Ruby version 1.8.7-p352