Mercurial > hg > xemacs

comparison my-news.el @ 70:ef61b0f32027

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Henry Thompson <ht@markup.co.uk>
date Mon, 09 Jun 2025 13:21:36 +0100
parents a9b2a2335782
children e5b0b98e81a0
comparison
equal deleted inserted replaced
69:d43503e9e431 70:ef61b0f32027
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
288 nil 297 nil
289 (put-database addr "t" whitelist-db) 298 (put-database addr "t" whitelist-db)
290 t)) 299 t))
291 300
292 (defun new-ad (addr) 301 (defun new-ad (addr)
302 (new-white addr)
293 (if (get-database addr adlist-db) 303 (if (get-database addr adlist-db)
294 nil 304 nil
295 (put-database addr "t" adlist-db) 305 (put-database addr "t" adlist-db)
296 t)) 306 t))
297 307
797 (t 807 (t
798 (insert "[anon] writes:\n\n")))))) 808 (insert "[anon] writes:\n\n"))))))
799 809
800 (defun use-text-not-html (&optional clear) 810 (defun use-text-not-html (&optional clear)
801 (when (and (if clear (looking-at "<html") 811 (when (and (if clear (looking-at "<html")
802 (looking-at "> <html")) 812 (looking-at "> <\\(html\\|div\\)"))
803 (bufferp (get-buffer "*Shell Command Output*"))) 813 (bufferp (get-buffer "*Shell Command Output*")))
804 ;; replace HTML only with result of my HTML filter 814 ;; replace HTML only with result of my HTML filter
805 (delete-region (point)(mark t)) 815 (delete-region (point)(mark t))
806 (insert-buffer "*Shell Command Output*") 816 (insert-buffer "*Shell Command Output*")
807 (when (looking-at "piping") 817 (when (looking-at "piping")