Mercurial > hg > lib > markup

comparison emacs/gnus-init.el @ 1:f005daf4488a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
local changes since 2007
author Henry S. Thompson <ht@inf.ed.ac.uk>
date Tue, 25 May 2021 13:58:37 -0400
parents
children
comparison
equal deleted inserted replaced
0:509549c55989 1:f005daf4488a
1 ;; Last edited: Fri Aug 20 14:49:23 1999
2 ;; gnus customisation
3 (setq mm-inline-large-images t) ;prevent crash in mm-image-fit-p ???
4 (setq gnus-novice-user nil)
5 (setq gnus-message-archive-group
6 '((concat "general." (format-time-string
7 "%Y-%m" (current-time)))))
8
9 (setq gnus-summary-ignore-duplicates t
10 gnus-auto-select-next 'quietly
11 gnus-summary-display-arrow nil
12 gnus-your-organization "HCRC, University of Edinburgh"
13 gnus-ignored-headers
14 "^Errors-To:\\|^Precedence:\\|^UNIX-From:"
15 mm-discouraged-alternatives '("text/html")
16 nnmail-expiry-wait 28
17 nnmail-spool-file
18 '((file)(file :path "/home/ht/mbox")))
19
20 (setq bbdb/news-auto-create-p t)
21
22 (defconst hash-file "/home/ht/.whitelist")
23
24 (defvar white-hash (make-hash-table :test (function equal)))
25
26 (with-current-buffer (get-buffer-create " *Whitelist")
27 (insert-file-contents hash-file)
28 (goto-char (point-min))
29 (while (not (eobp))
30 (puthash (buffer-substring (point) (progn
31 (end-of-line)
32 (point)))
33 t
34 white-hash)
35 (forward-line)))
36
37 (defun get-from-addr ()
38 (gnus-extract-address-components
39 (gnus-fetch-field "From")))
40
41 (defun get-current-from-addr ()
42 (with-current-buffer gnus-article-buffer
43 (get-from-addr)))
44
45 (defun white-list (list)
46 (if (or (gethash (cadr (get-from-addr))
47 white-hash)
48 (let ((subj (gnus-fetch-field "Subject")))
49 (and subj
50 (string-match "\\[\\([^]]*\\)\\]" subj)
51 (member (match-string 1 subj) white-lists))))
52 list))
53
54 (defun add-white ()
55 (interactive)
56 (gnus-summary-goto-article (gnus-summary-article-number))
57 (do-add-white (cadr (get-current-from-addr))))
58
59 (defun do-add-white (addr)
60 (puthash addr t white-hash)
61 (with-current-buffer (get-buffer " *Whitelist")
62 (let ((max (point-max)))
63 (goto-char max)
64 (insert addr)
65 (insert "\n")
66 (write-region max (point) hash-file t))))
67
68 (defun bogoNote (group)
69 (shell-command-on-region (point-min) (point-max)
70 "/home/ht/bin/makeBogo")
71 'delete)
72
73
74 (defun whiten-recip ()
75 ;;; a hook for outgoing mail
76 (let ((recips (message-options-get 'message-recipients)))
77 (mapcar (function new-white)
78 (split-string recips ",[ \f\t\n\r\v]+" t))))
79
80 (add-hook 'message-sent-hook (function whiten-recip))
81
82 (defun new-white (addr)
83 (if (gethash addr white-hash)
84 nil
85 (do-add-white addr)))
86
87 (setq wsp-cache nil)
88
89 (defun split-on-whole-field (field pat list)
90 (goto-char (point-max))
91 (let ((hit (assq pat wsp-cache))
92 rpat)
93 (if hit
94 (setq rpat (cdr hit))
95 (setq rpat
96 (concat "^"
97 field
98 ":\\s-*"
99 (if (stringp pat)
100 pat
101 (cdr (assq pat
102 nnmail-split-abbrev-alist)))
103 "$"))
104 (setq wsp-cache (cons (cons pat rpat) wsp-cache)))
105 (if (re-search-backward rpat nil t)
106 list)))
107
108 (setq nnmail-crosspost nil)
109 (setq nnmail-split-methods 'nnmail-split-fancy)
110
111 (setq ht-lists
112 '(("Subject" "Cron <mt> /home/mt/bin/heartbeat" "heartbeat")
113 ("Subject" "Cron <mt[@]markup> /home/mt/bin/heartbeat" "heartbeat")
114 (to "xml-dev" "xml")
115 (to "markup@markup[a-zA-Z]*" "markup")
116 (to "general@developer.marklogic.com" "marklogic")
117 (to "betterform-users@lists.sourceforge.net" "betterform")
118 (to "betterform-developer@lists.sourceforge.net" "betterform")
119 (to "mrbs-[a-zA-Z]*@lists.sourceforge.net" "mrbs")
120 (to "selenium-users" "selenium")
121 (to "sqlobject-discuss" "sqlobject")
122 (to "exist-open@lists.sourceforge.net" "exist")
123 (to "exim-users@exim.org" "exim")
124 (to "exist-development@lists.sourceforge.net" "exist")
125 (to "xsltforms-support@lists.sourceforge.net" "xsltforms")
126 (to "mtt" "mtt")
127 (to "ding" "gnus")))
128
129 (setq white-lists '("selenium-users" "Betterform-users" "Exist-development" "Exist-open"))
130
131 (defvar ht-compiled-split nil)
132
133 (defun set-ht-compiled-split ()
134 "update the mail splitting rules"
135 (interactive)
136 (setq ht-compiled-split
137 (let* ((month
138 (format-time-string "%Y-%m" (current-time)))
139 (now-group (concat "group-" month))
140 (now-pers (concat "pers-" month)))
141 `(|
142 (: split-on-whole-field "Subject" "testing" 'junk)
143 ,@ht-lists
144 (to "ht\\|henry\\|\\(h\\.?\\)?thompson?" ,now-pers)
145 (to "xml-dev" "xml")
146 ,now-group
147 ))))
148
149 (set-ht-compiled-split)
150
151 (setq nnmail-split-fancy
152 '(!
153 (lambda (sres)
154 (if (or (equal (car sres) "notSPAM")
155 (equal (car sres) "waSPAM"))
156 ;; documentation is wrong, no recursion,
157 ;; so we do it ourselves :-(
158 (nnmail-split-it ht-compiled-split)
159 sres))
160 (| (to "ht@hppllc.org" "llc")
161 ("X-Bogosity" "\\(Yes\\|Unsure\\).*"
162 (| (: white-list "waSPAM")
163 ("X-Spam-Score" "0" "boSPAM")
164 ("X-Bogosity" "Unsure.*" "mSPAM")
165 "bfSPAM"))
166 (: split-on-whole-field "X-Spam-Level" "\\*\\*\\*\\*.*"
167 '(| (: white-list "waSPAM")
168 "saSPAM"))
169 ("X-Spam-Status" "Yes.*"
170 (| (: white-list "waSPAM")
171 "saSPAM"))
172 "notSPAM")))
173
174 (defun ht-gnus-summary-delete-forward ()
175 "REAL delete for nnmail gnus"
176 (interactive)
177 (gnus-summary-delete-article)
178 (gnus-summary-next-unread-article))
179
180 (require 'my-news)
181 (setq gnus-show-mime t) ; stale
182
183 ;; try to ignore list name in subject for sorting
184 (setq message-subject-re-regexp "^[ ]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ ]*\\)*\\(\\[[^]]*\\]\\)?[ ]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ ]*\\)*")
185
186 (custom-set-variables
187 '(gnus-treat-display-picons nil))
188 (custom-set-faces)
189
190 (require 'mm-decode)
191 (setq mm-automatic-display (remove "text/html" mm-automatic-display))
192
193 (add-hook 'gnus-group-mode-hook 'gnus-topic-mode)
194
195 (add-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1)
196
197 ;; run the first time we make a summary window
198 (defun gnus-summary-mode-fun1 ()
199 "install ht's mods"
200 (define-key gnus-summary-mode-map "D" 'ht-gnus-summary-delete-forward)
201 (define-key gnus-summary-mode-map "\M-d" 'gnus-edit-and-move-to-diary)
202 (define-key gnus-summary-mode-map "\M-e" 'gnus-extract-attachment)
203 (define-key gnus-summary-mode-map "\M-w" 'add-white)
204 (define-key gnus-summary-mode-map "\M-h" 'showMPAhtml)
205 (define-key gnus-summary-mode-map "~" 'mark-and-mark)
206 (remove-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1))
207
208 (defun ht-gnus-pers-refresh (n)
209 (interactive "p")
210 (let ((gn (concat "nnml+ht:pers-"
211 (format-time-string "%Y-%m" (current-time)))))
212 (gnus-group-goto-group gn)
213 (gnus-group-get-new-news-this-group n)
214 (gnus-group-goto-group gn)
215 (gnus-group-read-group))
216 )
217
218 (add-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1)
219
220 ;; run the first time we make a group window
221 (defun gnus-group-mode-fun1 ()
222 "install ht's mods"
223 (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh)
224 (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1))
225
226 (defun gnus-user-format-function-t (header)
227 "display the to field (for archive messages)"
228 (let ((n (mail-header-number header)))
229 (with-current-buffer nntp-server-buffer
230 (save-excursion
231 (save-restriction
232 (let ((inhibit-point-motion-hooks t))
233 (goto-char (point-min))
234 (let ((beg (search-forward (format " %d Article retrieved." n)))
235 (end (search-forward "\n.\n")))
236 (narrow-to-region beg end)
237 (goto-char beg)
238 (message-fetch-field "To"))))))))
239
240 (defun showMPAhtml ()
241 "Show the text/html parts of an multipart/alternative message using lynx"
242 (interactive)
243 (gnus-summary-select-article)
244 (with-current-buffer gnus-original-article-buffer
245 (shell-command-on-region (point-min) (point-max) "/home/ht/bin/showMPA.sh")
246 )
247 )
248
249 (defun gnus-extract-attachment ()
250 "extract attachments from a multi-part mime message"
251 (interactive)
252 (let ((sm gnus-show-mime))
253 (if sm
254 (progn (setq gnus-show-mime nil)
255 (gnus-summary-select-article t 'force))
256 )
257 (gnus-article-show-all-headers)
258 (with-current-buffer gnus-article-buffer
259 (save-excursion
260 (save-restriction
261 (mime/viewer-mode)
262 (delete-other-windows)
263 (let ((pt 0))
264 (while (progn
265 (mime-viewer/next-content)
266 (and
267 (equal "*Preview-*Article**" (buffer-name (current-buffer)))
268 (not (= pt (point)))))
269 (setq pt (point))
270 (if (looking-at "^\\[[0-9]* \\([^ ]+ \\)+<")
271 (mime-viewer/extract-content)))))))
272 (kill-buffer "*Preview-*Article**")
273 (setq gnus-show-mime sm)
274 ))
275
276 (make-variable-buffer-local 'gnus-extra-headers)
277 (make-variable-buffer-local 'nnmail-extra-headers)
278 (add-hook 'gnus-parse-headers-hook
279 '(lambda ()
280 (gnus-summary-set-local-parameters gnus-newsgroup-name)))
281
282 (defun del-dups ()
283 (interactive)
284 (gnus-summary-sort-by-subject)
285 (gnus-summary-clear-mark-forward 1)
286 (goto-char (point-min))
287 (let ((pos))
288 (while (setq pos (search-forward "] " nil t))
289 (end-of-line)
290 (let ((subj (buffer-substring pos (point))))
291 (unless (equal subj "")
292 (let ((target (if (< (length subj) 26)
293 (concat "] " subj "\n")
294 (concat "] " (substring subj 0 25))))
295 (done 0)
296 (case-fold-search nil))
297 (while (and (= done 0)
298 (search-forward target nil t))
299 (forward-char -3)
300 (setq done (gnus-summary-mark-as-read-forward 1))))))))
301 (gnus-summary-limit-to-unread)
302 (gnus-summary-sort-by-original))
303
304 (add-hook 'gnus-get-new-news-hook (lambda () (setq ht-gnus-just-read nil)))
305
306 (add-hook 'gnus-after-getting-new-news-hook
307 (lambda () (message "%s" ht-gnus-just-read)))
308
309 (defvar ht-gnus-just-read nil)
310
311 (defun ht-gnus-note-save-to-group ()
312 (let ((g (caar group-art)))
313 (if (not (member g ht-gnus-just-read))
314 (setq ht-gnus-just-read (cons g ht-gnus-just-read)))))
315
316 (add-hook 'nnml-prepare-save-mail-hook (function ht-gnus-note-save-to-group))