--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lucid/my-news.el	Mon Feb 08 11:44:37 2021 +0000
@@ -0,0 +1,742 @@
+(load "gnus" nil t)
+;(require 'spam)
+(require 'cl)
+;(spam-initialize)
+(setq
+      gnus-select-method '(nntp "usenet.inf.ed.ac.uk")
+      gnus-post-method '(nntp "usenet.inf.ed.ac.uk")
+      gnus-nntp-server nil		; override local default
+      )
+
+(setq 	gnus-use-scoring nil		; not used yet
+	gnus-summary-gather-subject-limit nil
+	gnus-thread-sort-functions
+	'(gnus-thread-sort-by-number gnus-thread-sort-by-simpl-subject)
+	gnus-summary-line-format "%U%R%5N%I%(%[%4L: %-12,12A%]%) %s\n"
+	gnus-summary-make-false-root 'none
+	gnus-mime-display-multipart-related-as-mixed t
+	gnus-simplify-subject-regexp "^\\(re[:;.]\\| \\|fwd:\\)*")
+
+(defsubst gnus-trim-simplify-subject (text)
+  (if (string-match gnus-simplify-subject-regexp text)
+      (substring text (match-end 0))
+    text))
+
+(defun gnus-thread-sort-by-simpl-subject (h1 h2)
+  "sort by slightly simplified subject"
+;  (message (format "%s:%s %s:%s" (mail-header-number (gnus-thread-header h1))(mail-header-subject (gnus-thread-header h1))(mail-header-number (gnus-thread-header h2))(mail-header-subject (gnus-thread-header h2))))
+  (let ((case-fold-search t))
+    (let ((result
+    (string-lessp
+     (downcase (gnus-trim-simplify-subject (mail-header-subject
+					    (gnus-thread-header h1))))
+     (downcase (gnus-trim-simplify-subject (mail-header-subject
+					    (gnus-thread-header h2)))))))
+;      (message (format " %s\n" result))
+      result)))
+
+
+;; 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 "/disk/scratch/mail/quaker" 'berkeley-db)))
+(defun save-quaker ()
+  (close-database quaker-db)
+  (open-quaker))
+
+(defvar database-names '(whitelist-db adlist-db quaker-db) "sic")
+
+(defun db-status (&optional name)
+  "Check on the whereabouts of a name"
+  (interactive)
+  (let ((addr
+	 (or name
+	     (progn
+	       (gnus-summary-goto-article (gnus-summary-article-number))
+	       (get-canonical-from-addr (get-current-from-components)))))
+	res)
+    (dolist (dbn database-names)
+      (if (get-database addr (eval dbn))
+	  (setq res (cons dbn res))))
+    (if name
+	res
+      (message "%s" res))))
+
+(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)))
+
+(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 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-max))
+    (search-backward "\n-- \n")
+    (when (looking-at "\n-- \n       Henry")
+      (forward-char 5)
+      (kill-entire-line 5)
+      (insert-file "/afs/inf.ed.ac.uk/user/h/ht/.quaker-sig"))))
+
+(defun kill-white ()             
+  (interactive)                 
+  (gnus-summary-goto-article (gnus-summary-article-number)) 
+  (let ((addr (downcase (get-current-from-addr))))
+    (rem-white addr)))
+
+(defun kill-ad ()             
+  (interactive)                 
+  (gnus-summary-goto-article (gnus-summary-article-number)) 
+  (let ((addr (downcase (get-current-from-addr))))
+    (rem-ad 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 (addr)
+  (remove-database 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)
+ (save-white))
+
+(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 mark-and-mark (n)
+  (interactive "p")
+  (while (>= n 1)
+    (gnus-summary-mark-as-read)
+    (gnus-summary-mark-as-processable 1)
+    (setq n (- n 1))))
+
+(defun split-on-whole-field (field pat list)
+  (goto-char (point-max))
+  (let ((hit (assq pat wsp-cache))
+	rpat)
+    (if hit
+	(setq rpat (cdr hit))
+      (setq rpat 
+	 (concat "^"
+		 field
+		 ":\\s-*"
+		 (if (stringp pat)
+		     pat
+		   (cdr (assq pat
+			      nnmail-split-abbrev-alist)))
+		 "$"))
+      (setq wsp-cache (cons (cons pat rpat) wsp-cache)))
+    (if (re-search-backward rpat nil t)
+	list)))
+
+(defun ht-gnus-summary-delete-forward ()
+  "REAL delete for nnmail gnus"  
+  (interactive)
+  (gnus-summary-delete-article)
+  (gnus-summary-next-unread-article))
+
+;; run the first time we make a summary window
+(defun gnus-summary-mode-fun1 ()
+  "install ht's mods"
+  (define-key gnus-summary-mode-map "D" 'ht-gnus-summary-delete-forward)
+  (define-key gnus-summary-mode-map "~" 'mark-and-mark)
+  (define-key gnus-summary-mode-map "\M-d" 'gnus-edit-and-move-to-diary)
+  (define-key gnus-summary-mode-map "\M-e" 'gnus-extract-attachment)
+  (define-key gnus-summary-mode-map "\M-w" 'add-white)
+  (define-key gnus-summary-mode-map [(control meta w)] 'copy-region-to-kill)
+  (define-key gnus-summary-mode-map "\M-h" 'showMPAhtml)
+  ;(define-key gnus-summary-mode-map [(control meta w)] 'kill-white)
+  (define-key gnus-summary-mode-map "\M-a" 'add-ad)
+  (define-key gnus-summary-mode-map "\M-n" 'ht-next-unseen-maybe)
+  (define-key gnus-summary-mode-map "\M-c" 'ht-catchup-and-next-unseen)
+  (define-key gnus-summary-mime-map "O" 'ht-article-save-parts)
+  (define-key gnus-summary-backend-map "M" 'ht-move-to-pers)
+  (remove-hook 'gnus-summary-mode-hook 'gnus-summary-mode-fun1))
+
+(defun message-mode-fun1 ()
+  (define-key message-mode-map [(control meta q)] 'add-quaker)
+  (remove-hook 'message-mode-hook 'message-mode-fun1))
+
+(defvar ht-gnus-just-read nil)
+
+(defun ht-catchup-and-next-unseen ()
+  (interactive)
+  (when (gnus-summary-catchup nil t nil 'fast)
+    (gnus-summary-exit)
+    (previous-line 1)
+    (ht-next-with-unseen 1)))    
+
+(defun ht-next-unseen-maybe (n)
+  (interactive "p")
+  (cond
+     ((eq (gnus-summary-next-unread-subject n) n)
+      (gnus-summary-exit)
+      (previous-line 1)
+      (if (ht-next-with-unseen n)
+	  (ht-read-group-unseen-only)))))
+
+(defun ht-gnus-pers-refresh (n)
+  (interactive "p")
+  (let ((gn (concat "nnml+ht:pers-"
+		    (format-time-string "%Y-%m" (current-time)))))
+    (gnus-group-get-new-news)
+    (let ((nn (gnus-number-of-unseen-articles-in-group gn)))
+      (gnus-group-goto-group gn)
+      (cond
+       ((> nn 0)
+	(gnus-group-read-group nn))
+       ((> n 1)
+	(let ((gnus-auto-select-subject
+	       (lambda ()
+		 (goto-char (point-max))
+		 (previous-line 1))))
+	  (gnus-group-read-group nil t)))
+       (t (goto-char (point-min))
+	  (ht-next-with-unseen 1))))
+    (message "%s" ht-gnus-just-read))	
+  )
+
+(defun no-select ()
+  (if (member gnus-newsgroup-name no-select-groups)
+      (progn (make-variable-buffer-local 'gnus-auto-select-first)
+	     (setq gnus-auto-select-first nil))))
+
+(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) "/afs/inf.ed.ac.uk/user/h/ht/share/bin/showMPA.sh")
+    )
+  )
+
+
+;; run the first time we make a group window
+(defun gnus-group-mode-fun1 ()
+  "install ht's mods"
+  (require 'gnus-msg)
+  (define-key gnus-group-mode-map "\M-\C-g" 'ht-gnus-pers-refresh)
+  (define-key gnus-group-mode-map "\M-n" 'ht-next-with-unseen)
+  (define-key gnus-group-mode-map "\M-p" 'ht-previous-with-unseen)
+  (define-key gnus-group-mode-map "\M- " 'ht-read-group-unseen-only)
+  (define-key gnus-send-bounce-map "R" 'resend-to-schemadev)
+  (define-key gnus-send-bounce-map "x" 'flush-all-nogoods)
+  (remove-hook 'gnus-group-mode-hook 'gnus-group-mode-fun1))
+
+(defun flush-all-nogoods ()
+  (interactive)
+  (while (re-search-forward
+	  "] \\(\\(Returned\\|\\([Uu]n\\|[Nn]on-?\\)deliver\\(able\\|ed\\)\\)\\( [Mm]ail\\|:?\\)\\|DELIVERY FAILURE\\|Delivery \\(Notification: Delivery has failed\\|Status Notification .\\(Failure\\|Delay\\).\\)\\|failure \\(notice\\|delivery\\)\\)"
+	  nil t)
+    (gnus-summary-mark-as-read)
+    (end-of-line)))
+
+(defun gnus-user-format-function-t (header)
+  "display the to field (for archive messages)"
+  (let ((n (mail-header-number header)))
+    (with-current-buffer nntp-server-buffer
+      (save-excursion
+	(save-restriction
+	  (let ((inhibit-point-motion-hooks t))
+	    (goto-char (point-min))
+	    (let ((beg (search-forward (format " %d Article retrieved." n)))
+		  (end (search-forward "\n.\n")))
+	      (narrow-to-region beg end)
+	      (goto-char beg)
+	      (message-fetch-field "To"))))))))
+
+(defun gnus-extract-attachment ()
+  "extract attachments from a multi-part mime message"
+  (interactive)
+  (let ((sm gnus-show-mime))
+    (if sm
+	(progn (setq gnus-show-mime nil)
+	       (gnus-summary-select-article t 'force))
+        )
+    (gnus-summary-show-all-headers)
+    (with-current-buffer gnus-article-buffer
+      (save-excursion
+	(save-restriction
+	  (mime/viewer-mode)
+	  (delete-other-windows)
+	  (let ((pt 0))
+	    (while (progn
+		     (mime-viewer/next-content)
+		     (and
+		      (equal "*Preview-*Article**" (buffer-name (current-buffer)))
+		      (not (= pt (point)))))
+	      (setq pt (point))
+	      (if (looking-at "^\\[[0-9]* \\([^ ]+ \\)+<")
+		  (mime-viewer/extract-content)))))))
+    (kill-buffer "*Preview-*Article**")
+    (setq gnus-show-mime sm)
+    ))
+
+;;; Why???
+(make-variable-buffer-local 'gnus-extra-headers)
+(make-variable-buffer-local 'nnmail-extra-headers)
+
+
+(defun resend-to-schemadev ()
+  (interactive)
+  (message "forwarding to xmlschema-dev")
+  (gnus-summary-resend-message "xmlschema-dev@w3.org" 1)
+  (gnus-summary-next-unread-article))
+
+(defun brutal-resend ()
+  (interactive)
+  (message "editing for resend. . .")
+  (unless (eq (gnus-summary-article-number)
+	      gnus-current-article)
+    (gnus-summary-select-article t))
+  (gnus-summary-toggle-header 1)
+  (with-current-buffer gnus-article-buffer
+    (toggle-read-only)
+    (gnus-article-date-original)
+    (goto-char (point-min))
+    (replace-regexp "^\\(X-Diagnostic\\|X-Envelope-To\\|X-Original-To\\|Delivered-To\\):.*\n" "")
+    (goto-char (point-min))
+    (gnus-summary-edit-article-done
+     (or (mail-header-references gnus-current-headers) "")
+     (gnus-group-read-only-p) gnus-summary-buffer nil))
+  (call-interactively (function gnus-summary-resend-message))
+  (gnus-summary-next-unread-article))
+
+; (unless (fboundp 'builtin-coding-system-p)
+;   (fset 'builtin-coding-system-p (symbol-function 'coding-system-p))
+;   (defun coding-system-p (obj)
+;     (cond
+;      ((builtin-coding-system-p obj) t)
+;      ((memq obj '(utf-8 gb2312 koi8-r iso-8859-1))
+;       (message (format "Coding system: %s" obj))
+;       t))))
+
+;;; dangerous hack to improve display of names and subjects in mail/news
+(if nil (progn
+(require 'mm-util)
+(defun mm-decode-coding-string (str cs)
+  (if (and str (eq cs 'utf-8))
+      (if (or (string-match "Â" str)
+	      (string-match "Ã" str))
+	(let* ((r 0)			; read pointer
+	       (w 0)			; write pointer
+	       (l (length str)))
+	  (while (< r l)
+	    (let* ((c (aref str r))
+		   (i (char-int c)))
+	      (cond ((= i 194)
+		     (aset str w (aref str (+ r 1)))
+		     (setq r (+ r 2)))
+		    ((= i 195)
+		     (aset str w
+			   (int-char
+			    (+ 64
+			       (char-int (aref str (+ r 1))))))
+		     (setq r (+ r 2)))
+		    (t
+		     (aset str w c)
+		     (setq r (+ r 1)))))
+	    (setq w (+ w 1)))
+	  (substring str 0 w))
+	  str)
+    str))
+
+(defun mm-sort-coding-systems-predicate (a b)
+  ;; from mm-util, abort if no priorities
+  (or (not mm-coding-system-priorities)
+      (let ((priorities
+	     (mapcar (lambda (cs)
+		       ;; Note: invalid entries are dropped silently
+		       (and (setq cs (mm-coding-system-p cs))
+			    (coding-system-base cs)))
+		     mm-coding-system-priorities)))
+	(and (setq a (mm-coding-system-p a))
+	     (if (setq b (mm-coding-system-p b))
+		 (> (length (memq (coding-system-base a) priorities))
+		    (length (memq (coding-system-base b) priorities)))
+	       t)))))))
+
+(require 'browse-url)
+
+;;; This version collects extra lines if you use right-button
+;;; to click on a URL
+(defun browse-url (url &rest args)
+  "Ask a WWW browser to load URL.
+Prompts for a URL, defaulting to the URL at or before point.  Variable
+`browse-url-browser-function' says which browser to use."
+  (interactive (browse-url-interactive-arg "URL: "))
+  (unless (interactive-p)
+    (setq args (or args (list browse-url-new-window-flag))))
+  (if (and (boundp 'event)(= 3 (event-button event)))
+      (let ((thisLine url))
+	(while (and (progn (forward-char (length thisLine))
+			   (eolp))
+		    (progn (forward-line 1)
+			   (beginning-of-line)
+			   (not (looking-at "\\s-"))))
+	  (looking-at "\\S-*")
+	  (setq thisLine (buffer-substring (match-beginning 0)
+					   (match-end 0)))
+	  (setq url (concat url thisLine)))))
+  (if (functionp browse-url-browser-function)
+      (apply browse-url-browser-function url args)
+    ;; The `function' can be an alist; look down it for first match
+    ;; and apply the function (which might be a lambda).
+    (catch 'done
+      (dolist (bf browse-url-browser-function)
+	(when (string-match (car bf) url)
+	  (apply (cdr bf) url args)
+	  (throw 'done t)))
+      (error "No browse-url-browser-function matching URL %s"
+	     url))))
+
+(defun gnus-user-format-function-H (dummy)
+  (format "%c"
+	  (cond ((eq gnus-tmp-summary-live ?*)
+		 ?*)
+		((> (gnus-number-of-unseen-articles-in-group gnus-tmp-group) 0)
+		 ?.)
+		(t ? ))))
+
+(defun ht-next-with-unseen (n)
+  (interactive "p")
+  (let* ((gvl (mapcar (function string-to-number)
+		      (split-string gnus-version-number "\\.")))
+	 (pattern (if (or (> (car gvl) 5)
+			  (and (eq (car gvl) 5)
+			       (or (> (cadr gvl) 10)
+				   (and (eq (cadr gvl) 10)
+					(> (caddr gvl) 7)))))
+		      "\\."
+		    ":\\.")))		      
+    (if (looking-at pattern)
+	(if (< n 0)
+	    (backward-char 1)
+	  (forward-char 1)))
+    (let ((missing 0)
+	  (winning (looking-at pattern)))
+      (while (and (zerop missing)
+		  (not winning))
+	(setq missing (gnus-group-next-unread-group n))
+	(setq winning (looking-at pattern)))
+      winning)))
+
+(defun ht-read-group-unseen-only ()
+  (interactive)
+  (gnus-group-read-group
+   (gnus-number-of-unseen-articles-in-group (gnus-group-group-name))))
+
+(defun ht-previous-with-unseen (n)
+  (interactive "p")
+  (ht-next-with-unseen (- n)))
+
+(defun ht-gnus-note-save-to-group ()
+  (let ((g (caar group-art)))
+    (if (not (member g ht-gnus-just-read))
+	(setq ht-gnus-just-read (cons g ht-gnus-just-read)))))
+
+(defvar ht-stash-directory "/disk/scratch/mail/stash/")
+
+(defun ht-save-part (handle n)
+  (let ((sup-type (mm-handle-media-supertype handle))
+	(sub-type (mm-handle-media-subtype handle)))
+    (message (format "%s %s/%s" n sup-type sub-type))
+    (cond ((and (equal sup-type "multipart")
+		(or (equal sub-type "alternative")
+		    (equal sub-type "related")))
+	   (let ((alts (cddr handle))
+		 (j 0))
+	     (while alts
+	       (let* ((alt (pop alts))
+		      (handle-type (mm-handle-type alt)))
+		 (let* ((sub (mm-handle-media-subtype alt))
+			(ext (cdr
+			      (assoc sub '(("calendar" . "vcs")
+					   ("v-calendar" . "vcs"))))))
+		   (setq j (+ j 1))
+		   (if (not (or (mail-content-type-get
+				 (mm-handle-disposition alt) 'filename)
+				(mail-content-type-get
+				 handle-type 'name)))
+		       (nconc
+			handle-type
+			(list (cons 'name (format "%s.%s.%s"
+						  n j (or ext sub))))))
+		   (ht-save-part alt (format "%s.%s" n j)))))))
+	  ((and (equal sup-type "text")(not
+					(member sub-type '("html"
+							   "v-calendar"
+							   "calendar"))))
+	   (message "Skipping text part: %s" (mm-handle-disposition handle)))
+	  (t
+	   (mm-save-part handle)))))
+
+(defun ht-move-to-pers (n)
+  (interactive "p")
+  (gnus-summary-move-article n
+			     (concat
+			      "nnml+ht:pers-"
+			      (format-time-string "%Y-%m" (current-time)))))
+
+(defun ht-article-save-parts (n)
+  "Save non t/p MIME parts starting at N, which is the numerical prefix."
+  (interactive "p2")
+  (let ((window (get-buffer-window gnus-article-buffer 'visible))
+	frame)
+    (when window
+      ;; It is necessary to select the article window so that
+      ;; `gnus-article-goto-part' may really move the point.
+      (setq frame (selected-frame))
+      (gnus-select-frame-set-input-focus (window-frame window))
+      (unwind-protect
+	  (save-window-excursion
+	    (select-window window)
+	    (let ((len (length gnus-article-mime-handle-alist)))
+	      (setq mm-default-directory ht-stash-directory)
+	      (while (<= n len)
+		(gnus-article-goto-part n)
+		(let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
+		  (ht-save-part handle n))
+		(setq n (+ n 1))
+		)))
+	(gnus-select-frame-set-input-focus frame))))
+  )
+
+
+(defun gnus-article-part-wrapper (n function)
+  (let ((window (get-buffer-window gnus-article-buffer 'visible))
+	frame)
+    (when window
+      ;; It is necessary to select the article window so that
+      ;; `gnus-article-goto-part' may really move the point.
+      (setq frame (selected-frame))
+      (gnus-select-frame-set-input-focus (window-frame window))
+      (unwind-protect
+	  (save-window-excursion
+	    (select-window window)
+	    (when (> n (length gnus-article-mime-handle-alist))
+	      (error "No such part"))
+	    (gnus-article-goto-part n)
+	    (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
+	      (funcall function handle)))
+	(gnus-select-frame-set-input-focus frame)))))
+
+(defun mhstore-me (dir)
+  (interactive (list (read-directory-name "Save parts to " "/tmp" "/tmp" t)))
+  (let ((art (gnus-summary-article-number)))
+    (let* ((grp-parts (split-string gnus-newsgroup-name ":"))
+	   (meth (car grp-parts))
+	   (grp (cadr grp-parts)))
+      (if (string= meth "nnml+ht")
+	(let ((doit
+		(format "cd %s && mhstore -f /disk/scratch/mail/Mail/%s/%s -auto"
+			dir grp art)))
+	  (message doit)
+	  (shell-command doit))
+	))))
+
+(defun my-message-send-and-exit (&optional arg)
+  (interactive "P")
+  (let ((message-required-mail-headers
+	 (if arg
+	     (mapcar
+	      (lambda(x)
+		(if(and(consp x)(eq(cdr x)'In-Reply-To))
+		    (cons 'optional 'xyzzy)
+		  x))
+	      message-required-mail-headers)
+	   message-required-mail-headers)))
+    (orig-message-send-and-exit)))
+
+(require 'message)
+(if (not (fboundp 'orig-message-send-and-exit))
+     (progn
+       (fset 'orig-message-send-and-exit (symbol-function 'message-send-and-exit))
+       (fset 'message-send-and-exit (symbol-function 'my-message-send-and-exit))))
+
+(provide 'my-news)