--- a/my-news.el	Sat Oct 07 12:43:14 2023 +0100
+++ b/my-news.el	Sun Oct 08 16:36:27 2023 +0100
@@ -1,31 +1,47 @@
-;; Last edited: Wed Aug 25 14:10:36 1999
+(message "my-news")
+; (debug-on-entry 'gnus-start-news-server)
+(setq
+      gnus-select-method '(nntp "hebe.uk.clara.net")
+      gnus-post-method '(nntp "usenet.inf.ed.ac.uk")
+      gnus-nntp-server nil		; override local default
+      )
 
-;(site-caseq (edin (require 'ccs-gnus)))
+(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:\\)*")
 
-; mix-spool stuff
+(defsubst gnus-trim-simplify-subject (text)
+  (if (string-match gnus-simplify-subject-regexp text)
+      (substring text (match-end 0))
+    text))
 
-(load "gnus" nil t)
-; (debug-on-entry 'gnus-start-news-server)
-(setq gnus-nntp-server nil)
-;
+(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)))
 
 
-(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"
-	;; the following two are not taking effect, not sure why, answer
-	;; _may_ lie in gnus-setup-news...
-	(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
+(setq nnfolder-get-new-mail nil
+      nnfolder-inhibit-expiry t
+      gnus-secondary-select-methods
       '((nnml "ht"
 	      (gnus-show-threads nil)
-	      (gnus-article-sort-functions (gnus-article-sort-by-subject gnus-article-sort-by-date))
+	      (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)
@@ -51,16 +67,7 @@
    ))
 
 ;(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.
@@ -79,24 +86,41 @@
 
 ;; Database stuff
 (defun open-white ()
-  (setq whitelist-db (open-database "/disk/scratch/mail/white" 'berkeley-db)))
+  (setq whitelist-db (open-database (concat my-mail-dir "/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)))
+  (setq adlist-db (open-database (concat my-mail-dir "/ad") 'berkeley-db)))
 
 (defun save-ad ()
   (close-database adlist-db)
   (open-ad))
 
 (defun open-quaker ()
-  (setq quaker-db (open-database "~/mail/quaker" 'berkeley-db)))
+  (setq quaker-db (open-database (concat my-mail-dir "/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")
@@ -156,29 +180,18 @@
       (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)))
+  (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")))
 
@@ -282,9 +295,8 @@
     (put-database addr "t" adlist-db)
     t))
 
-(defun rem-ad ()
-  (interactive)
-  (remove-database (downcase (get-current-from-addr)) adlist-db)
+(defun rem-ad (addr)
+  (remove-database addr adlist-db)
   (save-ad))
 
 (defun new-quaker (addr)
@@ -294,7 +306,8 @@
     t))
 
 (defun rem-white (addr)
- (remove-database (downcase addr) whitelist-db))
+ (remove-database (downcase addr) whitelist-db)
+ (save-white))
 
 (defun bogoOK (group)
   (shell-command-on-region (point-min) (point-max)
@@ -323,14 +336,457 @@
   (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) "/home/ht/bin/showMPA.sh")
+    (shell-command-on-region (point-min) (point-max)
+			     (expand-file-name "~/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 (concat my-mail-dir "/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 (concat "cd %s && mhstore -f "
+				my-mail-dir "/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)