lisp/mail/pmailhdr.el

   1 ;;; pmail-header.el --- Header handling code of "PMAIL" mail reader for Emacs
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
   4 ;;   Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile
  29   (require 'mail-utils))
  30
  31 (defconst pmail-header-attribute-header "X-BABYL-V6-ATTRIBUTES"
  32   "The header that stores the Pmail attribute data.")
  33
  34 (defconst pmail-header-keyword-header "X-BABYL-V6-KEYWORDS"
  35   "The header that stores the Pmail keyword data.")
  36
  37 (defvar pmail-header-overlay-list nil
  38   "List of cached overlays used to make headers hidden or visible.")
  39
  40 (defvar pmail-header-display-state nil
  41   "Records the current header display state.
  42 nil means headers are displayed, t indicates headers are not displayed.")
  43
  44 (defun pmail-header-get-limit ()
  45   "Return the end of the headers.
  46 The current buffer must show one message.  If you want to narrow
  47 to the headers of a mail by number, use `pmail-narrow-to-header'
  48 instead."
  49   (save-excursion
  50     (goto-char (point-min))
  51     (if (search-forward "\n\n" nil t)
  52         (1- (point))
  53       (error "Invalid message format"))))
  54
  55 (defun pmail-header-add-header (header value)
  56   "Add HEADER to the list of headers and associate VALUE with it.
  57 The current buffer, possibly narrowed, contains a single message.
  58 If VALUE is nil or the empty string, the header is removed
  59 instead."
  60   (save-excursion
  61     (let* ((inhibit-read-only t)
  62            (case-fold-search t)
  63            (inhibit-point-motion-hooks t)
  64            (buffer-undo-list t)
  65            (limit (pmail-header-get-limit))
  66            start end)
  67       ;; Search for the given header.  If found, then set it's value.
  68       ;; If not then add the header to the end of the header section.
  69       (goto-char (point-min))
  70       (if (re-search-forward (format "^%s: " header) limit t)
  71           (let ((start (match-beginning 0)))
  72             (re-search-forward "\n[^ \t]")
  73             (goto-char limit)
  74             (delete-region start (1+ (match-beginning 0))))
  75         (goto-char limit))
  76       (when (> (length value) 0)
  77         (insert header ": " value "\n")))))
  78
  79 (defun pmail-header-contains-keyword-p (keyword)
  80   "Return t if KEYWORD exists in the current buffer, nil otherwise."
  81   (let ((limit (pmail-header-get-limit)))
  82     (goto-char (point-min))
  83     (if (re-search-forward (format "^%s: " pmail-header-keyword-header) limit t)
  84         ;; Some keywords exist.  Now search for the specific keyword.
  85         (let ((start (point))
  86               (end (progn (end-of-line) (point))))
  87           (if (re-search-forward (concat "\\(" keyword ",\\|" keyword "$\\)"))
  88               t)))))
  89
  90 (defun pmail-header-get-header (&rest args)
  91   "Return the text value for a header or nil if no such header exists.
  92 The arguments ARGS are passed to `mail-fetch-field'.  The first
  93 argument is the header to get.
  94
  95 The current buffer, possibly narrowed, contains a single message.
  96 Note that it is not necessary to call `pmail-header-show-headers'
  97 because `inhibit-point-motion-hooks' is locally bound to t."
  98   (save-excursion
  99     (save-restriction
 100       (let* ((inhibit-point-motion-hooks t)
 101              (limit (pmail-header-get-limit)))
 102         (narrow-to-region (point-min) limit)
 103         (apply 'mail-fetch-field args)))))
 104
 105 (defun pmail-header-get-keywords ()
 106   "Return the keywords in the current message.
 107 The current buffer, possibly narrowed, contains a single message."
 108   ;; Search for a keyword header and return the comma separated
 109   ;; strings as a list.
 110   (let ((limit (pmail-header-get-limit)) result)
 111     (goto-char (point-min))
 112     (if (re-search-forward
 113          (format "^%s: " pmail-header-keyword-header) limit t)
 114         (save-excursion
 115           (save-restriction
 116             (narrow-to-region (point) (line-end-position))
 117             (goto-char (point-min))
 118             (mail-parse-comma-list))))))
 119
 120 (defun pmail-header-hide-headers ()
 121   "Hide ignored headers.  All others will be visible.
 122 The current buffer, possibly narrowed, contains a single message."
 123   (save-excursion
 124     (pmail-header-show-headers)
 125     (let ((overlay-list pmail-header-overlay-list)
 126           (limit (pmail-header-get-limit))
 127           (inhibit-point-motion-hooks t)
 128           (case-fold-search t)
 129           visibility-p)
 130       ;; Record the display state as having headers hidden.
 131       (setq pmail-header-display-state t)
 132       (if pmail-displayed-headers
 133           ;; Set the visibility predicate function to ignore headers
 134           ;; marked for display.
 135           (setq visibility-p 'pmail-header-show-displayed-p)
 136         ;; Set the visibility predicate function to hide ignored
 137         ;; headers.
 138         (setq visibility-p 'pmail-header-hide-ignored-p))
 139       ;; Walk through all the headers marking the non-displayed
 140       ;; headers as invisible.
 141       (goto-char (point-min))
 142       (while (re-search-forward "^[^ \t:]+[ :]" limit t)
 143         ;; Determine if the current header needs to be hidden.
 144         (forward-line 0)
 145         (if (not (funcall visibility-p))
 146             ;; It does not.  Move point away from this header.
 147             (progn
 148               (forward-line 1)
 149               (while (looking-at "[ \t]+")
 150                 (forward-line 1)))
 151           ;; It does.  Make this header hidden by setting an overlay
 152           ;; with both the invisible and intangible properties set.
 153           (let ((start (point)))
 154             ;; Move to end and pick upp any continuation lines on folded
 155             ;; headers.
 156             (forward-line 1)
 157             (while (looking-at "[ \t]+")
 158               (forward-line 1))
 159             (if (car overlay-list)
 160                 ;; Use one of the cleared, cached overlays.
 161                 (let ((overlay (car overlay-list)))
 162                   (move-overlay overlay start (point))
 163                   (setq overlay-list (cdr overlay-list)))
 164               ;; No overlay exists for this header.  Create one and
 165               ;; add it to the cache.
 166               (let ((overlay (make-overlay start (point))))
 167                 (overlay-put overlay 'invisible t)
 168                 (overlay-put overlay 'intangible t)
 169                 (push overlay pmail-header-overlay-list)))))))))
 170
 171 (defun pmail-header-show-headers ()
 172   "Show all headers.
 173 The current buffer, possibly narrowed, contains a single message."
 174   ;; Remove all the overlays used to control hiding headers.
 175   (mapc 'delete-overlay pmail-header-overlay-list)
 176   (setq pmail-header-display-state nil))
 177
 178 (defun pmail-header-toggle-visibility (&optional arg)
 179   "Toggle the visibility of the ignored headers if ARG is nil.
 180 Hide the ignored headers if ARG is greater than 0, otherwise show the
 181 ignored headers.  The current buffer, possibly narrowed, contains a
 182 single message."
 183   (cond ((eq arg nil)
 184          (if pmail-header-display-state
 185              (pmail-header-show-headers)
 186            (pmail-header-hide-headers)))
 187         ((or (eq arg t) (> arg 0))
 188          (pmail-header-hide-headers))
 189         (t (pmail-header-show-headers))))
 190
 191 (defun pmail-header-hide-ignored-p ()
 192   "Test that the header is one of the headers marked to be ignored."
 193   (looking-at pmail-ignored-headers))
 194
 195 (defun pmail-header-show-displayed-p ()
 196   "Test that the header is not one of the headers marked for display."
 197   (not (looking-at pmail-displayed-headers)))
 198
 199 (provide 'pmailhdr)
 200
 201 ;; arch-tag: d708a0d9-2686-4958-b61a-7d3d2ace2131
 202 ;;; pmailhdr.el ends here