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.
+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.
* 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>
"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."
(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)
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
(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.
(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)
(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))
(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 ()
"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)
(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)))))
(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."
(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))))))))
(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)
(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)
(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)))))
(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.
(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))))
(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))
projects / emacs.git / commitdiff