andros/emacs-gpu
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Revision: miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-291

Browse source 
Merge from gnus--rel--5.10

Patches applied:

 * gnus--rel--5.10  (patch 68)

   - Update from CVS

2005-04-28  Katsumi Yamaoka  <yamaoka@jpl.org>

   * lisp/gnus/gnus-art.el (article-date-ut): Support converting date in
   forwarded parts as well.
   (gnus-article-save-original-date): New macro.
   (gnus-display-mime): Use it.

2005-04-28  David Hansen  <david.hansen@physik.fu-berlin.de>

   * lisp/gnus/nnrss.el (nnrss-check-group, nnrss-request-article): Support the
   enclosure element of <item>.
This commit is contained in:
Miles Bader 2005-05-06 00:27:50 +00:00
parent 6c9fb58872
commit 31640842b6
3 changed files with 137 additions and 69 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
lisp/gnus/ChangeLog
View file

@ -1,3 +1,15 @@
2005-04-28 Katsumi Yamaoka <yamaoka@jpl.org>
* gnus-art.el (article-date-ut): Support converting date in
forwarded parts as well.
(gnus-article-save-original-date): New macro.
(gnus-display-mime): Use it.
2005-04-28 David Hansen <david.hansen@physik.fu-berlin.de>
* nnrss.el (nnrss-check-group, nnrss-request-article): Support the
enclosure element of <item>.
2005-04-24 Teodor Zlatanov <tzz@lifelogs.com>
* spam-report.el (spam-report-unplug-agent)
@ -18,7 +30,7 @@
Process requests from `spam-report-requests-file'.
(spam-report-url-ping-mm-url): Autoload.
[Added missing offline functionality from trunk.]
2005-04-18 Katsumi Yamaoka <yamaoka@jpl.org>
* qp.el (quoted-printable-encode-region): Save excursion.

140
lisp/gnus/gnus-art.el
View file

@ -2824,72 +2824,76 @@ lines forward."
(forward-line 1)
(setq ended t)))))
(defun article-date-ut (&optional type highlight header)
(defun article-date-ut (&optional type highlight)
"Convert DATE date to universal time in the current article.
If TYPE is `local', convert to local time; if it is `lapsed', output
how much time has lapsed since DATE. For `lapsed', the value of
`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
should replace the \"Date:\" one, or should be added below it."
(interactive (list 'ut t))
(let* ((header (or header
(message-fetch-field "date")
""))
(tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
(date-regexp
(cond
((not gnus-article-date-lapsed-new-header)
tdate-regexp)
((eq type 'lapsed)
"^X-Sent:[ \t]")
(t
"^Date:[ \t]")))
(date (if (vectorp header) (mail-header-date header)
header))
(let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
(date-regexp (cond ((not gnus-article-date-lapsed-new-header)
tdate-regexp)
((eq type 'lapsed)
"^X-Sent:[ \t]")
(article-lapsed-timer
"^Date:[ \t]")
(t
tdate-regexp)))
(case-fold-search t)
(inhibit-read-only t)
(inhibit-point-motion-hooks t)
pos
bface eface)
pos date bface eface)
(save-excursion
(save-restriction
(article-narrow-to-head)
(when (re-search-forward tdate-regexp nil t)
(setq bface (get-text-property (gnus-point-at-bol) 'face)
date (or (get-text-property (gnus-point-at-bol)
'original-date)
date)
eface (get-text-property (1- (gnus-point-at-eol)) 'face))
(forward-line 1))
(when (and date (not (string= date "")))
(widen)
(goto-char (point-min))
(while (or (setq date (get-text-property (setq pos (point))
'original-date))
(when (setq pos (next-single-property-change
(point) 'original-date))
(setq date (get-text-property pos 'original-date))
t))
(narrow-to-region pos (or (text-property-any pos (point-max)
'original-date nil)
(point-max)))
(goto-char (point-min))
(let ((inhibit-read-only t))
;; Delete any old Date headers.
(while (re-search-forward date-regexp nil t)
(if pos
(delete-region (progn (beginning-of-line) (point))
(progn (gnus-article-forward-header)
(point)))
(delete-region (progn (beginning-of-line) (point))
(progn (gnus-article-forward-header)
(forward-char -1)
(point)))
(setq pos (point))))
(when (and (not pos)
(re-search-forward tdate-regexp nil t))
(forward-line 1))
(when pos
(goto-char pos))
(insert (article-make-date-line date (or type 'ut)))
(unless pos
(insert "\n")
(forward-line -1))
;; Do highlighting.
(beginning-of-line)
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
(put-text-property (match-beginning 1) (1+ (match-end 1))
'original-date date)
(put-text-property (match-beginning 1) (1+ (match-end 1))
'face bface)
(put-text-property (match-beginning 2) (match-end 2)
'face eface))))))))
(when (re-search-forward tdate-regexp nil t)
(setq bface (get-text-property (gnus-point-at-bol) 'face)
eface (get-text-property (1- (gnus-point-at-eol)) 'face)))
(goto-char (point-min))
(setq pos nil)
;; Delete any old Date headers.
(while (re-search-forward date-regexp nil t)
(if pos
(delete-region (gnus-point-at-bol)
(progn
(gnus-article-forward-header)
(point)))
(delete-region (gnus-point-at-bol)
(progn
(gnus-article-forward-header)
(forward-char -1)
(point)))
(setq pos (point))))
(when (and (not pos)
(re-search-forward tdate-regexp nil t))
(forward-line 1))
(gnus-goto-char pos)
(insert (article-make-date-line date (or type 'ut)))
(unless pos
(insert "\n")
(forward-line -1))
;; Do highlighting.
(beginning-of-line)
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
(put-text-property (match-beginning 1) (1+ (match-end 1))
'face bface)
(put-text-property (match-beginning 2) (match-end 2)
'face eface))
(put-text-property (point-min) (1- (point-max)) 'original-date date)
(goto-char (point-max))
(widen))))))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
@ -3075,6 +3079,27 @@ This format is defined by the `gnus-article-time-format' variable."
(interactive (list t))
(article-date-ut 'iso8601 highlight))
(defmacro gnus-article-save-original-date (&rest forms)
"Save the original date as a text property and evaluate FORMS."
`(let* ((case-fold-search t)
(start (progn
(goto-char (point-min))
(when (and (re-search-forward "^date:[\t\n ]+" nil t)
(not (bolp)))
(match-end 0))))
(date (when (and start
(re-search-forward "[\t ]*\n\\([^\t ]\\|\\'\\)"
nil t))
(buffer-substring-no-properties start
(match-beginning 0)))))
(goto-char (point-max))
(skip-chars-backward "\n")
(put-text-property (point-min) (point) 'original-date date)
,@forms
(goto-char (point-max))
(skip-chars-backward "\n")
(put-text-property (point-min) (point) 'original-date date)))
;; (defun article-show-all ()
;; "Show all hidden text in the article buffer."
;; (interactive)
@ -4686,7 +4711,8 @@ N is the numerical prefix."
(save-restriction
(article-goto-body)
(narrow-to-region (point-min) (point))
(gnus-treat-article 'head))))))))
(gnus-article-save-original-date
(gnus-treat-article 'head)))))))))
(defcustom gnus-mime-display-multipart-as-mixed nil
"Display \"multipart\" parts as \"multipart/mixed\".

52
lisp/gnus/nnrss.el
View file

@ -195,6 +195,7 @@ for decoding when the cdr that the data specify is not available.")
(delete "" (split-string (nth 6 e) "\n+"))
" ")))
(link (nth 2 e))
(enclosure (nth 7 e))
;; Enable encoding of Newsgroups header in XEmacs.
(default-enable-multibyte-characters t)
(rfc2047-header-encoding-alist
@ -203,18 +204,21 @@ for decoding when the cdr that the data specify is not available.")
rfc2047-header-encoding-alist)
rfc2047-header-encoding-alist))
rfc2047-encode-encoded-words body)
(when (or text link)
(when (or text link enclosure)
(insert "\n")
(insert "<#multipart type=alternative>\n"
"<#part type=\"text/plain\">\n")
(setq body (point))
(if text
(progn
(insert text "\n")
(when link
(insert "\n" link "\n")))
(when link
(insert link "\n")))
(when text
(insert text "\n")
(when (or link enclosure)
(insert "\n")))
(when link
(insert link "\n"))
(when enclosure
(insert (car enclosure) " "
(nth 2 enclosure) " "
(nth 3 enclosure) "\n"))
(setq body (buffer-substring body (point)))
(insert "<#/part>\n"
"<#part type=\"text/html\">\n"
@ -223,6 +227,10 @@ for decoding when the cdr that the data specify is not available.")
(insert text "\n"))
(when link
(insert "<p><a href=\"" link "\">link</a></p>\n"))
(when enclosure
(insert "<p><a href=\"" (car enclosure) "\">"
(cadr enclosure) "</a> " (nth 2 enclosure)
" " (nth 3 enclosure) "</p>\n"))
(insert "</body></html>\n"
"<#/part>\n"
"<#/multipart>\n"))
@ -518,8 +526,8 @@ nnrss: %s: Not valid XML %s and w3-parse doesn't work %s"
;;; Snarf functions
(defun nnrss-check-group (group server)
(let (file xml subject url extra changed author
date rss-ns rdf-ns content-ns dc-ns)
(let (file xml subject url extra changed author date
enclosure rss-ns rdf-ns content-ns dc-ns)
(if (and nnrss-use-local
(file-exists-p (setq file (expand-file-name
(nnrss-translate-file-chars
@ -567,6 +575,27 @@ nnrss: %s: Not valid XML %s and w3-parse doesn't work %s"
(setq date (or (nnrss-node-text dc-ns 'date item)
(nnrss-node-text rss-ns 'pubDate item)
(message-make-date)))
(when (setq enclosure (cadr (assq (intern (concat rss-ns "enclosure")) item)))
(let ((url (cdr (assq 'url enclosure)))
(len (cdr (assq 'length enclosure)))
(type (cdr (assq 'type enclosure)))
(name))
(setq len
(if (and len (integerp (setq len (string-to-number len))))
;; actually already in `ls-lisp-format-file-size' but
;; probably not worth to require it for one function
(do ((size (/ len 1.0) (/ size 1024.0))
(post-fixes (list "" "k" "M" "G" "T" "P" "E")
(cdr post-fixes)))
((< size 1024)
(format "%.1f%s" size (car post-fixes))))
"0"))
(setq url (or url ""))
(setq name (if (string-match "/\\([^/]*\\)$" url)
(match-string 1 url)
"file"))
(setq type (or type ""))
(setq enclosure (list url name len type))))
(push
(list
(incf nnrss-group-max)
@ -575,7 +604,8 @@ nnrss: %s: Not valid XML %s and w3-parse doesn't work %s"
(and subject (nnrss-mime-encode-string subject))
(and author (nnrss-mime-encode-string author))
date
(and extra (nnrss-decode-entities-string extra)))
(and extra (nnrss-decode-entities-string extra))
enclosure)
nnrss-group-data)
(gnus-sethash (or url extra) t nnrss-group-hashtb)
(setq changed t))