Re: New mail-related routines

[Alexander Pohoyda <alexander.pohoyda@gmx.net>]

Please comment on this code.  Thank you!

;;; The -hf suffix means Header Field.

(defconst mail-wsp-regexp "[\040\011]")
(defconst mail-crlf-regexp "[\015]?[\012]")

;; Header fields must be unfolded before using these regexps.  This
;; agrees with the RFC 2822, section 2.2.3, last paragraph.

;; Unstructured header fields
(defconst mail-hf-name-regexp "[\041-\071\073-\176]+")
(defconst mail-hf-body-regexp "[^\015\012]*")
(defconst mail-hf-regexp
  (format "^\\(%s\\)%s*:%s*\\(%s\\)%s*\\(%s\\)?"
	  mail-hf-name-regexp mail-wsp-regexp mail-wsp-regexp
	  mail-hf-body-regexp mail-wsp-regexp mail-crlf-regexp))

\f
;;;
;;; General-purpose mail functions
;;;

;; Merging this function with `rfc822-goto-eoh' failed, because
;; mbox-formatted messages start with "From name@example.org...",
;; which is neither a valid header field, nor the end of header.
(defun mail-body-start-position (&optional from to)
  "Return a position where the body of a message starts.

If called without arguments, the current buffer is assumed to be
narrowed to exactly one message.

This function may also be used to get the body start position of
a MIME entity in the region between FROM and TO."
  (save-excursion
    (goto-char (or from (point-min)))
    (save-match-data
      (if (or (search-forward (concat "\n" mail-header-separator "\n") to t)
	      (search-forward "\n\n" to t))
	  (point)
	(message "This entity has no body")
	(or to (point-max))))))

(defun mail-header-end-position (&optional from to)
  "Return a position where the header of a message ends.

If called without arguments, the current buffer is assumed to be
narrowed to exactly one message.

This function may also be used to get the header end position of
a MIME entity in the region between FROM and TO."
  (save-excursion
    (goto-char (mail-body-start-position (or from (point-min))
					 (or to (point-max))))
    (forward-line -1)
    (point)))

\f
;;;
;;; Header field functions
;;;

(defsubst mail-make-hf (name body)
  "Return \"NAME: BODY\" string."
  (when name (concat name ": " body)))

(defsubst mail-insert-hf (header-field)
  "Insert the HEADER-FIELD created by `mail-make-hf' function at point."
  (when header-field (insert header-field "\n")))

(defun mail-search-hf (name &optional from to)
  "Find a header field named NAME in the message header.
Set point at the beginning of the field found, and return point.
If the header field is not found, do not move the point and return nil.
The argument FROM defaults to `point-min' and the argument TO is
set to the message header end."
  (let ((found nil)
	(case-fold-search t))
    (save-excursion
      (goto-char (or from (point-min)))
      (save-match-data
	(when (re-search-forward (concat "^" name ":") to t)
	  (setq found (point-at-bol)))))
    (when found (goto-char found))))

(defun mail-hf-body-position ()
  "Return a position where the current header field body starts."
  (save-excursion
    (save-match-data
      (re-search-forward (format ":\\(%s*\\)" mail-wsp-regexp) nil t))))

(defun mail-hf-end-position ()
  "Return a position where the current header field ends."
  (save-excursion
    (save-match-data
      (while (progn
	       (forward-line)
	       (looking-at (format "%s+" mail-wsp-regexp))))
      (point))))

(defun mail-get-hf-at-point ()
  "Return the header field at point."
  (buffer-substring-no-properties (point) (mail-hf-end-position)))

(defun mail-get-hf (name &optional from to)
  "Return the whole header field called NAME as a string.

The argument FROM defaults to `point-min' and the argument TO is
set to the message header end.

The trailing CRLF is also included."
  (save-excursion
    (when (mail-search-hf name from to)
      (mail-get-hf-at-point))))

(defun mail-get-hf-name (header-field)
  "Return the name of the HEADER-FIELD string."
  (when header-field
    (setq header-field (mail-unfold-hf header-field))
    (save-match-data
      (when (string-match mail-hf-regexp header-field)
	(match-string-no-properties 1 header-field)))))

