(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 6)
      (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)