Mercurial > hg > xemacs
view my-news.el @ 21:7b2c4ed36302
for new maritain
author | ht |
---|---|
date | Mon, 30 Nov 2020 16:00:15 +0000 |
parents | 5f3a215f12eb |
children | 0e5b39d2f8bb |
line wrap: on
line source
;; Last edited: Wed Aug 25 14:10:36 1999 ;(site-caseq (edin (require 'ccs-gnus))) ; mix-spool stuff (load "gnus" nil t) ; (debug-on-entry 'gnus-start-news-server) (setq gnus-nntp-server nil) ; (setq gnus-article-save-directory "/home/ht/mail/Mail") (setq nnml-directory (expand-file-name "/home/ht/mail/Mail")) (setq gnus-message-archive-method '(nnfolder "archive" (nnfolder-directory "/home/ht/mail/cpy") (nnfolder-active-file "/home/ht/mail/cpy/active") (nnfolder-get-new-mail nil) (nnfolder-inhibit-expiry t))) (setq gnus-secondary-select-methods '((nnml "ht" (gnus-show-threads nil) (gnus-article-sort-functions (gnus-article-sort-by-subject gnus-article-sort-by-date)) ))) (setq mail-sources '((file :path "/var/spool/mail/ht"))) ;;; fixup clarinews ;(autoload 'gnus-clarinews-fun "clari-clean" "Clean ClariNews articles" t) ;(add-hook 'gnus-article-prepare-hook 'gnus-clarinews-fun) (defun gnus-Subject-sort-by-subject-and-date (reverse) "Sort subject display buffer by subject alphabetically. `Re:'s are ignored. If case-fold-search is non-nil, case of letters is ignored. Date is used if subjects are equal Argument REVERSE means reverse order." (interactive "P") (gnus-summary-sort-summary (function (lambda (a b) (let ((s-a (gnus-trim-simplify-subject (nntp-header-subject a))) (s-b (gnus-trim-simplify-subject (nntp-header-subject b))) ) (or (gnus-string-lessp s-a s-b) (and (gnus-string-equal s-a s-b) (gnus-date-lessp (nntp-header-date a) (nntp-header-date b))))))) reverse )) ;(require 'util-mde) ; for string-replace-regexp-2 (defun gnus-trim-simplify-subject (text) "call gnus-simplify-subject and remove leading blanks" (if text (gnus-simplify-subject (string-replace-regexp-2 (gnus-simplify-subject text t) "^\\s-+" "") t) "")) (defun gnus-string-equal (a b) "Return T if first arg string is equal than second in lexicographic order. If case-fold-search is non-nil, case of letters is ignored." (if case-fold-search (string-equal (downcase a) (downcase b)) (string-equal a b))) (defun gnus-Group-update-and-vanish () "update newsrc and restore config pre-group selection" (interactive) (gnus-group-force-update) (if gnus-pre-config (set-window-configuration gnus-pre-config)) ; (setq gnus-pre-config nil) ) ;; Database stuff (defun open-white () (setq whitelist-db (open-database "/disk/scratch/mail/white" 'berkeley-db))) (defun save-white () (close-database whitelist-db) (open-white)) (defun open-ad () (setq adlist-db (open-database "/disk/scratch/mail/ad" 'berkeley-db))) (defun save-ad () (close-database adlist-db) (open-ad)) (defun open-quaker () (setq quaker-db (open-database "~/mail/quaker" 'berkeley-db))) (defun save-quaker () (close-database quaker-db) (open-quaker)) (defun add-white (&optional addToBBDB) (interactive "P") (gnus-summary-goto-article (gnus-summary-article-number)) (let* ((components (get-current-from-components)) (addr (get-canonical-from-addr components))) (if (new-white addr) (save-white)) (if addToBBDB (let ((bbdb-no-duplicates-p t)) (bbdb-create-internal (car components) nil (cadr components) nil nil nil))))) (defun add-ad () (interactive) (gnus-summary-goto-article (gnus-summary-article-number)) (let ((addr (get-current-from-addr))) (if (or (not (get-database addr whitelist-db)) (yes-or-no-p "Already white, really convert to ad?")) (if (new-ad addr) (save-ad))))) (defun add-quaker() (interactive) (let ((addr (get-addr-before-point))) (when (new-quaker addr) (save-quaker)) (quaker-sig-maybe))) ; not needed anymore because of gnus-posting-styles (q.v. in gnus-init) (defun quaker-sig-if-to-quaker () (let ((message-options)) (save-excursion (message-options-set-recipient)) (let* ((recipStr (message-options-get 'message-recipients)) (recips (split-string (downcase recipStr) ",[ \f\t\n\r\v]+" t))) (while (and recips (not (quaker-sig-if-quaker-1 (car recips)))) (setq recips (cdr recips)))))) (defun to-quaker-p () (let ((message-options)) (save-excursion (message-options-set-recipient)) (let* ((recipStr (message-options-get 'message-recipients)) (recips (split-string (downcase recipStr) ",[ \f\t\n\r\v]+" t))) (while (and recips (not (get-database (car recips) quaker-db))) (setq recips (cdr recips))) (not (null recips))))) (defun quaker-sig-if-quaker () (quaker-sig-if-quaker-1 (get-addr-before-point))) (defun quaker-sig-if-quaker-1 (addr) (if (get-database addr quaker-db) (progn (quaker-sig-maybe) t))) (defun quaker-sig-maybe () (save-excursion (goto-char (point-min)) (cond ((to-quaker-p) (goto-char (point-min)) (cond ((search-forward "\nFrom: ht@home.hst.name" nil t) (backward-char 13) (delete-char 4) (insert "rsof"))))) (goto-char (point-max)) (search-backward "\n-- \n") (when (looking-at "\n-- \nHenry") (forward-char 5) (kill-entire-line 5) (insert-file "~/.quaker-sig")))) (defun kill-white () (interactive) (gnus-summary-goto-article (gnus-summary-article-number)) (let ((addr (get-current-from-addr))) (rem-white addr))) (defun get-from-gnus-addr () (get-from-addr (gnus-fetch-field "From"))) (defun get-from-addr (addr) (get-canonical-from-addr (gnus-extract-address-components addr))) (defun get-canonical-from-addr (components) (downcase (cadr components))) (defun get-current-from-addr () (with-current-buffer gnus-article-buffer (get-from-gnus-addr))) (defun get-current-from-components () (with-current-buffer gnus-article-buffer (gnus-extract-address-components (gnus-fetch-field "From")))) (defun get-addr-before-point () (let ((cur (point))) (save-excursion (get-from-addr (buffer-substring (+ (search-backward " ") 1) cur))) )) (defun blacken-and-delete (group) ;; mis-named now ;; this is part of the expiry processing for xxxSPAM groups, and ;; actually whitens the from addresses of #-marked articles ;; The return value is crucial (and crucially outside of the scope of the if) (if (memq number (with-current-buffer gnus-summary-buffer gnus-newsgroup-processable)) (let ((addr (get-from-gnus-addr))) (new-white addr))) 'delete) (defun unwhiten-and-delete (group) ;; unused except in stale groups -- usable as an expiry (if (memq number (with-current-buffer gnus-summary-buffer gnus-newsgroup-processable)) (let ((addr (get-from-gnus-addr))) (remove-database addr whitelist-db))) 'delete) (defun known-black (list) (if (get-database (get-from-gnus-addr) blacklist-db) list)) (defun white-spam (list) (if (or (equal (get-database (get-from-gnus-addr) whitelist-db) "t") (let ((case-fold-search t) (subj (gnus-fetch-field "Subject")) (from (get-from-gnus-addr))) (or (and subj (string-match white-subjects subj)) (and from (let ((fromDom (substring from (+ 1 (search "@" from))))) (and fromDom (member fromDom white-domains))))))) list)) (defun ad-spam (list) (if (let ((from (get-from-gnus-addr))) (or (equal (get-database from adlist-db) "t") (and from (let ((fromDom (substring from (+ 1 (search "@" from))))) (and fromDom (member fromDom ad-domains)))) )) list)) (defun bogoNote (group) (if (memq number (with-current-buffer gnus-summary-buffer gnus-newsgroup-processable)) (let ((addr (get-from-gnus-addr))) (new-white addr))) (shell-command-on-region (point-min) (point-max) "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeBogo") 'delete) (defun whiten-recip () ;;; a hook for outgoing mail (let* ((recips (message-options-get 'message-recipients)) (res (mapcar (function new-white) (split-string (downcase recips) ",[ \f\t\n\r\v]*" t)))) (while (and res (not (car res))) (setq res (cdr res))) (if res (save-white)))) (defun new-white (addr) (if (get-database addr whitelist-db) nil (put-database addr "t" whitelist-db) t)) (defun new-ad (addr) (if (get-database addr adlist-db) nil (put-database addr "t" adlist-db) t)) (defun rem-ad () (interactive) (remove-database (downcase (get-current-from-addr)) adlist-db) (save-ad)) (defun new-quaker (addr) (if (get-database addr quaker-db) nil (put-database addr "t" quaker-db) t)) (defun rem-white (addr) (remove-database (downcase addr) whitelist-db)) (defun bogoOK (group) (shell-command-on-region (point-min) (point-max) "/afs/inf.ed.ac.uk/user/h/ht/share/bin/local/makeNonBogo") 'delete) (defun del-dups () (interactive) (gnus-summary-sort-by-subject) (gnus-summary-clear-mark-forward 1) (goto-char (point-min)) (let ((pos)) (while (setq pos (search-forward "] " nil t)) (end-of-line) (let ((subj (buffer-substring pos (point)))) (unless (equal subj "") (let ((target (if (< (length subj) 26) (concat "] " subj "\n") (concat "] " (substring subj 0 25)))) (done 0) (case-fold-search nil)) (while (and (= done 0) (search-forward target nil t)) (forward-char -3) (setq done (gnus-summary-mark-as-read-forward 1)))))))) (gnus-summary-limit-to-unread) (gnus-summary-sort-by-original)) (defun showMPAhtml () "Show the text/html parts of an multipart/alternative message using lynx" (interactive) (gnus-summary-select-article) (with-current-buffer gnus-original-article-buffer (shell-command-on-region (point-min) (point-max) "/home/ht/bin/showMPA.sh") ) ) (provide 'my-news)