mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-20 10:23:57 +00:00
203 lines
7.4 KiB
EmacsLisp
203 lines
7.4 KiB
EmacsLisp
;;; pmail-header.el --- Header handling code of "PMAIL" mail reader for Emacs
|
|
|
|
;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
|
|
;; Free Software Foundation, Inc.
|
|
|
|
;; Maintainer: FSF
|
|
;; Keywords: mail
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(eval-when-compile
|
|
(require 'mail-utils))
|
|
|
|
(defconst pmail-header-attribute-header "X-BABYL-V6-ATTRIBUTES"
|
|
"The header that stores the Pmail attribute data.")
|
|
|
|
(defconst pmail-header-keyword-header "X-BABYL-V6-KEYWORDS"
|
|
"The header that stores the Pmail keyword data.")
|
|
|
|
(defvar pmail-header-overlay-list nil
|
|
"List of cached overlays used to make headers hidden or visible.")
|
|
|
|
(defvar pmail-header-display-state nil
|
|
"Records the current header display state.
|
|
nil means headers are displayed, t indicates headers are not displayed.")
|
|
|
|
(defun pmail-header-get-limit ()
|
|
"Return the end of the headers.
|
|
The current buffer must show one message. If you want to narrow
|
|
to the headers of a mail by number, use `pmail-narrow-to-header'
|
|
instead."
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(if (search-forward "\n\n" nil t)
|
|
(1- (point))
|
|
(error "Invalid message format"))))
|
|
|
|
(defun pmail-header-add-header (header value)
|
|
"Add HEADER to the list of headers and associate VALUE with it.
|
|
The current buffer, possibly narrowed, contains a single message.
|
|
If VALUE is nil or the empty string, the header is removed
|
|
instead."
|
|
(save-excursion
|
|
(let* ((inhibit-read-only t)
|
|
(case-fold-search t)
|
|
(inhibit-point-motion-hooks t)
|
|
(buffer-undo-list t)
|
|
(limit (pmail-header-get-limit))
|
|
start end)
|
|
;; Search for the given header. If found, then set it's value.
|
|
;; If not then add the header to the end of the header section.
|
|
(goto-char (point-min))
|
|
(if (re-search-forward (format "^%s: " header) limit t)
|
|
(let ((start (match-beginning 0)))
|
|
(re-search-forward "\n[^ \t]")
|
|
(goto-char limit)
|
|
(delete-region start (1+ (match-beginning 0))))
|
|
(goto-char limit))
|
|
(when (> (length value) 0)
|
|
(insert header ": " value "\n")))))
|
|
|
|
(defun pmail-header-contains-keyword-p (keyword)
|
|
"Return t if KEYWORD exists in the current buffer, nil otherwise."
|
|
(let ((limit (pmail-header-get-limit)))
|
|
(goto-char (point-min))
|
|
(if (re-search-forward (format "^%s: " pmail-header-keyword-header) limit t)
|
|
;; Some keywords exist. Now search for the specific keyword.
|
|
(let ((start (point))
|
|
(end (progn (end-of-line) (point))))
|
|
(if (re-search-forward (concat "\\(" keyword ",\\|" keyword "$\\)"))
|
|
t)))))
|
|
|
|
(defun pmail-header-get-header (&rest args)
|
|
"Return the text value for a header or nil if no such header exists.
|
|
The arguments ARGS are passed to `mail-fetch-field'. The first
|
|
argument is the header to get.
|
|
|
|
The current buffer, possibly narrowed, contains a single message.
|
|
Note that it is not necessary to call `pmail-header-show-headers'
|
|
because `inhibit-point-motion-hooks' is locally bound to t."
|
|
(save-excursion
|
|
(save-restriction
|
|
(let* ((inhibit-point-motion-hooks t)
|
|
(limit (pmail-header-get-limit)))
|
|
(narrow-to-region (point-min) limit)
|
|
(apply 'mail-fetch-field args)))))
|
|
|
|
(defun pmail-header-get-keywords ()
|
|
"Return the keywords in the current message.
|
|
The current buffer, possibly narrowed, contains a single message."
|
|
;; Search for a keyword header and return the comma separated
|
|
;; strings as a list.
|
|
(let ((limit (pmail-header-get-limit)) result)
|
|
(goto-char (point-min))
|
|
(if (re-search-forward
|
|
(format "^%s: " pmail-header-keyword-header) limit t)
|
|
(save-excursion
|
|
(save-restriction
|
|
(narrow-to-region (point) (line-end-position))
|
|
(goto-char (point-min))
|
|
(mail-parse-comma-list))))))
|
|
|
|
(defun pmail-header-hide-headers ()
|
|
"Hide ignored headers. All others will be visible.
|
|
The current buffer, possibly narrowed, contains a single message."
|
|
(save-excursion
|
|
(pmail-header-show-headers)
|
|
(let ((overlay-list pmail-header-overlay-list)
|
|
(limit (pmail-header-get-limit))
|
|
(inhibit-point-motion-hooks t)
|
|
(case-fold-search t)
|
|
visibility-p)
|
|
;; Record the display state as having headers hidden.
|
|
(setq pmail-header-display-state t)
|
|
(if pmail-displayed-headers
|
|
;; Set the visibility predicate function to ignore headers
|
|
;; marked for display.
|
|
(setq visibility-p 'pmail-header-show-displayed-p)
|
|
;; Set the visibility predicate function to hide ignored
|
|
;; headers.
|
|
(setq visibility-p 'pmail-header-hide-ignored-p))
|
|
;; Walk through all the headers marking the non-displayed
|
|
;; headers as invisible.
|
|
(goto-char (point-min))
|
|
(while (re-search-forward "^[^ \t:]+[ :]" limit t)
|
|
;; Determine if the current header needs to be hidden.
|
|
(forward-line 0)
|
|
(if (not (funcall visibility-p))
|
|
;; It does not. Move point away from this header.
|
|
(progn
|
|
(forward-line 1)
|
|
(while (looking-at "[ \t]+")
|
|
(forward-line 1)))
|
|
;; It does. Make this header hidden by setting an overlay
|
|
;; with both the invisible and intangible properties set.
|
|
(let ((start (point)))
|
|
;; Move to end and pick upp any continuation lines on folded
|
|
;; headers.
|
|
(forward-line 1)
|
|
(while (looking-at "[ \t]+")
|
|
(forward-line 1))
|
|
(if (car overlay-list)
|
|
;; Use one of the cleared, cached overlays.
|
|
(let ((overlay (car overlay-list)))
|
|
(move-overlay overlay start (point))
|
|
(setq overlay-list (cdr overlay-list)))
|
|
;; No overlay exists for this header. Create one and
|
|
;; add it to the cache.
|
|
(let ((overlay (make-overlay start (point))))
|
|
(overlay-put overlay 'invisible t)
|
|
(overlay-put overlay 'intangible t)
|
|
(push overlay pmail-header-overlay-list)))))))))
|
|
|
|
(defun pmail-header-show-headers ()
|
|
"Show all headers.
|
|
The current buffer, possibly narrowed, contains a single message."
|
|
;; Remove all the overlays used to control hiding headers.
|
|
(mapc 'delete-overlay pmail-header-overlay-list)
|
|
(setq pmail-header-display-state nil))
|
|
|
|
(defun pmail-header-toggle-visibility (&optional arg)
|
|
"Toggle the visibility of the ignored headers if ARG is nil.
|
|
Hide the ignored headers if ARG is greater than 0, otherwise show the
|
|
ignored headers. The current buffer, possibly narrowed, contains a
|
|
single message."
|
|
(cond ((eq arg nil)
|
|
(if pmail-header-display-state
|
|
(pmail-header-show-headers)
|
|
(pmail-header-hide-headers)))
|
|
((or (eq arg t) (> arg 0))
|
|
(pmail-header-hide-headers))
|
|
(t (pmail-header-show-headers))))
|
|
|
|
(defun pmail-header-hide-ignored-p ()
|
|
"Test that the header is one of the headers marked to be ignored."
|
|
(looking-at pmail-ignored-headers))
|
|
|
|
(defun pmail-header-show-displayed-p ()
|
|
"Test that the header is not one of the headers marked for display."
|
|
(not (looking-at pmail-displayed-headers)))
|
|
|
|
(provide 'pmailhdr)
|
|
|
|
;; arch-tag: d708a0d9-2686-4958-b61a-7d3d2ace2131
|
|
;;; pmailhdr.el ends here
|