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

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

;;; Code:

(defconst mew-header-version "mew-header.el version 0.12")

(require 'mew)

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

(defun mew-header-get-value (field)
  "currently, when no match, it returns nil."
  (let ((case-fold-search t)
	(start nil)
	(key nil)
	(match nil)
	(count 0)
	(ret nil)) ;; (concat nil "foo") -> "foo"
    (save-excursion
      (goto-char (point-min))
      (catch 'header
	(while (re-search-forward (format "^-*$\\|^%s[ \t]*" field) nil t)
	  (if (>= count mew-header-max-depth)
	      (throw 'header ret)) ;; xxx warn to users?
	  (setq count (1+ count))
	  (setq key (mew-match 0))
	  (setq start (match-end 0))
	  (if (string-match "^-*$" key) (throw 'header ret))
	  (forward-line)
	  (while (looking-at mew-lwsp) (forward-line))
	  (setq match (mew-buffer-substring start (1- (point))))
	  (if (null ret)
	      (if (null (string= "" match))
		  (setq ret match))
	    (if (null (string= "" match))
		(setq ret (concat ret "," match))))
	)))
    ret
    ))
	  
(defun mew-header-get-line (field)
;; return  with ^J
;; currently, when no match, it returns nil.
  (let ((case-fold-search t)
	(start nil)
	(key nil)
	(count 0)
	(ret nil)) ;; (concat nil "foo") -> "foo"
    (save-excursion
      (goto-char (point-min))
      (catch 'header
	(while (re-search-forward (format "^-*$\\|^%s" field) nil t)
	  (if (>= count mew-header-max-depth)
	      (throw 'header ret)) ;; xxx warn to users?
	  (setq count (1+ count))
	  (setq key (mew-match 0))
	  (setq start (match-beginning 0))
	  (if (string-match "^-*$" key) (throw 'header ret))
	  (forward-line)
	  (while (looking-at mew-lwsp) (forward-line))
	  (setq ret (concat ret (mew-buffer-substring start (point))))
	  ))
      )
    ret
    ))

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

(defun mew-header-delete-lines (fields)
  (let ((case-fold-search t)
	(regex (mew-make-field-regex fields))
	key start)
    (save-excursion
      (goto-char (point-min))
      (catch 'header
	(while (re-search-forward (concat "^-*$\\|" regex) nil t)
	  (setq key (mew-match 0)
		start (match-beginning 0))
	  (if (string-match "^-*$" key) (throw 'header nil))
	  (forward-line)
	  (while (looking-at mew-lwsp) (forward-line))
	  (delete-region start (point))
	  ))
      )))

(defun mew-header-resent-lines (fields)
  (let ((case-fold-search t)
	(regex (mew-make-field-regex fields))
	key)
    (save-excursion
      (goto-char (point-min))
      (catch 'header
	(while (re-search-forward (concat "^-*$\\|" regex) nil t)
	  (setq key (mew-match 0))
	  (if (string-match "^-*$" key) (throw 'header nil))
	  (beginning-of-line)
	  (insert "Prev-")
	  ))
      )))

(defun mew-header-insert-here (field &optional value noret)
  (insert field)
  (insert " ")
  (if value (insert value))
  (if (not noret) (insert "\n"))
  )

(defun mew-header-insert-param-here (params)
  (if (null params)
      ()
    (insert (format "; %s" (car params)))
    (setq params (cdr params))
    (while params
      (insert (format ";\n\t%s" (car params)))
      (setq params (cdr params)))))


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

;;
;; Get a canonical syntax
;;
;; '"Winnie (The) Pooh" (loves "honey") @ (somewhere in) England'
;; ->
;; '"Winnie (The) Pooh"@England'
;;
(defun mew-header-syntax (string)
  (let* ((i 0) (len (length string))
	 (par-cnt 0) (ret-cnt 0)
	 (ret (make-string len ?x))
	 quoted c)
    (while (< i len)
      (setq c (aref string i))
      (cond
       (quoted
	(if (char-equal c ?\") (setq quoted nil))
	(aset ret ret-cnt c)
	(setq ret-cnt (1+ ret-cnt))
	)
       ((> par-cnt 0)
	(cond
	 ((char-equal c ?\() (setq par-cnt (1+ par-cnt)))
	 ((char-equal c ?\)) (setq par-cnt (1- par-cnt)))
	 )
	)
       ((char-equal c ?\() (setq par-cnt 1))
       ((char-equal c ?\n))
       ((char-equal c ?\t))
       ((char-equal c ?\ ))
       (t 
	(if (char-equal c ?\") (setq quoted t))
	(aset ret ret-cnt c)
	(setq ret-cnt (1+ ret-cnt))
	)
       )
      (setq i (1+ i))
      )
    (substring ret 0 ret-cnt)
    ))

;;
;; Split a string by a separator.
;;
;; "Winnie-The-Pooh" -> "Winnie", "The", "Pooh"
;;
(defun mew-header-split (string sep)
 (let ((quote nil)
       (len (length string))
       (ret nil)
       (start 0)
       (n 0))
   (while (< n len)
     (cond
      ((char-equal (aref string n) ?\")
       (setq quote (not quote)))
      ((char-equal (aref string n) sep)
       (if (null quote)
	   (progn
	     (setq ret (cons (substring string start n) ret))
	     (setq start (1+ n))
	     )
	 ))
      )
     (setq n (1+ n))
     )
   (setq ret (cons (substring string start n) ret))
   (nreverse ret)
   ))

;;
;; Extract an address from <>.
;;
;; "Winnie The Pooh <wtp@uk>" -> "wtp@uk"
;;
(defmacro mew-header-extract-addr-list (list)
  (` (mapcar (function mew-header-extract-addr) (, list))))

(defun mew-header-extract-addr (str)
  "Extracts a real e-mail address from STR and returns it.
e.g. \"Mine Sakurai <m-sakura@ccs.mt.nec.co.jp>\"
  ->  \"m-sakura@ccs.mt.nec.co.jp\".
e.g. \"m-sakura@ccs.mt.nec.co.jp (Mine Sakurai)\"
  ->  \"m-sakura@ccs.mt.nec.co.jp\"."
  (cond ((string-match ".*<\\([^>]*\\)>" str) ;; .* to extract last <>
         (mew-match 1 str))
        ((string-match "\\([^ \t]*@[^ \t]*\\)" str)
         (mew-match 1 str))
        (t str)
    )
  )

;;
;; Delete a string after @.
;;
;; "Pooh@England" -> "Pooh"
;;
(defmacro mew-header-delete-at-list (list)
  (` (mapcar (function mew-header-delete-at) (, list))))

(defun mew-header-delete-at (string)
  (if (string-match "@.*:" string)
      (setq string (substring string (match-end 0) (length string)))
    (setq string (substring string 0 (string-match "%" string)))
    (setq string (substring string 0 (string-match "@" string)))
    (substring string 0 (string-match ":;" string))
    ))

;;
;; Delete null strings.
;;
;; "Winnie", "", "The", "", "Pooh"
;; ->
;; "Winnie", "The", "Pooh"
;;
(defun mew-header-delete-nullstring-list (list)
  (if (null list)
      ()
    (cond 
     ((string= (car list) "") 
      (mew-header-delete-nullstring-list (cdr list)))
     (t 
      (cons (car list) (mew-header-delete-nullstring-list (cdr list)))))))

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

(defun mew-header-syntax-list (string)
  (mew-header-split
   (mew-header-syntax string)
   ?;))

(defun mew-header-user-collect (list)
  (let ((fields (mapcar (function mew-header-get-value) list))
	(users "") (count 0) (begin 0))
    (while fields
      (if (car fields) 
	  (setq users (concat users "," (car fields))))
      (setq fields (cdr fields)))
    (while (and (< count mew-header-max-depth) 
		(string-match "," users begin))
      (setq begin (match-end 0))
      (setq count (1+ count))
      )
    (if (equal count mew-header-max-depth)
	(setq users (substring users 0 begin)))
    (mew-header-delete-nullstring-list
     (mew-header-delete-at-list
      (mew-header-extract-addr-list
       (mew-header-split
	(mew-header-syntax users)
	?,))))
    ))


(defun mew-header-address-collect (list)
  (let ((fields (mapcar (function mew-header-get-value) list))
	(users "") (count 0) (begin 0))
    (while fields
      (if (car fields) 
	  (setq users (concat users "," (car fields))))
      (setq fields (cdr fields)))
    (while (and (< count mew-header-max-depth) 
		(string-match "," users begin))
      (setq begin (match-end 0))
      (setq count (1+ count))
      )
    (if (>= count mew-header-max-depth)
	(progn
	  (message "Too many addresses, truncated after %d" 
		   mew-header-max-depth)
	  (ding)
	  (sit-for 3) ;; enough time to read?
	  ))
    (if (equal count mew-header-max-depth) 
	(setq users (substring users 0 begin)))
    (mew-header-delete-nullstring-list
     (mew-header-extract-addr-list
      (mew-header-split
       (mew-header-syntax users)
       ?,)))
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Alias functions
;;;

(defun mew-header-expand-alias (alias)
  (let ((assoc (mew-assoc-case-equal alias mew-alias-alist 0)))
    (if assoc 
	(cdr assoc)
      alias)
    ))

(defun mew-header-expand-alias-list (alias-list)
  (mapcar (function mew-header-expand-alias) alias-list)
  )

(defun mew-header-decrypters-collect (list)
  (let ((fields (mapcar (function mew-header-get-value) list))
	(users "") (count 0) (begin 0) a)
    (catch 'first
      (while fields
	(setq a (car fields) fields (cdr fields))
	(if (null a)
	    ()
	  (setq users a)
	  (throw 'first nil)
	  )))
    (while fields
      (if (car fields) 
	  (setq users (concat users "," (car fields))))
      (setq fields (cdr fields)))
    (while (and (< count mew-header-max-depth) 
		(string-match "," users begin))
      (setq begin (match-end 0))
      (setq count (1+ count))
      )
    (if (>= count mew-header-max-depth)
	(progn
	  (message "Too many addresses, truncated after %d" 
		   mew-header-max-depth)
	  (ding)
	  (sit-for 3) ;; enough time to read?
	  ))
    (if (equal count mew-header-max-depth) 
	(setq users (substring users 0 begin)))
    users
    ))

(defun mew-header-get-address (field)
  (let ((value (mew-header-get-value field)))
    (if (null value)
	nil
      (mew-header-extract-addr (mew-header-syntax value))
      )
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; e-mail address canonical form 
;;;

(defmacro mew-header-canform-list (list)
  (` (mapcar (function mew-header-canform) (, list))))

(defun mew-header-canform (string)
  "Complete STRING with mew-mail-domain."
  (if (or (null mew-mail-domain) (string= mew-mail-domain ""))
      string
    (if (string-match "@" string)
	string
      (concat string "@" mew-mail-domain)))
  )

(provide 'mew-header)

;;; Copyright Notice:

;; Copyright (C) 1996, 1997, 1998 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. All advertising materials mentioning features or use of this software
;;    must display the following acknowledgement:
;;       This product includes software developed by 
;;       Mew developing team and its contributors.
;; 4. 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
