--- a/my-news.el	Mon Nov 30 15:42:47 2020 +0000
+++ b/my-news.el	Mon Nov 30 16:00:15 2020 +0000
@@ -1,66 +1,334 @@
-;; 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 "d:/mail")
-
-;;; 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)
-  )
-
-(provide 'my-news)
+;; 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)