;;  $Id: myrmail.el,v 1.4 2000/05/12 10:35:41 tag Exp $
;;; myrmail.el  - Define assorted functions for rmail mode
;;;             by Tim Gonsalves, 19-Nov-93
;;;
;;;  $Log: myrmail.el,v $
;;;  Revision 1.4  2000/05/12 10:35:41  tag
;;;  Added mail-guardian-archive-index
;;;
;;;  Revision 1.3  2000/05/10 11:27:49  tag
;;;  Added my-mail-signature
;;;  Modified mail-put-initials: centre-align closing and initials
;;;
;;;  Revision 1.2  1999/10/22 09:41:25  tag
;;;  Bug fix in mime-base64-decode-save
;;;
;;;  Revision 1.1  1999/10/22 09:29:34  tag
;;;  Modified mime-base64-decode-save to work with "Content-*" split over
;;;  two lines.
;;;
;;;        TAG, 13/11/98: added mime-base64-decode-save
;;;        TAG, 5/4/99:
;;;             converted mime-base64-decode-save from kbd-macro to ELisp
;;;        TAG, 6/5/99:
;;;             mime-base64-decode-save was converting \r -> \n when writing
;;;             to *Shell-Command-Output*.  Fixed by writing to file.
;;;             Changed b64decode to mimencode.
;;;        TAG, 6/8/99: added mail-archive-fcc
;;;        TAG, 9/8/99: modified mail-find-alias:  added completion, and
;;;                     inserts the alias.
;;;             6/9/99: fixed bug in my-mail-fcc (was adding cc: field)
;;;                     Modified mail-archive-fcc to call my-mail-fcc
;;;             8/9/99: added require 20.3 compatibility at end
;;;                     Provides 'myrmail
;;;        TAG, 29/1/07: Added mime-dir-export-bulbul, kbd macro to
;;;                     rsync mail/mime directory to Bulbul 
;;;        TAG, 15/3/07: Added mail-spam-report keyboard macro

