Mercurial > hg > xemacs

comparison my-news.el @ 21:7b2c4ed36302

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
for new maritain
author ht
date Mon, 30 Nov 2020 16:00:15 +0000
parents 5f3a215f12eb
children 0e5b39d2f8bb
comparison
equal deleted inserted replaced
20:06827fc8ae79 21:7b2c4ed36302
8 ; (debug-on-entry 'gnus-start-news-server) 8 ; (debug-on-entry 'gnus-start-news-server)
9 (setq gnus-nntp-server nil) 9 (setq gnus-nntp-server nil)
10 ; 10 ;
11 11
12 12
13 (setq gnus-article-save-directory "d:/mail") 13 (setq gnus-article-save-directory "/home/ht/mail/Mail")
14 14 (setq nnml-directory (expand-file-name "/home/ht/mail/Mail"))
15 (setq gnus-message-archive-method
16 '(nnfolder "archive"
17 (nnfolder-directory "/home/ht/mail/cpy")
18 (nnfolder-active-file "/home/ht/mail/cpy/active")
19 (nnfolder-get-new-mail nil)
20 (nnfolder-inhibit-expiry t)))
21 (setq gnus-secondary-select-methods
22 '((nnml "ht"
23 (gnus-show-threads nil)
24 (gnus-article-sort-functions (gnus-article-sort-by-subject gnus-article-sort-by-date))
25 )))
26 (setq mail-sources '((file :path "/var/spool/mail/ht")))
15 ;;; fixup clarinews 27 ;;; fixup clarinews
16 ;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t) 28 ;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t)
17 ;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun) 29 ;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun)
18 30
19 31
61 (if gnus-pre-config 73 (if gnus-pre-config
62 (set-window-configuration gnus-pre-config)) 74 (set-window-configuration gnus-pre-config))
63 ; (setq gnus-pre-config nil) 75 ; (setq gnus-pre-config nil)
64 ) 76 )
65 77
78 ;; Database stuff
79 (defun open-white ()
80 (setq whitelist-db (open-database "/disk/scratch/mail/white" 'berkeley-db)))
81 (defun save-white ()
82 (close-database whitelist-db)
83 (open-white))
84
85 (defun open-ad ()
86 (setq adlist-db (open-database "/disk/scratch/mail/ad" 'berkeley-db)))
87
88 (defun save-ad ()
89 (close-database adlist-db)
90 (open-ad))
91
92 (defun open-quaker ()
93 (setq quaker-db (open-database "~/mail/quaker" 'berkeley-db)))
94 (defun save-quaker ()
95 (close-database quaker-db)
96 (open-quaker))
97
98
99 (defun add-white (&optional addToBBDB)
100 (interactive "P")
101 (gnus-summary-goto-article (gnus-summary-article-number))
102 (let* ((components (get-current-from-components))
103 (addr (get-canonical-from-addr components)))
104 (if (new-white addr)
105 (save-white))
106 (if addToBBDB
107 (let ((bbdb-no-duplicates-p t))
108 (bbdb-create-internal (car components) nil (cadr components)
109 nil nil nil)))))
110
111 (defun add-ad ()
112 (interactive)
113 (gnus-summary-goto-article (gnus-summary-article-number))
114 (let ((addr (get-current-from-addr)))
115 (if (or (not (get-database addr whitelist-db))
116 (yes-or-no-p "Already white, really convert to ad?"))
117 (if (new-ad addr)
118 (save-ad)))))
119
120 (defun add-quaker()
121 (interactive)
122 (let ((addr (get-addr-before-point)))
123 (when (new-quaker addr)
124 (save-quaker))
125 (quaker-sig-maybe)))
126
127 ; not needed anymore because of gnus-posting-styles (q.v. in gnus-init)
128 (defun quaker-sig-if-to-quaker ()
129 (let ((message-options))
130 (save-excursion (message-options-set-recipient))
131 (let* ((recipStr (message-options-get 'message-recipients))
132 (recips (split-string (downcase recipStr)
133 ",[ \f\t\n\r\v]+" t)))
134 (while (and recips
135 (not (quaker-sig-if-quaker-1 (car recips))))
136 (setq recips (cdr recips))))))
137
138 (defun to-quaker-p ()
139 (let ((message-options))
140 (save-excursion (message-options-set-recipient))
141 (let* ((recipStr (message-options-get 'message-recipients))
142 (recips (split-string (downcase recipStr)
143 ",[ \f\t\n\r\v]+" t)))
144 (while (and recips
145 (not (get-database (car recips) quaker-db)))
146 (setq recips (cdr recips)))
147 (not (null recips)))))
148
149 (defun quaker-sig-if-quaker ()
150 (quaker-sig-if-quaker-1 (get-addr-before-point)))
151
152 (defun quaker-sig-if-quaker-1 (addr)
153 (if (get-database addr quaker-db)
154 (progn (quaker-sig-maybe)
155 t)))
156
157 (defun quaker-sig-maybe ()
158 (save-excursion
159 (goto-char (point-min))
160 (cond ((to-quaker-p)
161 (goto-char (point-min))
162 (cond ((search-forward "\nFrom: ht@home.hst.name" nil t)
163 (backward-char 13)
164 (delete-char 4)
165 (insert "rsof")))))
166
167 (goto-char (point-max))
168 (search-backward "\n-- \n")
169 (when (looking-at "\n-- \nHenry")
170 (forward-char 5)
171 (kill-entire-line 5)
172 (insert-file "~/.quaker-sig"))))
173
174 (defun kill-white ()
175 (interactive)
176 (gnus-summary-goto-article (gnus-summary-article-number))
177 (let ((addr (get-current-from-addr)))
178 (rem-white addr)))
179
180 (defun get-from-gnus-addr ()
181 (get-from-addr (gnus-fetch-field "From")))
182
183 (defun get-from-addr (addr)
184 (get-canonical-from-addr (gnus-extract-address-components addr)))
185
186 (defun get-canonical-from-addr (components)
187 (downcase (cadr components)))
188
189 (defun get-current-from-addr ()
190 (with-current-buffer gnus-article-buffer
191 (get-from-gnus-addr)))
192
193 (defun get-current-from-components ()
194 (with-current-buffer gnus-article-buffer
195 (gnus-extract-address-components (gnus-fetch-field "From"))))
196
197 (defun get-addr-before-point ()
198 (let ((cur (point)))
199 (save-excursion
200 (get-from-addr (buffer-substring (+ (search-backward " ") 1) cur)))
201 ))
202
203 (defun blacken-and-delete (group)
204 ;; mis-named now
205 ;; this is part of the expiry processing for xxxSPAM groups, and
206 ;; actually whitens the from addresses of #-marked articles
207 ;; The return value is crucial (and crucially outside of the scope of the if)
208 (if (memq number
209 (with-current-buffer gnus-summary-buffer
210 gnus-newsgroup-processable))
211 (let ((addr (get-from-gnus-addr)))
212 (new-white addr)))
213 'delete)
214
215 (defun unwhiten-and-delete (group)
216 ;; unused except in stale groups -- usable as an expiry
217 (if (memq number
218 (with-current-buffer gnus-summary-buffer
219 gnus-newsgroup-processable))
220 (let ((addr (get-from-gnus-addr)))
221 (remove-database addr whitelist-db)))
222 'delete)
223
224 (defun known-black (list)
225 (if (get-database (get-from-gnus-addr) blacklist-db)
226 list))
227
228 (defun white-spam (list)
229 (if (or (equal (get-database (get-from-gnus-addr) whitelist-db) "t")
230 (let ((case-fold-search t)
231 (subj (gnus-fetch-field "Subject"))
232 (from (get-from-gnus-addr)))
233 (or
234 (and subj (string-match white-subjects subj))
235 (and from
236 (let ((fromDom (substring from (+ 1 (search "@" from)))))
237 (and fromDom (member fromDom white-domains)))))))
238 list))
239
240 (defun ad-spam (list)
241 (if (let ((from (get-from-gnus-addr)))
242 (or
243 (equal (get-database from adlist-db) "t")
244 (and from
245 (let ((fromDom (substring from (+ 1 (search "@" from)))))
246 (and fromDom (member fromDom ad-domains))))
247 ))
248 list))
249
250 (defun bogoNote (group)
251 (if (memq number
252 (with-current-buffer gnus-summary-buffer
253 gnus-newsgroup-processable))
254 (let ((addr (get-from-gnus-addr)))
255 (new-white addr)))
256 (shell-command-on-region (point-min) (point-max)
257 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeBogo")
258 'delete)
259
260 (defun whiten-recip ()
261 ;;; a hook for outgoing mail
262 (let* ((recips (message-options-get 'message-recipients))
263 (res (mapcar (function new-white)
264 (split-string (downcase recips)
265 ",[ \f\t\n\r\v]*" t))))
266 (while (and res (not (car res)))
267 (setq res (cdr res)))
268 (if res (save-white))))
269
270
271 (defun new-white (addr)
272 (if (get-database addr whitelist-db)
273 nil
274 (put-database addr "t" whitelist-db)
275 t))
276
277 (defun new-ad (addr)
278 (if (get-database addr adlist-db)
279 nil
280 (put-database addr "t" adlist-db)
281 t))
282
283 (defun rem-ad ()
284 (interactive)
285 (remove-database (downcase (get-current-from-addr)) adlist-db)
286 (save-ad))
287
288 (defun new-quaker (addr)
289 (if (get-database addr quaker-db)
290 nil
291 (put-database addr "t" quaker-db)
292 t))
293
294 (defun rem-white (addr)
295 (remove-database (downcase addr) whitelist-db))
296
297 (defun bogoOK (group)
298 (shell-command-on-region (point-min) (point-max)
299 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeNonBogo")
300 'delete)
301
302 (defun del-dups ()
303 (interactive)
304 (gnus-summary-sort-by-subject)
305 (gnus-summary-clear-mark-forward 1)
306 (goto-char (point-min))
307 (let ((pos))
308 (while (setq pos (search-forward "] " nil t))
309 (end-of-line)
310 (let ((subj (buffer-substring pos (point))))
311 (unless (equal subj "")
312 (let ((target (if (< (length subj) 26)
313 (concat "] " subj "\n")
314 (concat "] " (substring subj 0 25))))
315 (done 0)
316 (case-fold-search nil))
317 (while (and (= done 0)
318 (search-forward target nil t))
319 (forward-char -3)
320 (setq done (gnus-summary-mark-as-read-forward 1))))))))
321 (gnus-summary-limit-to-unread)
322 (gnus-summary-sort-by-original))
323
324
325 (defun showMPAhtml ()
326 "Show the text/html parts of an multipart/alternative message using lynx"
327 (interactive)
328 (gnus-summary-select-article)
329 (with-current-buffer gnus-original-article-buffer
330 (shell-command-on-region (point-min) (point-max) "/home/ht/bin/showMPA.sh")
331 )
332 )
333
66 (provide 'my-news) 334 (provide 'my-news)