;;; mew-header.el --- Mail header stuff for Mew

;; Author:  Kazu Yamamoto <Kazu@Mew.org>
;; Created: Oct  2, 1996

;;; Code:

(require 'mew)

(defvar mew-anonymous-recipients ":;")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Header functions
;;;

(defsubst mew-header-goto-next ()
  (while (looking-at mew-lwsp) (forward-line)))

;; see also mew-header-end
(defsubst mew-header-goto-end ()
  (goto-char (point-min))
  (if (re-search-forward mew-eoh nil t)
      (beginning-of-line)
    (goto-char (point-max))
    (if (eolp) (insert "\n"))))

(defsubst mew-header-goto-body ()
  (mew-header-goto-end)
  (forward-line))

(defun mew-header-get-value (field &optional as-list)
  "currently, when no match, it returns nil."
  ;; maybe called in narrowed region.
  ;; we cannot widen for citation.
  (let ((case-fold-search t)
	(regex (format "^%s[ \t]*" field))
	start match ret)
    (save-excursion
      (mew-header-goto-end)
      (save-restriction
	(narrow-to-region (point-min) (point))
	(goto-char (point-min))
	(catch 'only-one
	  (while (re-search-forward regex nil t)
	    (setq start (match-end 0))
	    (forward-line)
	    (mew-header-goto-next)
	    (setq match (mew-buffer-substring start (1- (point))))
	    (unless (string= "" match)
	      (if ret
		  (if as-list
		      (setq ret (cons match ret))
		    (setq ret (concat ret "," match)))
		(if as-list
		    (setq ret (list match))
		  (setq ret match))
		(if (string= field mew-from:) (throw 'only-one nil))))))))
    (if as-list
	(nreverse ret)
      ret)))

(defalias 'mew-header-existp 'mew-header-get-value)

(defun mew-header-replace-value (field value)
  (let ((case-fold-search t)
	(regex (format "^%s[ \t]*" field))
	start)
    (save-excursion
      (mew-header-goto-end)
      (save-restriction
	(narrow-to-region (point-min) (point))
	(goto-char (point-min))
	;; make value with evaluating
	(if (and (listp value)
		 (stringp (car value)))
	    (setq value (cons 'format value)))
	(setq value 
	      (condition-case e
		  (eval value)
		(error 
		 (format "*** ERROR: %s: %s ***" (car e) (car (cdr e))))))
	(unless (or (stringp value)
		    (null value))
	  (setq value (format "%s" value)))
	;; at this time, value is string or nil
	(cond
	 ((re-search-forward regex nil t)
	  (setq start (match-beginning 0))
	  (forward-line)
	  (mew-header-goto-next)
	  (delete-region start (point))
	  (if value
	      (mew-draft-header-insert field value)))
	 (value ;; insert when value is exist
	  (mew-header-goto-end)
	  (mew-draft-header-insert field value)))))))

(defun mew-make-field-regex (fields)
  (concat "^\\(" (mapconcat 'identity fields "\\|") "\\)"))

(defun mew-header-delete-lines (fields)
  (when fields
    (let ((case-fold-search t)
	  (regex (mew-make-field-regex fields))
	  start)
      (mew-header-goto-end)
      (save-restriction
	(narrow-to-region (point-min) (point))
	(goto-char (point-min))
	(while (re-search-forward regex nil t)
	  (setq start (match-beginning 0))
	  (forward-line)
	  (mew-header-goto-next)
	  (delete-region start (point)))))))

(defun mew-header-delete-other-lines (fields)
  (when fields
    (let ((case-fold-search t)
	  (regex (mew-make-field-regex fields))
	  start)
      (mew-header-goto-end)
      (save-restriction
	(narrow-to-region (point-min) (point))
	(goto-char (point-min))
	(while (not (eobp))
	  (if start (delete-region start (point)))
	  (if (looking-at regex)
	      (setq start nil)
	    (setq start (point)))
	  (forward-line)
	  (mew-header-goto-next))
	(if start (delete-region start (point)))))))

(defun mew-header-replace-lines (fields prefix)
  (when fields
    (let ((case-fold-search t)
	  (regex (mew-make-field-regex fields)))
      (mew-header-goto-end)
      (save-restriction
	(narrow-to-region (point-min) (point))
	(goto-char (point-min))
	(while (re-search-forward regex nil t)
	  (beginning-of-line)
	  (insert prefix)
	  (forward-line))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Header sort
;;;

(defun mew-header-sort (order)
  (when order
    (let* ((case-fold-search t)
	   (len (length order))
	   (vec (make-vector len nil))
	   (i 0)
	   key beg n line other)
      (mew-header-goto-end)
      (save-restriction
	(narrow-to-region (point-min) (point))
	(goto-char (point-min))
	(while (not (eobp))
	  (if (not (looking-at mew-keyval))
	      (forward-line)
	    (setq key (mew-match-string 1))
	    (setq beg (match-beginning 0))
	    (forward-line)
	    (mew-header-goto-next)
	    (setq line (mew-buffer-substring beg (point)))
	    (delete-region beg (point))
	    (setq n (mew-member-case-equal key order))
	    (if n
		(aset vec n (concat (aref vec n) line))
	      (setq other (concat other line)))))
	(while (< i len)
	  (and (aref vec i) (insert (aref vec i)))
	  (setq i (1+ i)))
	(and other (insert other))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Header insertion
;;;

(defsubst mew-draft-header-insert (field value)
  "No encoding. Just insert."
  (if (and value (stringp field)) (insert field " " value "\n")))

(defsubst mew-draft-header-fill (field value)
  (unless (mew-header-existp field) (mew-draft-header-insert field value)))

(defun mew-header-insert (key value &optional no-fold)
  (if (and value (stringp key))
      (let ((beg (point)) params med par parname parval)
	(when (listp value)
	  (setq params (cdr value))
	  (setq value (car value)))
	(insert key)
  	(insert " ")
	(setq med (point))
	(if (string-match "^[\t -~]*$" value)
	    (insert value)
	  (mew-header-encode-text value nil (length key)))
	(while params
	  (setq par (car params))
	  (mew-set '(parname parval) par)
	  (setq params (cdr params))
	  (insert ";")
	  (cond
	   ((string-match "^[-a-zA-Z0-9]+$" parval)
	    ) ;; do nothing
	   ((and (string= (mew-charset-guess-string parval) mew-us-ascii)
		 (not (string-match "\"" parval)))
	    (setq parval (concat "\"" parval "\"")))
	   (t
	    (setq parval (mew-param-encode parval))
	    (setq parname (concat parname "*"))))
	  (insert " " parname "=" parval))
	(insert "\n")
	(unless no-fold
	  (mew-header-fold-region beg (point) med)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Low-level functions to parse fields
;;;

;;
;; The purpose of this function is to purse and extract value
;; of address or content header. text is not target!
;;
;; ADDRP is t if STR are addresses.
;; ADDRP is nil if STR is a value of content-*.
;;
;; 'Winnie (The) Pooh <"W. Pooh" (loves "honey") @ (somewhere in) England>'
;; ->
;; '"W. Pooh"@England'
;;
;; For 'destination', SEP is ",".
;; For Content-*, SEP is ";".
;;
;; The special (i.e. SEP) is one of delimiters.
;; 'linear-white-space' is another delimiter.
;; 'quoted-string', 'comment', and 'domain-literal' is self-delimiting.
;; But 'domain-literal' (e.g. [1.2.3.4]) is meaningless.
;; So, the delimiters consists of SEP, SP, TAB, CRLF, "(", ")", and <">.
;; 
;; 'qtext' remains. (It will be removed by mew-param-decode.)
;; ## how about 'quoted-pair'?
;;
;; 'comment' must be symmetric. That is, it must have the exact number of
;; ")" against that of ")". The entire 'comment', even if nested, is 
;; ignored.
;;
;; 'encoded-word' is meaningless.
;; (1) Remove 'comment' so 'encoded-word' in 'comment' is meaningless.
;; (2) 'phrase' of 'mailbox' will be ignored because 'addr-spec' in 
;; 'route-addr' will be extracted. So, 'encoded-word' in 'phrase' is
;; meaningless.

(defmacro mew-addrstr-parse-syntax-list-check-depth (&optional depth)
  `(progn
     (setq sep-cnt (1+ sep-cnt))
     (if (and ,depth (>= sep-cnt ,depth))
	 (throw 'max nil))
     (when (and (integerp mew-header-max-depth)
		(>= sep-cnt mew-header-max-depth))
       (mew-warn "Too many values. Truncate values over mew-header-max-depth")
       (throw 'max nil))))

(defun mew-addrstr-parse-syntax-list (str sep addrp &optional depth)
  (when str
    (if (featurep 'mew-temacs)
	(setq str (string-as-unibyte str))) ;; A bug of Emacs 20.7
    (let* ((i 0) (len (length str))
	   (par-cnt 0) (tmp-cnt 0) (sep-cnt 0)
	   (tmp (make-string len ?x))
	   c ret)
      (catch 'max
	(while (< i len)
	  (setq c (aref str i))
	  (cond
	   ((char-equal c ?\")
	    (aset tmp tmp-cnt c)
	    (setq tmp-cnt (1+ tmp-cnt))
	    (setq i (1+ i))
	    (catch 'quote
	      (while (< i len)
		(setq c (aref str i))
		(cond
		 ((char-equal c ?\")
		  (aset tmp tmp-cnt c)
		  (setq tmp-cnt (1+ tmp-cnt))
		  (throw 'quote nil))
		 ((char-equal c ?\n)
		  (setq i (1+ i))
		  (catch 'fold-quote
		    (while (< i len)
		      (setq c (aref str i))
		      (cond
		       ;; ((or (char-equal c ?\t) (char-equal c mew-sp))
		       ;; (setq i (1+ i)))
		       ((char-equal c ?\")
			(aset tmp tmp-cnt c)
			(setq tmp-cnt (1+ tmp-cnt))
			(throw 'quote nil))
		       (t
			(aset tmp tmp-cnt c)
			(setq tmp-cnt (1+ tmp-cnt))
			(throw 'fold-quote nil))))))
		 (t
		  (aset tmp tmp-cnt c)
		  (setq tmp-cnt (1+ tmp-cnt))))
		(setq i (1+ i)))))
	   ((char-equal c ?\()
	    (setq par-cnt 1)
	    (setq i (1+ i))
	    (catch 'comment
	      (while (< i len)
		(setq c (aref str i))
		(cond
		 ((char-equal c ?\()
		  (setq par-cnt (1+ par-cnt)))
		 ((char-equal c ?\))
		  (setq par-cnt (1- par-cnt))
		  (if (eq par-cnt 0) (throw 'comment nil))))
		(setq i (1+ i)))))
	   ((char-equal c ?<)
	    (cond
	     (addrp
	      (let (rbeg rend)
		(setq i (1+ i))
		(setq rbeg i)
		(while (and (< i len) (not (char-equal (aref str i) ?>)))
		  (setq i (1+ i)))
		(when (> i rbeg)
		  (setq rend i)	;; note: to be used for substring, so not 1-.
		  ;; should not be nested but easy to implement...
		  (setq ret (cons (car (mew-addrstr-parse-syntax-list
					(substring str rbeg rend) sep t))
				  ret))))
	      (while (and (< i len) (not (char-equal (aref str i) sep)))
		(setq i (1+ i)))
	      (setq tmp-cnt 0)
	      (mew-addrstr-parse-syntax-list-check-depth depth))
	     (t
	      ;; just ignore
	      (while (and (< i len) (not (char-equal (aref str i) ?>)))
		(setq i (1+ i))))))
	   ((char-equal c ?\n))
	   ((char-equal c ?\t))
	   ((char-equal c mew-sp))
	   ((char-equal c sep)
	    ;; broken quoted string cannot be rescued because
	    ;; the separator cannot be distinguished
	    (if (> tmp-cnt 0)
		(setq ret (cons (substring tmp 0 tmp-cnt) ret)))
	    (setq tmp-cnt 0)
	    (mew-addrstr-parse-syntax-list-check-depth depth))
	   (t 
	    (aset tmp tmp-cnt c)
	    (setq tmp-cnt (1+ tmp-cnt)))) ;; end of cond
	  (setq i (1+ i)))		  ;; end of while
	(when (> tmp-cnt 0)
	  ;; broken quoted string can be rescued if it appears solely
	  (save-match-data
	    (if (string-match "<\\([^>]+\\)>" tmp)
		(setq ret (cons (mew-match-string 1 tmp) ret))
	      (setq ret (cons (substring tmp 0 tmp-cnt) ret)))))) ;; end of catch
      (setq ret (delete nil ret))
      (if (featurep 'mew-temacs)
	  (mapcar 'string-as-multibyte (nreverse ret)) ;; A bug of Emacs 20.7
	(nreverse ret)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; High-level functions to parse fields
;;;

(defsubst mew-addrstr-parse-value (value)
  (car (mew-addrstr-parse-syntax-list value ?\; nil 1)))

(defsubst mew-addrstr-parse-value-list (value)
  (mew-addrstr-parse-syntax-list value ?\; nil))

(defsubst mew-addrstr-parse-value2 (value)
  (car (mew-addrstr-parse-syntax-list value ?, nil 1)))

(defsubst mew-addrstr-parse-value-list2 (value)
  (mew-addrstr-parse-syntax-list value ?, nil))

;;

(defsubst mew-addrstr-parse-address (address)
  (car (mew-addrstr-parse-syntax-list address ?, t 1)))

(defsubst mew-addrstr-parse-address-list (address)
  (mew-addrstr-parse-syntax-list address ?, t))

(defsubst mew-header-parse-address (field)
  (car
   (mew-addrstr-parse-syntax-list
    (mapconcat 'mew-header-get-value (list field) ",")
    ?, t 1)))

(defsubst mew-header-parse-address-list (field-list)
  (mew-addrstr-parse-syntax-list
   (mapconcat 'mew-header-get-value field-list ",")
   ?, t))

(defun mew-header-parse-address-list2 (field-list)
  "Collect addresses from FIELD-LIST. 
Remove anonymous addresses."
  (let ((vals (mew-addrstr-parse-syntax-list
	       (mapconcat 'mew-header-get-value field-list ",")
	       ?, t))
	ret)
    (while vals
      (unless (string-match mew-anonymous-recipients (car vals))
	(setq ret (cons (car vals) ret)))
      (setq vals (cdr vals)))
    (nreverse ret)))

;;

(defsubst mew-addrstr-extract-user-list (addr-list)
  (mapcar 'mew-addrstr-extract-user addr-list))

(defun mew-addrstr-extract-user (addr)
  "Extracts username from ADDR"
  (if (string-match "@.*:" addr) ;; xxx what's this?
      (setq addr (substring addr (match-end 0)))
    (setq addr (mew-replace-character addr mew-sp ?_))
    (setq addr (substring addr 0 (string-match "%" addr)))
    (setq addr (substring addr 0 (string-match "@" addr)))
    ;; just for refile:  "To: recipients:;" -> recipients
    (setq addr (substring addr 0 (string-match mew-anonymous-recipients addr)))
    ;; removing Notes domain
    (setq addr (substring addr 0 (string-match "/" addr)))))

;;

(defun mew-addrstr-append-domain (addr)
  (if mew-addrbook-append-domain-p
      (if (string-match "@" addr)
	  addr
	(concat addr "@" (mew-mail-domain))) ;; xxx
    addr))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Functions for ID
;;;

(defun mew-idstr-get-first-id (idstr)
  (when (stringp idstr)
    (if (string-match mew-regex-id idstr)
	(mew-replace-white-space2 (match-string 0 idstr)))))

(defun mew-idstr-get-last-id (idstr)
  (when (stringp idstr)
    (let (beg end start)
      (while (string-match mew-regex-id idstr start)
	(setq beg (match-beginning 0))
	(setq end (match-end 0))
	(setq start (match-end 0)))
      (if (and beg end)
	  (mew-replace-white-space2 (substring idstr beg end))))))

(defun mew-idstr-to-id-list (idstr &optional rev)
  (when (stringp idstr)
    (let (ret start)
      (while (string-match mew-regex-id idstr start)
	(setq start (match-end 0))
	(setq ret (cons (mew-replace-white-space2 (match-string 0 idstr)) ret)))
      (if rev
	  ret
	(nreverse ret)))))

(defun mew-id-list-to-idstr (id-list)
  (let (skip)
    (if (integerp mew-references-max-count)
	(setq skip (- (length id-list) mew-references-max-count)))
    (if (and (numberp skip) (> skip 0))
	(setq id-list (nthcdr skip id-list)))
    (mew-join "\n\t" id-list)))

(provide 'mew-header)

;;; Copyright Notice:

;; Copyright (C) 1996-2007 Mew developing team.
;; All rights reserved.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. Neither the name of the team nor the names of its contributors
;;    may be used to endorse or promote products derived from this software
;;    without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; mew-header.el ends here
