From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Alexander Pohoyda Newsgroups: gmane.emacs.devel Subject: Re: New mail-related routines Date: 26 Oct 2004 00:43:47 +0200 Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Message-ID: <874qkibeqk.fsf@oak.pohoyda.family> References: <200410182157.i9ILvjln000739@oak.pohoyda.family> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-Trace: sea.gmane.org 1098744277 24007 80.91.229.6 (25 Oct 2004 22:44:37 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Mon, 25 Oct 2004 22:44:37 +0000 (UTC) Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Tue Oct 26 00:44:30 2004 Return-path: Original-Received: from lists.gnu.org ([199.232.76.165]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1CMDZm-0003VZ-00 for ; Tue, 26 Oct 2004 00:44:30 +0200 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.33) id 1CMDhR-0006PZ-JV for ged-emacs-devel@m.gmane.org; Mon, 25 Oct 2004 18:52:25 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.33) id 1CMDhH-0006Nw-BI for emacs-devel@gnu.org; Mon, 25 Oct 2004 18:52:15 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.33) id 1CMDhF-0006N4-Eu for emacs-devel@gnu.org; Mon, 25 Oct 2004 18:52:13 -0400 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.33) id 1CMDhE-0006N1-Vg for emacs-devel@gnu.org; Mon, 25 Oct 2004 18:52:13 -0400 Original-Received: from [213.165.64.20] (helo=mail.gmx.net) by monty-python.gnu.org with smtp (Exim 4.34) id 1CMDZ9-0001a6-Mb for emacs-devel@gnu.org; Mon, 25 Oct 2004 18:43:52 -0400 Original-Received: (qmail 9442 invoked by uid 65534); 25 Oct 2004 22:43:49 -0000 Original-Received: from p508433A6.dip0.t-ipconnect.de (EHLO www2.gmx.net) (80.132.51.166) by mail.gmx.net (mp006) with SMTP; 26 Oct 2004 00:43:49 +0200 X-Authenticated: #14602519 Original-Received: from oak.pohoyda.family (localhost [127.0.0.1]) by www2.gmx.net (8.12.10/8.12.10) with ESMTP id i9PMhmNn000862 for ; Tue, 26 Oct 2004 00:43:48 +0200 (CEST) (envelope-from alexander.pohoyda@gmx.net) Original-Received: (from apog@localhost) by oak.pohoyda.family (8.12.10/8.12.10/Submit) id i9PMhlxQ000859; Tue, 26 Oct 2004 00:43:47 +0200 (CEST) (envelope-from alexander.pohoyda@gmx.net) X-Authentication-Warning: oak.pohoyda.family: apog set sender to alexander.pohoyda@gmx.net using -f Original-To: emacs-devel@gnu.org In-Reply-To: Original-Lines: 234 User-Agent: Gnus/5.09 (Gnus v5.9.0) Emacs/21.3.50 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: main.gmane.org gmane.emacs.devel:28949 X-Report-Spam: http://spam.gmane.org/gmane.emacs.devel:28949 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)) ;;; ;;; 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))) ;;; ;;; 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 PGP Key fingerprint: 7F C9 CC 5A 75 CD 89 72 15 54 5F 62 20 23 C6 44