;; 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"
	;; 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
      '((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)