Commit 144b7b5c authored by Gnus developers's avatar Gnus developers Committed by Katsumi Yamaoka

Merge changes made in Gnus trunk.

shr-color.el (shr-color-visible): Really return original background if fixed.
shr.el (shr-insert-color-overlay): Replace deprecated syntax.
shr.el (shr-tag-body, shr-descend): Add background support.
shr.el (shr-tag-title): Add.
gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes this function to return incorrect results.
shr.el (shr-parse-style): Drop !important from styles.
message.el (message-goto-body): Remove the <#secure special-casing, which is too special.
mm-util.el (mm-enable-multibyte): Use `to' instead of t.  This fixes something or other in Emacs 23, and is backwards compatible.
message.el (message-goto-body): Use called-interactively-p.
message.el (message-in-body-p): message-goto-body returns point.
nnimap.el (nnimap-request-move-article): It's no longer necessary to clear marks before moving, since they're synced from the Gnus side first.
gnus-sum.el (gnus-summary-push-marks-to-backend): New function.
gnus-sum.el (gnus-summary-move-article): Copy over all marks before moving, so that IMAP doesn't think a new article has arrived.
message.el (message-goto-body): called-interactively-p needs a parameter, so use `any'.
gnus-cache.el (gnus-summary-insert-cached-articles): Use it.
gnus-sum.el (gnus-summary-include-articles): New function.
shr.el (shr-tag-table, shr-render-td): Add bgcolor support.
shr-color.el (shr-color-visible): Fix docstring.
shr.el (shr-insert-background-overlay): Fix typo.
shr.el (shr-render-td): Copy the background before rendering.
parent 872ab164
2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
* gnus-cache.el (gnus-summary-insert-cached-articles): Use it.
* gnus-sum.el (gnus-summary-include-articles): New function.
* message.el (message-goto-body): called-interactively-p needs a
parameter, so use `any'.
* nnimap.el (nnimap-request-move-article): It's no longer necessary to
clear marks before moving, since they're synced from the Gnus side
first.
* gnus-sum.el (gnus-summary-push-marks-to-backend): New function.
(gnus-summary-move-article): Copy over all marks before moving, so that
IMAP doesn't think a new article has arrived.
2010-11-24 Julien Danjou <julien@danjou.info>
* shr.el (shr-insert-background-overlay): Fix typo.
(shr-render-td): Copy the background before rendering.
* shr-color.el (shr-color-visible): Fix docstring.
* shr.el (shr-tag-table): Add bgcolor support.
(shr-render-td): Add bgcolor support.
(shr-get-background): Add.
(shr-insert-foreground-overlay): Use shr-get-background.
* message.el (message-goto-body): Use called-interactively-p.
(message-in-body-p): message-goto-body returns point.
2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
* mm-util.el (mm-enable-multibyte): Use `to' instead of t. This fixes
Fixes something or other in Emacs 23, and is backwards compatible.
* message.el (message-goto-body): Remove the <#secure special-casing,
which is too special.
* shr.el (shr-parse-style): Drop !important from styles.
2010-11-24 Daniel Schoepe <daniel.schoepe@googlemail.com> (tiny change)
* gnus-sum.el (gnus-summary-articles-in-thread): Fix a bug that causes
this function to return incorrect results when calling it with an
explicit article argument different from
(gnus-summary-article-number).
2010-11-24 Julien Danjou <julien@danjou.info>
* shr.el (shr-insert-color-overlay): Replace deprecated syntax.
(shr-tag-body): Add background support.
(shr-descend): Add background support.
(shr-tag-title): Add.
* shr-color.el (shr-color-visible): Really return original background
if fixed.
2010-11-24 Lars Magne Ingebrigtsen <larsi@gnus.org>
* shr.el (shr-color-check): Protect against non-existant colour names.
......@@ -46,7 +105,8 @@
* shr.el (shr-parse-style): Replace \n with space in style parsing.
* shr-color.el (shr-color-hsl-to-rgb-fractions): Use shr-color-hue-to-rgb.
* shr-color.el (shr-color-hsl-to-rgb-fractions): Use
shr-color-hue-to-rgb.
(shr-color->hexadecimal): Call shr-color-hsl-to-rgb-fractions.
2010-11-23 Lars Magne Ingebrigtsen <larsi@gnus.org>
......
......@@ -383,9 +383,14 @@ Returns the list of articles removed."
"Insert all the articles cached for this group into the current buffer."
(interactive)
(let ((gnus-verbose (max 6 gnus-verbose)))
(if (not gnus-newsgroup-cached)
(gnus-message 3 "No cached articles for this group")
(gnus-summary-goto-subjects gnus-newsgroup-cached))))
(cond
((not gnus-newsgroup-cached)
(gnus-message 3 "No cached articles for this group"))
;; This is faster if there are few articles to insert.
((< (length gnus-newsgroup-cached) 20)
(gnus-summary-goto-subjects gnus-newsgroup-cached))
(t
(gnus-summary-include-articles gnus-newsgroup-cached)))))
(defun gnus-summary-limit-include-cached ()
"Limit the summary buffer to articles that are cached."
......
......@@ -8500,6 +8500,18 @@ fetched for this group."
(gnus-summary-limit (append gnus-newsgroup-dormant gnus-newsgroup-limit))
(gnus-summary-position-point)))
(defun gnus-summary-include-articles (articles)
"Fetch the headers for ARTICLES and then display the summary lines."
(let ((gnus-inhibit-demon t)
(gnus-agent nil)
(gnus-read-all-available-headers t))
(setq gnus-newsgroup-headers
(gnus-merge
'list gnus-newsgroup-headers
(gnus-fetch-headers articles nil t)
'gnus-article-sort-by-number))
(gnus-summary-limit (append articles gnus-newsgroup-limit))))
(defun gnus-summary-limit-exclude-dormant ()
"Hide all dormant articles."
(interactive)
......@@ -9705,6 +9717,9 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
articles)
(while articles
(setq article (pop articles))
;; Set any marks that may have changed in the summary buffer.
(when gnus-preserve-marks
(gnus-summary-push-marks-to-backend article))
(let ((gnus-newsgroup-original-name gnus-newsgroup-name)
(gnus-article-original-subject
(mail-header-subject
......@@ -9921,6 +9936,25 @@ ACTION can be either `move' (the default), `crosspost' or `copy'."
(gnus-summary-position-point)
(gnus-set-mode-line 'summary)))
(defun gnus-summary-push-marks-to-backend (article)
(let ((add nil)
(delete nil)
(marks gnus-article-mark-lists))
(if (memq article gnus-newsgroup-unreads)
(push 'read add)
(push 'read delete))
(while marks
(when (eq (gnus-article-mark-to-type (cdar marks)) 'list)
(if (memq article (symbol-value
(intern (format "gnus-newsgroup-%s"
(caar marks)))))
(push (cdar marks) add)
(push (cdar marks) delete)))
(pop marks))
(gnus-request-set-mark gnus-newsgroup-name
`(((,article) add ,add)
((,article) del ,delete)))))
(defun gnus-summary-copy-article (&optional n to-newsgroup select-method)
"Copy the current article to some other group.
If TO-NEWSGROUP is string, do not prompt for a newsgroup to copy to.
......@@ -11232,6 +11266,7 @@ with that article."
(mail-header-subject (gnus-data-header (car data)))))
(t nil)))
(end-point (save-excursion
(goto-char (gnus-data-pos (car data)))
(if (gnus-summary-go-to-next-thread)
(point) (point-max))))
articles)
......
......@@ -3047,10 +3047,10 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(interactive)
(message-position-on-field "Summary" "Subject"))
(defun message-goto-body (&optional interactivep)
(defun message-goto-body ()
"Move point to the beginning of the message body."
(interactive (list t))
(when (and interactivep
(interactive)
(when (and (called-interactively-p 'any)
(looking-at "[ \t]*\n"))
(expand-abbrev))
(goto-char (point-min))
......@@ -3059,7 +3059,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)."
(defun message-in-body-p ()
"Return t if point is in the message body."
(let ((body (save-excursion (message-goto-body) (point))))
(let ((body (save-excursion (message-goto-body))))
(>= (point) body)))
(defun message-goto-eoh ()
......
......@@ -903,7 +903,7 @@ mail with multiple parts is preferred to sending a Unicode one.")
"Set the multibyte flag of the current buffer.
Only do this if the default value of `enable-multibyte-characters' is
non-nil. This is a no-op in XEmacs."
(set-buffer-multibyte t)))
(set-buffer-multibyte 'to)))
(if (featurep 'xemacs)
(defalias 'mm-disable-multibyte 'ignore)
......
......@@ -783,9 +783,6 @@ textual parts.")
(if internal-move-group
(let ((result
(with-current-buffer (nnimap-buffer)
;; Clear all flags before moving.
(nnimap-send-command "UID STORE %d FLAGS.SILENT ()"
article)
(nnimap-command "UID COPY %d %S"
article
(utf7-encode internal-move-group t)))))
......
......@@ -318,8 +318,8 @@ If FIXED is t, then val1 will not be touched."
(defun shr-color-visible (bg fg &optional fixed-background)
"Check that BG and FG colors are visible if they are drawn on each other.
Return t if they are. If they are too similar, two new colors are
returned instead.
Return (bg fg) if they are. If they are too similar, two new
colors are returned instead.
If FIXED-BACKGROUND is set, and if the color are not visible, a
new background color will not be computed. Only the foreground
color will be adapted to be visible on BG."
......@@ -337,11 +337,14 @@ color will be adapted to be visible on BG."
(let ((Ls (set-minimum-interval (car bg-lab) (car fg-lab) 0 100
shr-color-visible-luminance-min
fixed-background)))
(setcar bg-lab (car Ls))
(unless fixed-background
(setcar bg-lab (car Ls)))
(setcar fg-lab (cadr Ls))
(list
(apply 'format "#%02x%02x%02x"
(mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab)))
(if fixed-background
bg
(apply 'format "#%02x%02x%02x"
(mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb bg-lab))))
(apply 'format "#%02x%02x%02x"
(mapcar (lambda (x) (* (max (min 1 x) 0) 255)) (apply 'lab->rgb fg-lab))))))))
......
......@@ -201,7 +201,10 @@ redirects somewhere else."
(funcall function (cdr dom))
(shr-generic (cdr dom)))
(when (consp style)
(shr-insert-color-overlay (cdr (assq 'color style)) start (point)))))
(shr-insert-background-overlay (cdr (assq 'background-color style))
start)
(shr-insert-foreground-overlay (cdr (assq 'color style))
start (point)))))
(defun shr-generic (cont)
(dolist (sub cont)
......@@ -494,23 +497,65 @@ START, and END."
(autoload 'shr-color-visible "shr-color")
(autoload 'shr-color->hexadecimal "shr-color")
(defun shr-color-check (fg &optional bg)
"Check that FG is visible on BG."
(let ((hex-color (shr-color->hexadecimal fg)))
(when hex-color
(shr-color-visible (or (shr-color->hexadecimal bg)
(frame-parameter nil 'background-color))
hex-color (not bg)))))
(defun shr-insert-color-overlay (color start end)
(when color
(let ((new-color (cadr (shr-color-check color))))
(when new-color
(overlay-put (make-overlay start end) 'face
(cons 'foreground-color new-color))))))
(defun shr-color-check (fg bg)
"Check that FG is visible on BG.
Returns (fg bg) with corrected values.
Returns nil if the colors that would be used are the default
ones, in case fg and bg are nil."
(when (or fg bg)
(let ((fixed (cond ((null fg) 'fg)
((null bg) 'bg))))
;; Convert colors to hexadecimal, or set them to default.
(let ((fg (or (shr-color->hexadecimal fg)
(frame-parameter nil 'foreground-color)))
(bg (or (shr-color->hexadecimal bg)
(frame-parameter nil 'background-color))))
(cond ((eq fixed 'bg)
;; Only return the new fg
(list nil (cadr (shr-color-visible bg fg t))))
((eq fixed 'fg)
;; Invert args and results and return only the new bg
(list (cadr (shr-color-visible fg bg t)) nil))
(t
(shr-color-visible bg fg)))))))
(defun shr-get-background (pos)
"Return background color at POS."
(dolist (overlay (overlays-in start (1+ start)))
(let ((background (plist-get (overlay-get overlay 'face)
:background)))
(when background
(return background)))))
(defun shr-insert-foreground-overlay (fg start end)
(when fg
(let ((bg (shr-get-background start)))
(let ((new-colors (shr-color-check fg bg)))
(when new-colors
(overlay-put (make-overlay start end) 'face
(list :foreground (cadr new-colors))))))))
(defun shr-insert-background-overlay (bg start)
"Insert an overlay with background color BG at START.
The overlay has rear-advance set to t, so it will be used when
text will be inserted at start."
(when bg
(let ((new-colors (shr-color-check nil bg)))
(when new-colors
(overlay-put (make-overlay start start nil nil t) 'face
(list :background (car new-colors)))))))
;;; Tag-specific rendering rules.
(defun shr-tag-body (cont)
(let ((start (point))
(fgcolor (cdr (assq :fgcolor cont)))
(bgcolor (cdr (assq :bgcolor cont))))
(shr-insert-background-overlay bgcolor start)
(shr-generic cont)
(shr-insert-foreground-overlay fgcolor start (point))))
(defun shr-tag-p (cont)
(shr-ensure-paragraph)
(shr-indent)
......@@ -554,6 +599,8 @@ START, and END."
(cadr elem))
(let ((name (replace-regexp-in-string "^ +\\| +$" "" (car elem)))
(value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem))))
(when (string-match " *!important\\'" value)
(setq value (substring value 0 (match-beginning 0))))
(push (cons (intern name obarray)
value)
plist)))))
......@@ -703,11 +750,14 @@ START, and END."
(shr-ensure-newline)
(insert (make-string shr-width shr-hr-line) "\n"))
(defun shr-tag-title (cont)
(shr-heading cont 'bold 'underline))
(defun shr-tag-font (cont)
(let ((start (point))
(color (cdr (assq :color cont))))
(shr-generic cont)
(shr-insert-color-overlay color start (point))))
(shr-insert-foreground-overlay color start (point))))
;;; Table rendering algorithm.
......@@ -755,9 +805,11 @@ START, and END."
(header (cdr (assq 'thead cont)))
(body (or (cdr (assq 'tbody cont)) cont))
(footer (cdr (assq 'tfoot cont)))
(bgcolor (cdr (assq :bgcolor cont)))
(nheader (if header (shr-max-columns header)))
(nbody (if body (shr-max-columns body)))
(nfooter (if footer (shr-max-columns footer))))
(shr-insert-background-overlay bgcolor (point))
(shr-tag-table-1
(nconc
(if caption `((tr (td ,@caption))))
......@@ -900,44 +952,48 @@ START, and END."
(nreverse trs)))
(defun shr-render-td (cont width fill)
(with-temp-buffer
(let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
(if cache
(insert cache)
(let ((shr-width width)
(shr-indentation 0))
(shr-generic cont))
(delete-region
(point)
(+ (point)
(skip-chars-backward " \t\n")))
(push (cons (cons width cont) (buffer-string))
shr-content-cache)))
(goto-char (point-min))
(let ((max 0))
(while (not (eobp))
(end-of-line)
(setq max (max max (current-column)))
(forward-line 1))
(when fill
(goto-char (point-min))
;; If the buffer is totally empty, then put a single blank
;; line here.
(if (zerop (buffer-size))
(insert (make-string width ? ))
;; Otherwise, fill the buffer.
(while (not (eobp))
(end-of-line)
(when (> (- width (current-column)) 0)
(insert (make-string (- width (current-column)) ? )))
(forward-line 1))))
(if fill
(list max
(count-lines (point-min) (point-max))
(split-string (buffer-string) "\n")
(shr-collect-overlays))
(list max
(shr-natural-width))))))
(let ((background (shr-get-background (point))))
(with-temp-buffer
(let ((cache (cdr (assoc (cons width cont) shr-content-cache))))
(if cache
(insert cache)
(shr-insert-background-overlay (or (cdr (assq :bgcolor cont))
background)
(point))
(let ((shr-width width)
(shr-indentation 0))
(shr-generic cont))
(delete-region
(point)
(+ (point)
(skip-chars-backward " \t\n")))
(push (cons (cons width cont) (buffer-string))
shr-content-cache)))
(goto-char (point-min))
(let ((max 0))
(while (not (eobp))
(end-of-line)
(setq max (max max (current-column)))
(forward-line 1))
(when fill
(goto-char (point-min))
;; If the buffer is totally empty, then put a single blank
;; line here.
(if (zerop (buffer-size))
(insert (make-string width ? ))
;; Otherwise, fill the buffer.
(while (not (eobp))
(end-of-line)
(when (> (- width (current-column)) 0)
(insert (make-string (- width (current-column)) ? )))
(forward-line 1))))
(if fill
(list max
(count-lines (point-min) (point-max))
(split-string (buffer-string) "\n")
(shr-collect-overlays))
(list max
(shr-natural-width)))))))
(defun shr-natural-width ()
(goto-char (point-min))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment