Mercurial > hg > xemacs

comparison my-news.el @ 63:e7c2deb7de20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
old changes ??, get add-white working
author Henry S Thompson <ht@inf.ed.ac.uk>
date Mon, 16 Dec 2024 18:19:39 +0000
parents 963ac2f8e386
children a9b2a2335782
comparison
equal deleted inserted replaced
62:fea10b67cc09 63:e7c2deb7de20
120 (setq res (cons dbn res)))) 120 (setq res (cons dbn res))))
121 (if name 121 (if name
122 res 122 res
123 (message "%s" res)))) 123 (message "%s" res))))
124 124
125 (defun add-white (&optional addToBBDB) 125 (defun add-white (&optional dontAddToBBDB)
126 "While reading an article, add to whitelist"
126 (interactive "P") 127 (interactive "P")
127 (gnus-summary-goto-article (gnus-summary-article-number)) 128 (gnus-summary-goto-article (gnus-summary-article-number))
128 (let* ((components (get-current-from-components)) 129 (do-add-white (gnus-fetch-original-field "From") dontAddToBBDB))
130
131 (defun do-add-white (addr &optional dontAddToBBDB)
132 (let* ((components (gnus-extract-address-components addr))
129 (addr (get-canonical-from-addr components))) 133 (addr (get-canonical-from-addr components)))
134 (if (not dontAddToBBDB)
135 (let ((bbdb-no-duplicates-p t))
136 (condition-case nil
137 (bbdb-create-internal (car components) nil
138 (cadr components) nil nil nil)
139 (error
140 ;; OK, just means already present
141 ))))
130 (if (new-white addr) 142 (if (new-white addr)
131 (save-white)) 143 (save-white))))
132 (if addToBBDB
133 (let ((bbdb-no-duplicates-p t))
134 (bbdb-create-internal (car components) nil (cadr components)
135 nil nil nil)))))
136 144
137 (defun add-ad () 145 (defun add-ad ()
138 (interactive) 146 (interactive)
139 (gnus-summary-goto-article (gnus-summary-article-number)) 147 (gnus-summary-goto-article (gnus-summary-article-number))
140 (let ((addr (get-current-from-addr))) 148 (let ((addr (get-current-from-addr)))
148 (let ((addr (get-addr-before-point))) 156 (let ((addr (get-addr-before-point)))
149 (when (new-quaker addr) 157 (when (new-quaker addr)
150 (save-quaker)) 158 (save-quaker))
151 (quaker-sig-maybe))) 159 (quaker-sig-maybe)))
152 160
153 ; not needed anymore because of gnus-posting-styles (q.v. in gnus-init) 161 ; not needed anymore because of gnus-posting-styles (q.v. in mail-from-*)
154 (defun quaker-sig-if-to-quaker () 162 (defun quaker-sig-if-to-quaker ()
155 (let ((message-options)) 163 (let ((message-options))
156 (save-excursion (message-options-set-recipient)) 164 (save-excursion (message-options-set-recipient))
157 (let* ((recipStr (message-options-get 'message-recipients)) 165 (let* ((recipStr (message-options-get 'message-recipients))
158 (recips (split-string (downcase recipStr) 166 (recips (split-string (downcase recipStr)
272 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeBogo") 280 "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeBogo")
273 'delete) 281 'delete)
274 282
275 (defun whiten-recip () 283 (defun whiten-recip ()
276 ;;; a hook for outgoing mail 284 ;;; a hook for outgoing mail
277 (let* ((recips (message-options-get 'message-recipients)) 285 (let* ((to (message-fetch-field "To"))
278 (res (mapcar (function new-white) 286 (cc (message-fetch-field "cc"))
279 (split-string (downcase recips) 287 (msg-recipients (concat to (and to cc ", ") cc))
280 ",[ \f\t\n\r\v]*" t)))) 288 (recips (message-tokenize-header msg-recipients))
289 (res (mapcar (function do-add-white) recips)))
281 (while (and res (not (car res))) 290 (while (and res (not (car res)))
282 (setq res (cdr res))) 291 (setq res (cdr res)))
283 (if res (save-white)))) 292 (if res (save-white))))
284 293
285 294