(require 'misc)
(require 'mail-utils)

;;; Customisation of rmail variables

(defvar rmail-summary-window-size-max 10
  "*Maximum size for the rmail summary window, or frame-height/2")

(setq rmail-summary-window-size
      (progn
	(min rmail-summary-window-size-max (- (frame-height) 4))))

;;; mail-guardian-archive-index -- clean-up and archive Guardian Weekly Index 

(defvar mail-guardian-archive "~/mail/guardian"
  "*Archive file for the Guardian Weekly Index, used by \\[mail-guardian-archive-archive].")

(defvar mail-guardian-fields-list '("Date" "From" "To")
  "*List of header fields to retain in the archive.  Subject: is re-generated.
Used by \\[mail-guardian-archive-archive].")

(defvar mail-guardian-intro-regexp "^Guardian Weekly \\(Index for .*[0-9]+\\)$"
  "*Matches end of standard intro text, (match-string 1) used as Subject:.
Used by \\[mail-guardian-archive-archive].")

;;; the following strings depend on the archive format

(defvar mail-guardian-help-start "----HELP FOR NEW USERS----"
  "*Matches start of help text.  Used by \\[mail-guardian-archive-index].")

(defvar mail-guardian-help-end "HELP----"
  "*Matches end of help text.  Used by \\[mail-guardian-archive-index].")

(defvar mail-spam-new-folder "~/mail/spam_new"
  "*Folder for filing new spam.  Used by \\[mail-spam-save].")

(defun mail-spam-save ()
  "Move message to the spam folder in Unix format for Bayesian learning."
  (interactive "")
  (rmail-toggle-header 0)
  (rmail-output mail-spam-new-folder)
  (rmail-toggle-header 1))  

(fset 'mail-spam-report			; forward mail to Dspam and delete
   "fspam@lantana\C-c\C-cnd")

(defun mail-guardian-archive-index (&optional arg)
  "Prune the Guardian Weekly Index and archive it in `mail-guardian-archive'.
With prefix arg, only prune."
  (interactive "P")
  (save-excursion
    (save-match-data
      (let ((subject)
	    (fields-alist (list nil))	; (field-name . value)
	    (waspruned (rmail-msg-is-pruned))
	    (oldreadonly buffer-read-only))
	(save-restriction
					; is it a Guardian Weekly Index?
	  (goto-char (point-min))
	  (narrow-to-region (point) (search-forward "\n\n"))
	  (or (string-match "Guardian Weekly Index" (mail-fetch-field "Subject"))
	      (error "Could not find Subject: Guardian Weekly Index"))
	  (widen)
					; make editable
	  (setq buffer-read-only nil)
	  (rmail-toggle-header 0)
					; Delete unwanted header fields:
					;        1. fetch wanted fields
					;        2. delete header
					;        3. write wanted fields
	  (mapcar '(lambda (f)
		     (nconc fields-alist (list (cons f (mail-fetch-field f)))))
		  mail-guardian-fields-list)
	  (goto-char (point-min))
	  (delete-region (point-min) (search-forward "\n\n"))
	  (mapcar '(lambda (f)
		     (insert f ": " (cdr (assoc f fields-alist)) "\n"))
		  mail-guardian-fields-list)
	  (insert "\n")
					; Delete intro
	  (goto-char (point-min))
	  (search-forward "\n\n")
	  (delete-region (point)
			 (progn		; delete changes match-string!
			   (re-search-forward mail-guardian-intro-regexp)
			   (setq subject (match-string 1))
			   (point)))
					; Insert Subject:
	  (skip-chars-backward "\n")
	  (insert "\nSubject: " subject)
	  (delete-whitespace 2)
					; Delete excess \n
	  (while (search-forward "\n\n\n" nil t)
	    (replace-match "\n\n"))
					; Delete help text
	  (goto-char (point-max))
	  (search-backward mail-guardian-help-end)
	  (next-line 1)
	  (delete-region (point) (progn
				   (search-backward mail-guardian-help-start)
				   (beginning-of-line)
				   (point)))
	  (delete-whitespace 3))
				; From rmail-cease-edit: to update summary
	(if (boundp 'rmail-summary-vector)
	    (progn
	      (aset rmail-summary-vector (1- rmail-current-message) nil)
	      (save-excursion
		(rmail-widen-to-current-msgbeg
		 (function (lambda ()
			     (forward-line 2)
			     (if (looking-at "Summary-line: ")
				 (delete-region (point)
						(progn (forward-line 1)
						       (point))))))))))
					; Restore msg state
	(setq buffer-read-only oldreadonly)
	(rmail-show-message)
	(if waspruned (rmail-toggle-header 1)))))
  (if (not arg)
      (rmail-output-to-rmail-file mail-guardian-archive)))

(defvar mail-fcc-long-msg-min 12
  "*Prompt for FCC only if message has this many lines,
used by \\[mail-archive-fcc].")

(defvar mail-default-archive-file-name nil
  "*Default archive file for sent mail, used by \\[mail-archive-fcc] and \\[my-mail-fcc].")

(defun mail-archive-fcc()
  "If no FCC:, prompts whether to insert FCC: `mail-default-archive-file-name'."
  (interactive "*")
  (save-excursion
    (or (mail-position-on-field "FCC" t) ; existing FCC?
	(if (>=	     ;;; Hack: split-string missing in 19.3
		 (if (< (+ emacs-major-version
			   (/ (float emacs-minor-version) 10))
			20.0)
		     "100000000"
		   (string-to-number (car (cdr (cdr (split-string
				   (count-lines-region
				    (mail-text-start) (point-max))))))))
		mail-fcc-long-msg-min)
	    (and (y-or-n-p (concat "FCC: " mail-default-archive-file-name "? "))
		 (my-mail-fcc nil))))))

;;;  my-mail-fcc -- derived from sendmail.el:mail-fcc

(defun my-mail-fcc(arg)
  "Inserts FCC: `mail-default-archive-file-name'.
With prefix arg, prompts for name of archive, with completion."
  (interactive "P")
  (let ((folder mail-default-archive-file-name))
    (if arg
	(progn
	  (setq folder
		(read-file-name "Folder carbon copy: " "~/mail/" nil nil nil))
	  (or (mail-position-on-field "fcc" t) ; Put after existing FCC.
	      (mail-position-on-field "cc" t)
	      (mail-position-on-field "to" t))
	  (insert "\nFCC: " folder))
      (save-excursion
	(or (mail-position-on-field "fcc" t) ; Put after existing FCC.
	      (mail-position-on-field "cc" t)
	    (mail-position-on-field "to" t))
	(insert "\nFCC: " folder)
	(message (concat "Inserted FCC: " folder))))))

; find base64 encoded attachment, decode and save in ~/mail/mime/<name>
;  Note:  ~/mail/mime must exist
;         b64decode must be on the path
;         Caution:  overwrites file <name> without warning!

(defvar mime-save-dir (concat (getenv "HOME") "/mail/mime/")
  "Default directory to save decoded MIME attachment")

(defun mime-base64-decode-save()
  "Decode a base64 encoded MIME attachment and save to a file"
  (interactive)
  (save-match-data
    (let ((hdrStart) (bodyStart) (sentinel) (textType nil) (base64Type nil)
	  (name "") (fname nil))
					; Find limits of next part header
      (if (or (not (re-search-forward "^content-.*:" nil t))
	      (not (re-search-forward "^$" nil t))
	      (not (re-search-forward "^.+$" nil t)))
	   (error "Can't find attachment header"))
      (beginning-of-line 1)
      (setq bodyStart (point))
      (re-search-backward "^--")
      (setq hdrStart (point))
      (end-of-line 1)
      (setq sentinel (buffer-substring hdrStart (point)))

      (and (re-search-forward "^content-transfer-encoding:\\s-*\\bbase64$"
			     bodyStart t)
	   (setq base64Type t))
      (goto-char hdrStart)
      (and (re-search-forward
	    "^content-type:.*\\s-*\\bname=\"?\\([^\"\n]*\\)\"?$" bodyStart t)
	   (setq name (buffer-substring (match-beginning 1) (match-end 1))))
      (goto-char hdrStart)
      (and (re-search-forward
	    "^content-disposition:.*\\s-*\\bfilename=\"?\\([^\"\n]*\\)\"?$"
	    bodyStart t)
	   (setq fname (buffer-substring (match-beginning 1) (match-end 1))))
      (and (not fname) (setq fname name))
      (while (string-match " " fname)	; Replace ' ' with '_' in filename
	(setq fname (replace-match "_" t t fname)))
      (beginning-of-line 1)
      (goto-char hdrStart)
      (and (re-search-forward
	    "^content-type:\\s-*\\btext/plain" bodyStart t)
	   (setq textType t))
      (goto-char bodyStart)
      (re-search-forward (concat "^" (regexp-quote sentinel))) ; end of body
      (beginning-of-line 1)
      (if base64Type
	  (shell-command-on-region bodyStart (point) (concat "mimencode -u "
			     (if textType "-p " nil) "-o "
			     (read-file-name "Save attachment to file: "
					 mime-save-dir nil nil fname)))
	(message "Not base64 encoded"))
      nil
      )))

; mime-dir-export-bulbul -- rsync mail/mime directory to Bulbul
; TAG, 29/1/07

(fset 'mime-dir-export-bulbul
   "\C-[!cd ~/mail/mime; wdto bulbul .;ssh bulbul ls -lt mail/mime|head -5|tail -4\C-m\C-[xdisplay buffer\C-m*Shell Command Output*\C-m")

(defun rmail-reply-nocc ()
  "Reply to sender only, no CCs"
  (interactive)
  (rmail-reply t))

; rmail-input uses the current directory

(defun rmail-input-dir (filename)	; use last-rmail-file directory
  "Run RMAIL on file FILENAME in rmail-directory."
  (interactive (list (read-file-name
		      (concat "Read Rmail file: (default "
			      (file-name-nondirectory rmail-last-rmail-file)
			      ") ")
		      (file-name-directory rmail-last-rmail-file)
		      rmail-last-rmail-file)))
  (setq filename (expand-file-name filename))
  (setq rmail-last-rmail-file filename)
  (rmail filename))

(defvar mail-myinitials-alist '((1 . "TAG") (4 . "Tim") (16 . "Appa")
				(0 . "TAG"))
  "*Initials used by \\[mail-put-initials], selected by the prefix
argument.  Defaults to the '0' sublist.")

(defun mail-put-initials (arg closing)
  "Add my initials to the message.  If prefix, put name, if 2 prefixes put
personal name."
  (interactive "p\nsClosing: ")
  (let ((name (or (cdr (assq arg mail-myinitials-alist))
		  (cdr (assq 0 mail-myinitials-alist))))
	(oldfillcol fill-column))
    (setq fill-column (/ (* fill-column 2 2) 3)) ; centre about 2/3*fill-col
    (if (not (eolp))
	(end-of-line))
    (if (equal closing "")
	(insert "\n- " name)
      (progn
	(insert "\n" closing)
	(center-line)
	(insert "\n" name)))
    (center-line)
    (if (eobp)
	(insert "\n")
      (forward-char 1))
    (setq fill-column oldfillcol)))

;;; my-mail-signature -- from 20.3/lisp/mail/sendmail.el
;;;  Edited to remove the "-- " before the signature block since I use
;;;  mail-put-initials (defined in myrmail.el)
(defun my-mail-signature (atpoint)
  "Sign letter with contents of the file `mail-signature-file'.
Prefix arg means put contents at point."
  (interactive "P")
  (save-excursion
    (or atpoint
	(goto-char (point-max)))
    (skip-chars-backward " \t\n")
    (end-of-line)
    (or atpoint
	(delete-region (point) (point-max)))
;    (insert "\n\n-- \n")               %TAG-
    (insert "\n\n")			; %TAG+
    (insert-file-contents (expand-file-name mail-signature-file))))

;;; mail-find-alias - find the full name for a mail alias

(defun mail-find-alias (arg)
  "Find the full name for a mail alias."
  (interactive "P")
  (let ((name (get-current-word nil)) (temp) (translation)
	(saved-completion-ignore-case completion-ignore-case))
    (unwind-protect			; to restore completion-ignore-case
	(progn
	  (setq completion-ignore-case t)
	  (setq name (completing-read (concat "Expand alias: ")
				      mail-aliases nil nil name)))
      (setq completion-ignore-case saved-completion-ignore-case))
    (setq temp (setq translation name))
    (while temp
      (progn
	(setq temp (cdr (assoc translation mail-aliases)))
	(if temp
	    (setq translation temp))))
    (if (not (equal name ""))
	(progn
	  (if (not arg)
	      (progn
		(goto-char (get-current-word t))
		(insert name)))
	  (message "%s --> %s" name translation)))))

;;  Get and optionally delete the word before/under point.
;;  If delflag, deletes the word, and returns point at start of the word.
;;  Used in mail-find-alias.
(defun get-current-word (delflag)
  "Return the word before/under point and optionally delete it"
  (save-excursion
    (let ((start) (end) (pos (point)))
      (if (or (char-equal (char-after pos) ? )
	      (char-equal (char-after pos) ?\n)
	      (char-equal (char-after pos) ?,))
	  (skip-chars-backward " ,"))
      (skip-chars-forward "a-zA-Z0-9")
      (setq end (point))
      (skip-chars-backward "a-zA-Z0-9")
      (setq start (point))
      (if delflag
	  (progn
	    (delete-region start end)
	    start)
	(buffer-substring start end)))))

;; modified from sendmail.el:mail-yank-original, 17/9/94

(defun mail-yank-original-region (arg)
  "Insert region from the message being replied to, if any (in rmail).
Puts point before the text and mark after.
Normally, indents each nonblank line ARG spaces (default 3).
However, if `mail-yank-prefix' is non-nil, insert that prefix on each line.

Just \\[universal-argument] as argument means don't indent, insert no prefix,
and don't delete any header fields."
  (interactive "P")
  (if mail-reply-buffer
      (let ((start (point)) (replybuf (current-buffer)) (yanked-region nil))
	(save-excursion
	  (progn			; copy region into yanked-region
	    (set-buffer mail-reply-buffer)
	    (if (not mark-active)
		(error "Mark is not set in %s" mail-reply-buffer)
	      (setq yanked-region (buffer-substring (region-beginning) (region-end))))))
	(set-buffer replybuf)		; insert behaving like insert-buffer
	(push-mark)
	(insert yanked-region)
	(exchange-point-and-mark)
                        ;;
			;; the rest is verbatim from mail-yank-original
                        ;;
	(if (consp arg)
	    nil
	  (goto-char start)
	  (let ((mail-indentation-spaces (if arg (prefix-numeric-value arg)
					   mail-indentation-spaces)))
	    (if mail-citation-hook
		(run-hooks 'mail-citation-hook)
	      (if mail-yank-hooks
		  (run-hooks 'mail-yank-hooks)
		(mail-indent-citation)))))
		;; This is like exchange-point-and-mark, but doesn't activate the mark.
		;; It is cleaner to avoid activation, even though the command
		;; loop would deactivate the mark because we inserted text.
		(goto-char (prog1 (mark t)
			     (set-marker (mark-marker) (point) (current-buffer))))
		(if (not (eolp)) (insert ?\n)))))


;;; from mail-utils.el (19.26)  Added separators <SP> and <TAB> to ","
;;;      - TAG, 14/11/94
(defun mail-parse-comma-list ()
  (let (accumulated
	beg)
    (skip-chars-forward " ")
    (while (not (eobp))
      (setq beg (point))
      (skip-chars-forward "^, \t")	; added " \t"
;      (skip-chars-backward " ")        ; commented out
      (setq accumulated
	    (cons (buffer-substring beg (point))
		  accumulated))
;      (skip-chars-forward "^,")        ; commented out
      (skip-chars-forward ", \t"))	; added "\t"
    accumulated))

;;; from rmail.el (19.26)
;;; commented out putting only message-id in the in-reply-to field as
;;;  it is not sufficiently informative.
;;;
;;;         - TAG, 15/9/97

(defun rmail-make-in-reply-to-field (from date message-id)
  (cond ((not from)
         (if message-id
             message-id
             nil))
        (mail-use-rfc822
         (require 'rfc822)
         (let ((tem (car (rfc822-addresses from))))
;           (if message-id
;               (if (string-match
;                    (regexp-quote (if (string-match "@[^@]*\\'" tem)
;                                      (substring tem 0 (match-beginning 0))
;                                      tem))
;                    message-id)
;                   ;; Message-ID is sufficiently informative
;                   message-id
;                 (concat message-id " (" tem ")"))
	     ;; Copy TEM, discarding text properties.
	     (setq tem (copy-sequence tem))
	     (set-text-properties 0 (length tem) nil tem)
	     (setq tem (copy-sequence tem))
	     ;; Use prin1 to fake RFC822 quoting
	     (let ((field (prin1-to-string tem)))
	       (if date
		   (concat field "'s message of " date)
		   field))))
;		   field)))))
        ((let* ((foo "[^][\000-\037\177-\377()<>@,;:\\\" ]+")
                (bar "[^][\000-\037\177-\377()<>@,;:\\\"]+"))
           ;; Can't use format because format loses on \000 (unix *^&%*^&%$!!)
           (or (string-match (concat "\\`[ \t]*\\(" bar
                                     "\\)\\(<" foo "@" foo ">\\)?[ \t]*\\'")
                             ;; "Unix Loser <Foo@bar.edu>" => "Unix Loser"
                             from)
               (string-match (concat "\\`[ \t]*<" foo "@" foo ">[ \t]*(\\("
                                     bar "\\))[ \t]*\\'")
                             ;; "<Bugs@bar.edu>" (Losing Unix) => "Losing Unix"
                             from)))
         (let ((start (match-beginning 1))
               (end (match-end 1)))
           ;; Trim whitespace which above regexp match allows
           (while (and (< start end)
                       (memq (aref from start) '(?\t ?\ )))
             (setq start (1+ start)))
           (while (and (< start end)
                       (memq (aref from (1- end)) '(?\t ?\ )))
             (setq end (1- end)))
           (let ((field (substring from start end)))
             (if date (setq field (concat "message from " field " on " date)))
             (if message-id
                 ;; "<AA259@bar.edu> (message from Unix Loser on 1-Apr-89)"
                 (concat message-id " (" field ")")
                 field))))
        (t
         ;; If we can't kludge it simply, do it correctly
         (let ((mail-use-rfc822 t))
           (rmail-make-in-reply-to-field from date message-id)))))

(if (< (+ emacs-major-version
			   (/ (float emacs-minor-version) 10))
       20.3)
    (require 'myrmail-20-3-compat))

;;;  Keyboard macros to delete admin msgs
(fset 'rmail-clean-admin-msgs
   "\C-z\C-sroot@.* Cron\\|root@.* Anacron job\\|root@.* \\|\\*\\*\\* SECURITY information for\\|root@.* Mailrun.vsnl: oversized\C-?\C-?\C-?\C-?Cron <root\C-md")

(provide 'myrmail)