1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
;;; pmail-header.el --- Header handling code of "PMAIL" mail reader for Emacs
;; Copyright (C) 2002, 2006 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 2, 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; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; 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.
(mapcar '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)
;;; pmailhdr.el ends here
|
