+2010-12-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus.texi (Paging the Article): Note the reverse meanings of `C-u C-u
+ g'.
+
2010-12-02 Julien Danjou <julien@danjou.info>
* gnus.texi (Archived Messages): Remove gnus-outgoing-message-group.
@findex gnus-summary-show-article
@vindex gnus-summary-show-article-charset-alist
(Re)fetch the current article (@code{gnus-summary-show-article}). If
-given a prefix, fetch the current article, but don't run any of the
-article treatment functions. If given a prefix twice (i.e., @kbd{C-u
-C-u g'}), show a completely ``raw'' article, just the way it came from
-the server.
+given a prefix, show a completely ``raw'' article, just the way it
+came from the server. If given a prefix twice (i.e., @kbd{C-u C-u
+g'}), fetch the current article, but don't run any of the article
+treatment functions.
@cindex charset, view article with different charset
If given a numerical prefix, you can do semi-manual charset stuff.
+2010-12-05 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-sum.el (gnus-summary-respool-article): The completion function
+ expects a list instead of an alist.
+
+ * nntp.el (nntp-snarf-error-message): nnheader-report takes a format
+ string as the parameter.
+
+ * gnus.el (gnus-valid-select-methods): Allow nnimap to respool.
+
+ * shr.el (shr-stylesheet): New dynamic variable for cascading the
+ styles.
+ (shr-colorize-region): New function.
+ (shr-insert-background-overlay): Remove.
+ (shr-render-td): Background setting should be taken care of on a higher
+ level.
+ (shr-tag-body): Use post-hoc colorizations.
+ (shr-tag-body): Set up a style sheet based on bgcolor/fgcolor.
+ (shr-put-color-1): Don't overwrite old colors.
+ (shr-colorize-region): When the background color isn't explicit, use
+ a fixed background.
+
+ * gnus-util.el (gnus-output-to-mail): Require nnmail before using
+ nnmail variables.
+
+2010-12-05 Bjørn Mork <bjorn@mork.no>
+
+ * nnimap.el (nnimap-process-expiry-targets): Avoid downloading articles
+ unless necessary.
+
+2010-12-05 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-run-gmane): Use more careful test for gmane nntp
+ server.
+
+2010-12-04 Lars Magne Ingebrigtsen <larsi@gnus.org>
+
+ * gnus-html.el (gnus-html-put-image): Use widget instead of local maps
+ so that TAB works.
+
+ * gnus-sum.el (gnus-summary-show-article): Reverse the meanings of `C-u
+ C-u g' and `C-u g' so that `C-u g' does what it traditionally did.
+
+ * shr.el (shr-urlify): Show the URL before the title to avoid
+ misleading URLs.
+
+2010-12-04 Adam Sjøgren <asjo@koldfront.dk>
+
+ * shr.el (shr-urlify): Display the title in <a> tags.
+
+2010-12-04 Andrew Cohen <cohen@andy.bu.edu>
+
+ * nnir.el (nnir-categorize): Replace mapcar with mapc.
+
2010-12-03 Andrew Cohen <cohen@andy.bu.edu>
* nnir.el: Rearrange code to allow macros to be autoloaded by
(gnus-html-display-image url start end
,alt-text))
'gnus-image (list url start end alt-text)))
- (gnus-overlay-put (gnus-make-overlay start end)
- 'local-map gnus-html-image-map)
+ (widget-convert-button
+ 'url-link start (point)
+ :help-echo alt-text
+ :keymap gnus-html-image-map
+ url)
(if (string-match "\\`cid:" url)
;; URLs with cid: have their content stashed in other
;; parts of the MIME structure, so just insert them
(let ((image (gnus-rescale-image image (gnus-html-maximum-image-size))))
(delete-region start end)
(gnus-put-image image alt-text 'external)
- (gnus-put-text-property start (point) 'help-echo alt-text)
- (gnus-overlay-put
- (gnus-make-overlay start (point)) 'local-map
- gnus-html-displayed-image-map)
+ (widget-convert-button
+ 'url-link start (point)
+ :help-echo alt-text
+ :keymap gnus-html-displayed-image-map
+ url)
(gnus-put-text-property start (point)
'gnus-alt-text alt-text)
(when url
(gnus-message 1 "Denied server %s" server)
nil)
;; Open the server.
- (let* ((open-server-function (gnus-get-function gnus-command-method 'open-server))
+ (let* ((open-server-function
+ (gnus-get-function gnus-command-method 'open-server))
(result
- (condition-case err
- (funcall open-server-function
- (nth 1 gnus-command-method)
- (nthcdr 2 gnus-command-method))
- (error
- (gnus-message 1 "Unable to open server %s due to: %s"
- server (error-message-string err))
- nil)
- (quit
- (gnus-message 1 "Quit trying to open server %s" server)
- nil)))
- open-offline)
+ (condition-case err
+ (funcall open-server-function
+ (nth 1 gnus-command-method)
+ (nthcdr 2 gnus-command-method))
+ (error
+ (gnus-message 1 "Unable to open server %s due to: %s"
+ server (error-message-string err))
+ nil)
+ (quit
+ (gnus-message 1 "Quit trying to open server %s" server)
+ nil)))
+ open-offline)
;; If this hasn't been opened before, we add it to the list.
(unless elem
(setq elem (list gnus-command-method nil)
((or (equal arg '(16))
(eq arg t))
;; C-u C-u g
+ (let ((gnus-inhibit-article-treatments t))
+ (gnus-summary-select-article nil 'force)))
+ (t
;; We have to require this here to make sure that the following
;; dynamic binding isn't shadowed by autoloading.
(require 'gnus-async)
;; Set it to nil for safety reason.
(setq gnus-article-mime-handle-alist nil)
(setq gnus-article-mime-handles nil)))
- (gnus-summary-select-article nil 'force)))
- (t
- (let ((gnus-inhibit-article-treatments t))
(gnus-summary-select-article nil 'force))))
(gnus-summary-goto-subject gnus-current-article)
(gnus-summary-position-point))
;;;!!!Why is this necessary?
(set-buffer gnus-summary-buffer)
-
+
(when (eq action 'move)
(save-excursion
(gnus-summary-goto-subject article)
latter case, they will be copied into the relevant groups."
(interactive
(list current-prefix-arg
- (let* ((methods (gnus-methods-using 'respool))
+ (let* ((methods (mapcar #'car (gnus-methods-using 'respool)))
(methname
(symbol-name (or gnus-summary-respool-default-method
(car (gnus-find-method-for-group
(defun gnus-write-buffer (file)
"Write the current buffer's contents to FILE."
+ (require 'nnmail)
(let ((file-name-coding-system nnmail-pathname-coding-system))
;; Make sure the directory exists.
(gnus-make-directory (file-name-directory file))
FILENAME exists and is Babyl format."
(require 'rmail)
(require 'mm-util)
+ (require 'nnmail)
;; Some of this codes is borrowed from rmailout.el.
(setq filename (expand-file-name filename))
;; FIXME should we really be messing with this defcustom?
(defun gnus-output-to-mail (filename &optional ask)
"Append the current article to a mail file named FILENAME."
+ (require 'nnmail)
(setq filename (expand-file-name filename))
(let ((artbuf (current-buffer))
(tmpbuf (get-buffer-create " *Gnus-output*")))
("nnweb" none)
("nnrss" none)
("nnagent" post-mail)
- ("nnimap" post-mail address prompt-address physical-address)
+ ("nnimap" post-mail address prompt-address physical-address respool)
("nnmaildir" mail respool address)
("nnnil" none))
"*An alist of valid select methods.
(defun nnimap-process-expiry-targets (articles group server)
(let ((deleted-articles nil))
- (dolist (article articles)
- (let ((target nnmail-expiry-target))
- (with-temp-buffer
- (mm-disable-multibyte)
- (when (nnimap-request-article article group server (current-buffer))
- (nnheader-message 7 "Expiring article %s:%d" group article)
- (when (functionp target)
- (setq target (funcall target group)))
- (when (and target
- (not (eq target 'delete)))
- (if (or (gnus-request-group target t)
- (gnus-request-create-group target))
- (nnmail-expiry-target-group target group)
- (setq target nil)))
- (when target
- (push article deleted-articles))))))
+ (cond
+ ;; shortcut further processing if we're going to delete the articles
+ ((eq nnmail-expiry-target 'delete)
+ (setq deleted-articles articles)
+ t)
+ ;; or just move them to another folder on the same IMAP server
+ ((and (not (functionp nnmail-expiry-target))
+ (gnus-server-equal (gnus-group-method nnmail-expiry-target)
+ (gnus-server-to-method
+ (format "nnimap:%s" server))))
+ (and (nnimap-possibly-change-group group server)
+ (with-current-buffer (nnimap-buffer)
+ (nnheader-message 7 "Expiring articles from %s: %s" group articles)
+ (nnimap-command
+ "UID COPY %s %S"
+ (nnimap-article-ranges (gnus-compress-sequence articles))
+ (utf7-encode (gnus-group-real-name nnmail-expiry-target) t))
+ (setq deleted-articles articles)))
+ t)
+ (t
+ (dolist (article articles)
+ (let ((target nnmail-expiry-target))
+ (with-temp-buffer
+ (mm-disable-multibyte)
+ (when (nnimap-request-article article group server (current-buffer))
+ (nnheader-message 7 "Expiring article %s:%d" group article)
+ (when (functionp target)
+ (setq target (funcall target group)))
+ (when (and target
+ (not (eq target 'delete)))
+ (if (or (gnus-request-group target t)
+ (gnus-request-create-group target))
+ (nnmail-expiry-target-group target group)
+ (setq target nil)))
+ (when target
+ (push article deleted-articles))))))))
;; Change back to the current group again.
(nnimap-possibly-change-group group server)
(setq deleted-articles (nreverse deleted-articles))
is `(valuefunc member)'."
`(unless (null ,sequence)
(let (value)
- (mapcar
+ (mapc
(lambda (member)
(let ((y (,keyfunc member))
(x ,(if valuefunc
;; gmane interface
(defun nnir-run-gmane (query srv &optional groups)
"Run a search against a gmane back-end server."
- (if (gnus-string-match-p "gmane.org$" srv)
+ (if (gnus-string-match-p
+ "gmane.org$"
+ (or (cadr (assoc 'nntp-address (cddr (gnus-server-to-method srv))))
+ ""))
(let* ((case-fold-search t)
(qstring (cdr (assq 'query query)))
(server (cadr (gnus-server-to-method srv)))
(cond ((looking-at "480")
(nntp-handle-authinfo process))
((looking-at "482")
- (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message))
+ (nnheader-report 'nntp "%s"
+ (get 'nntp-authinfo-rejected 'error-message))
(signal 'nntp-authinfo-rejected nil))
((looking-at "^.*\n")
(delete-region (point) (progn (forward-line 1) (point)))))
(let ((message (buffer-string)))
(while (string-match "[\r\n]+" message)
(setq message (replace-match " " t t message)))
- (nnheader-report 'nntp message)
+ (nnheader-report 'nntp "%s" message)
message))
(defun nntp-accept-process-output (process)
(defvar shr-content-cache nil)
(defvar shr-kinsoku-shorten nil)
(defvar shr-table-depth 0)
+(defvar shr-stylesheet nil)
(defvar shr-map
(let ((map (make-sparse-keymap)))
(defun shr-descend (dom)
(let ((function (intern (concat "shr-tag-" (symbol-name (car dom))) obarray))
(style (cdr (assq :style (cdr dom))))
+ (shr-stylesheet shr-stylesheet)
(start (point)))
(when (and style
(string-match "color" style))
- (setq style (shr-parse-style style)))
+ (setq shr-stylesheet (nconc (shr-parse-style style)
+ shr-stylesheet)))
(if (fboundp function)
(funcall function (cdr dom))
(shr-generic (cdr dom)))
- (when (consp style)
- (shr-insert-background-overlay (cdr (assq 'background-color style))
- start)
- (shr-insert-foreground-overlay (cdr (assq 'color style))
- start (point)))))
+ (let ((color (cdr (assq 'color shr-stylesheet)))
+ (background (cdr (assq 'background-color
+ shr-stylesheet))))
+ (when (and shr-stylesheet
+ (or color background))
+ (shr-colorize-region start (point) color background)))))
(defun shr-generic (cont)
(dolist (sub cont)
(autoload 'widget-convert-button "wid-edit")
-(defun shr-urlify (start url)
+(defun shr-urlify (start url &optional title)
(widget-convert-button
'url-link start (point)
- :help-echo url
+ :help-echo (if title (format "%s (%s)" url title) url)
:keymap shr-map
url)
(put-text-property start (point) 'shr-url url))
(t
(shr-color-visible bg fg)))))))
-(defun shr-get-background (pos)
- "Return background color at POS."
- (dolist (overlay (overlays-in pos (1+ pos)))
- (let ((background (plist-get (overlay-get overlay 'face)
- :background)))
- (when background
- (return background)))))
-
-(defun shr-insert-foreground-overlay (fg start end)
+(defun shr-colorize-region (start end fg &optional bg)
(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)))
+ (let ((new-colors (shr-color-check fg bg)))
(when new-colors
- (overlay-put (make-overlay start start nil nil t) 'face
- (list :background (car new-colors)))))))
+ (shr-put-color start end :foreground (cadr new-colors))
+ (when bg
+ (shr-put-color start end :background (car new-colors)))))))
+
+;; Put a color in the region, but avoid putting colors on on blank
+;; text at the start of the line, and the newline at the end, to avoid
+;; ugliness. Also, don't overwrite any existing color information,
+;; since this can be called recursively, and we want the "inner" color
+;; to win.
+(defun shr-put-color (start end type color)
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (when (bolp)
+ (skip-chars-forward " "))
+ (when (> (line-end-position) (point))
+ (shr-put-color-1 (point) (min (line-end-position) end) type color))
+ (if (< (line-end-position) end)
+ (forward-line 1)
+ (goto-char end)))))
+
+(defun shr-put-color-1 (start end type color)
+ (let* ((old-props (get-text-property start 'face))
+ (do-put (not (memq type old-props)))
+ change)
+ (while (< start end)
+ (setq change (next-single-property-change start 'face nil end))
+ (when do-put
+ (put-text-property start change 'face
+ (nconc (list type color) old-props)))
+ (setq old-props (get-text-property change 'face))
+ (setq do-put (not (memq type old-props)))
+ (setq start change))
+ (when (and do-put
+ (> end start))
+ (put-text-property start end 'face
+ (nconc (list type color old-props))))))
;;; 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)
+ (let* ((start (point))
+ (fgcolor (cdr (assq :fgcolor cont)))
+ (bgcolor (cdr (assq :bgcolor cont)))
+ (shr-stylesheet (list (cons :color fgcolor)
+ (cons :background-color bgcolor))))
(shr-generic cont)
- (shr-insert-foreground-overlay fgcolor start (point))))
+ (shr-colorize-region start (point) fgcolor bgcolor)))
(defun shr-tag-p (cont)
(shr-ensure-paragraph)
(defun shr-tag-a (cont)
(let ((url (cdr (assq :href cont)))
+ (title (cdr (assq :title cont)))
(start (point))
shr-start)
(shr-generic cont)
- (shr-urlify (or shr-start start) url)))
+ (shr-urlify (or shr-start start) url title)))
(defun shr-tag-object (cont)
(let ((start (point))
(let ((start (point))
(color (cdr (assq :color cont))))
(shr-generic cont)
- (shr-insert-foreground-overlay color start (point))))
+ (shr-colorize-region start (point) color)))
;;; Table rendering algorithm.
(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)
- (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)))))))
+ (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))))))
(defun shr-natural-width ()
(goto-char (point-min))
projects / emacs.git / commitdiff