(defun mail-get-hf-body (header-field)
  "Return the body of the HEADER-FIELD string."
  (when header-field
    (setq header-field (mail-unfold-hf header-field))
    (save-match-data
      (when (string-match mail-hf-regexp header-field)
	(match-string-no-properties 2 header-field)))))

(defun mail-process-hfs-in-region (from to function)
  "Enumerate all header fields in the region between FROM and TO and
call FUNCTION on them."
  (save-excursion
    (goto-char from)
    (save-restriction
      (narrow-to-region from to)
      ;; RFC 2822, section 2.2.3.
      (while (re-search-forward "^[^ \t]+:" nil t)
	(beginning-of-line)
	;;(message "Processing `%s' header..."
	;;	 (mail-get-hf-name (mail-get-hf-at-point)))
	(funcall function (point) (mail-hf-end-position))
	;; Goto next header field
	(goto-char (mail-hf-end-position)))
      (- (point-max) from))))

(defun mail-sort-hfs-in-region (from to sort-list)
  "Sort header fields in the region between FROM and TO, using
SORT-LIST as a sequence."
  (save-excursion
    (goto-char from)
    (save-restriction
      (narrow-to-region from to)
      ;; Do the job.
      (let ((my-pos (point))
	    my-hf)
	(dolist (sorted-hf sort-list)
	  ;;(message "Sorting `%s' header..." sorted-hf)
	  (when (mail-search-hf sorted-hf)
	    (setq my-hf (mail-get-hf-at-point))
	    (delete-region (point) (mail-hf-end-position))
	    (goto-char my-pos)
	    (insert my-hf)
	    (setq my-pos (point))))))))

(defun mail-fold-hf (header-field)
  "See description of `mail-fold-region' function."
  (when header-field
    (with-temp-buffer
      ;;(message "Header to fold:\n%s" header-field)
      (insert header-field)
      (mail-fold-region (point-min) (point-max))
      (buffer-string))))

(defun mail-fold-region (from to &optional limit)
  "Fold header fields in the region between FROM and TO,
as defined by RFC 2822.  The LIMIT argument defaults to 76."
  (save-excursion
    (goto-char from)
    (save-restriction
      (narrow-to-region from to)
      (let ((limit (or limit 76))
	    start)
	(while (not (eobp))
	  (setq start (point))
	  (goto-char (min (+ (point) (- limit (current-column)))
			  (point-at-eol)))
	  (if (and (>= (current-column) limit)
		   (re-search-backward mail-wsp-regexp start t)
		   (not (looking-at (format "\n%s" mail-wsp-regexp))))
	      ;; Insert line break
	      (progn
		(insert "\n")
		(forward-char))
	    (if (re-search-backward mail-wsp-regexp start t)
		(forward-line)
	      ;; Token is too long, so we skip it
	      (re-search-forward mail-wsp-regexp nil t)
	      (backward-char)
	      (insert "\n")
	      (forward-char))))))))

(defun mail-unfold-hf (header-field &optional loose)
  "See description of `mail-unfold-region' function."
  (when header-field
    (with-temp-buffer
      ;;(message "Header to unfold:\n%s" header-field)
      (insert header-field)
      (mail-unfold-region (point-min) (point-max) loose)
      (buffer-string))))

(defun mail-unfold-region (from to &optional loose)
  "Unfold header fields in the region between FROM and TO, 
as defined by RFC 2822.

If LOOSE argument is non-nil, replace also all leading WSP
characters with just one SPACE."
  (save-excursion
    (goto-char from)
    (save-restriction
      (narrow-to-region from to)
      (save-match-data
	(while (re-search-forward
		(format "\\(%s\\)%s+" mail-crlf-regexp mail-wsp-regexp) nil t)
	  (if loose
	      (replace-match " " nil t)
	    (replace-match "" nil t nil 1)))))))


-- 
Alexander Pohoyda <alexander.pohoyda@gmx.net>
PGP Key fingerprint: 7F C9 CC 5A 75 CD 89 72  15 54 5F 62 20 23 C6 44