;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2011 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;;; Code:
-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.
(eval-and-compile
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
:group 'gnus-article-various)
(make-obsolete-variable 'gnus-article-hide-pgp-hook nil
- "Gnus 5.10 (Emacs-22.1)")
+ "Gnus 5.10 (Emacs 22.1)")
(defface gnus-button
'((t (:weight bold)))
"Function used to decode addresses.")
(defvar gnus-article-dumbquotes-map
- '(("\200" "EUR")
- ("\202" ",")
- ("\203" "f")
- ("\204" ",,")
- ("\205" "...")
- ("\213" "<")
- ("\214" "OE")
- ("\221" "`")
- ("\222" "'")
- ("\223" "``")
- ("\224" "\"")
- ("\225" "*")
- ("\226" "-")
- ("\227" "--")
- ("\230" "~")
- ("\231" "(TM)")
- ("\233" ">")
- ("\234" "oe")
- ("\264" "'"))
+ '((?\200 "EUR")
+ (?\202 ",")
+ (?\203 "f")
+ (?\204 ",,")
+ (?\205 "...")
+ (?\213 "<")
+ (?\214 "OE")
+ (?\221 "`")
+ (?\222 "'")
+ (?\223 "``")
+ (?\224 "\"")
+ (?\225 "*")
+ (?\226 "-")
+ (?\227 "--")
+ (?\230 "~")
+ (?\231 "(TM)")
+ (?\233 ">")
+ (?\234 "oe")
+ (?\264 "'"))
"Table for MS-to-Latin1 translation.")
(defcustom gnus-ignored-mime-types nil
:group 'gnus-article-headers
:type 'boolean)
+(defcustom gnus-article-update-lapsed-header 1
+ "How often to update the lapsed date header.
+If nil, don't update it at all."
+ :version "24.1"
+ :group 'gnus-article-headers
+ :type '(choice
+ (item :tag "Don't update" :value nil)
+ integer))
+
(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
"Function called with a MIME handle as the argument.
This is meant for people who want to view first matched part.
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
+(defcustom gnus-treat-date-combined-lapsed 'head
+ "Display the Date header in a way that says how much time has elapsed.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-head-custom)
+
(defcustom gnus-treat-date-original nil
"Display the date in the original timezone.
Valid values are nil, t, `head', `first', `last', an integer or a
:type gnus-article-treat-custom)
(make-obsolete-variable 'gnus-treat-display-xface
- 'gnus-treat-display-x-face "22.1")
+ 'gnus-treat-display-x-face "Emacs 22.1")
(defcustom gnus-treat-display-x-face
(and (not noninteractive)
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(defcustom gnus-treat-fill-long-lines nil
+(defcustom gnus-treat-fill-long-lines '(typep "text/plain")
"Fill long lines.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles'."
+ :version "24.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
:type 'string
:group 'mime-security)
-(defvar gnus-article-wash-function nil
- "Function used for converting HTML into text.")
-
(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
(mm-coding-system-p 'utf-8)
(executable-find idna-program))
:group 'gnus-article
:type 'boolean)
+(defcustom gnus-inhibit-images nil
+ "Non-nil means inhibit displaying of images inline in the article body."
+ :version "24.1"
+ :group 'gnus-article
+ :type 'boolean)
+
+(defcustom gnus-blocked-images 'gnus-block-private-groups
+ "Images that have URLs matching this regexp will be blocked.
+This can also be a function to be evaluated. If so, it will be
+called with the group name as the parameter, and should return a
+regexp."
+ :version "24.1"
+ :group 'gnus-art
+ :type 'regexp)
+
;;; Internal variables
(defvar gnus-english-month-names
(gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-buttonize gnus-article-add-buttons)
(gnus-treat-fill-article gnus-article-fill-cited-article)
- (gnus-treat-fill-long-lines gnus-article-fill-long-lines)
+ (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
(gnus-treat-unsplit-urls gnus-article-unsplit-urls)
(gnus-treat-date-ut gnus-article-date-ut)
(gnus-treat-date-user-defined gnus-article-date-user)
(gnus-treat-date-iso8601 gnus-article-date-iso8601)
(gnus-treat-date-lapsed gnus-article-date-lapsed)
+ (gnus-treat-date-combined-lapsed gnus-article-date-combined-lapsed)
(gnus-treat-display-x-face gnus-article-display-x-face)
(gnus-treat-display-face gnus-article-display-face)
(gnus-treat-hide-headers gnus-article-maybe-hide-headers)
(interactive)
(article-translate-strings gnus-article-dumbquotes-map))
+(defvar org-entities)
+
+(defun article-treat-non-ascii ()
+ "Translate many Unicode characters into their ASCII equivalents."
+ (interactive)
+ (require 'org-entities)
+ (let ((table (make-char-table (if (featurep 'xemacs) 'generic))))
+ (dolist (elem org-entities)
+ (when (and (listp elem)
+ (= (length (nth 6 elem)) 1))
+ (if (featurep 'xemacs)
+ (put-char-table (aref (nth 6 elem) 0) (nth 4 elem) table)
+ (set-char-table-range table (aref (nth 6 elem) 0) (nth 4 elem)))))
+ (save-excursion
+ (when (article-goto-body)
+ (let ((inhibit-read-only t)
+ replace props)
+ (while (not (eobp))
+ (if (not (setq replace (if (featurep 'xemacs)
+ (get-char-table (following-char) table)
+ (aref table (following-char)))))
+ (forward-char 1)
+ (if (prog1
+ (setq props (text-properties-at (point)))
+ (delete-char 1))
+ (add-text-properties (point) (progn (insert replace) (point))
+ props)
+ (insert replace)))))))))
+
(defun article-translate-characters (from to)
"Translate all characters in the body of the article according to FROM and TO.
FROM is a string of characters to translate from; to is a string of
(when (article-goto-body)
(let ((inhibit-read-only t))
(dolist (elem map)
- (save-excursion
- (while (search-forward (car elem) nil t)
- (replace-match (cadr elem)))))))))
+ (let ((from (car elem))
+ (to (cadr elem)))
+ (save-excursion
+ (if (stringp from)
+ (while (search-forward from nil t)
+ (replace-match to))
+ (while (not (eobp))
+ (if (eq (following-char) from)
+ (progn
+ (delete-char 1)
+ (insert to))
+ (forward-char 1)))))))))))
(defun article-treat-overstrike ()
"Translate overstrikes into bold text."
"Remove all images from the article buffer."
(interactive)
(gnus-with-article-buffer
- (dolist (elem gnus-article-image-alist)
- (gnus-delete-images (car elem)))))
+ (save-restriction
+ (widen)
+ (dolist (elem gnus-article-image-alist)
+ (gnus-delete-images (car elem))))))
+
+(defun gnus-article-show-images ()
+ "Show any images that are in the HTML-rendered article buffer.
+This only works if the article in question is HTML."
+ (interactive)
+ (gnus-with-article-buffer
+ (save-restriction
+ (widen)
+ (dolist (region (gnus-find-text-property-region (point-min) (point-max)
+ 'image-displayer))
+ (destructuring-bind (start end function) region
+ (funcall function (get-text-property start 'image-url)
+ start end))))))
(defun gnus-article-treat-fold-newsgroups ()
"Unfold folded message headers.
(when (interactive-p)
(gnus-treat-article nil))))
-
-(defun article-wash-html (&optional read-charset)
- "Format an HTML article.
-If READ-CHARSET, ask for a coding system. If it is a number, the
-charset defined in `gnus-summary-show-article-charset-alist' is used."
- (interactive "P")
- (save-excursion
- (let ((inhibit-read-only t)
- charset)
- (if read-charset
- (if (or (and (numberp read-charset)
- (setq charset
- (cdr
- (assq read-charset
- gnus-summary-show-article-charset-alist))))
- (setq charset (mm-read-coding-system "Charset: ")))
- (let ((gnus-summary-show-article-charset-alist
- (list (cons 1 charset))))
- (with-current-buffer gnus-summary-buffer
- (gnus-summary-show-article 1)))
- (error "No charset is given"))
- (when (gnus-buffer-live-p gnus-original-article-buffer)
- (with-current-buffer gnus-original-article-buffer
- (let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct (mail-header-parse-content-type ct))))
- (setq charset (and ctl
- (mail-content-type-get ctl 'charset)))
- (when (stringp charset)
- (setq charset (intern (downcase charset)))))))
- (unless charset
- (setq charset gnus-newsgroup-charset)))
- (article-goto-body)
- (save-window-excursion
- (save-restriction
- (narrow-to-region (point) (point-max))
- (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
- (entry (assq func mm-text-html-washer-alist)))
- (when entry
- (setq func (cdr entry)))
- (cond
- ((functionp func)
- (funcall func))
- (t
- (apply (car func) (cdr func))))))))))
-
-;; External.
-(declare-function w3-region "ext:w3-display" (st nd))
-
-(defun gnus-article-wash-html-with-w3 ()
- "Wash the current buffer with w3."
- (mm-setup-w3)
- (let ((w3-strict-width (window-width))
- (url-standalone-mode t)
- (url-gateway-unplugged t)
- (w3-honor-stylesheets nil))
- (condition-case ()
- (w3-region (point-min) (point-max))
- (error))))
-
-;; External.
-(declare-function w3m-region "ext:w3m" (start end &optional url charset))
-
-(defun gnus-article-wash-html-with-w3m ()
- "Wash the current buffer with emacs-w3m."
- (mm-setup-w3m)
- (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
- w3m-force-redisplay)
- (w3m-region (point-min) (point-max)))
- ;; Put the mark meaning this part was rendered by emacs-w3m.
- (put-text-property (point-min) (point-max) 'mm-inline-text-html-with-w3m t)
- (when (and mm-inline-text-html-with-w3m-keymap
- (boundp 'w3m-minor-mode-map)
- w3m-minor-mode-map)
- (if (and (boundp 'w3m-link-map)
- w3m-link-map)
- (let* ((start (point-min))
- (end (point-max))
- (on (get-text-property start 'w3m-href-anchor))
- (map (copy-keymap w3m-link-map))
- next)
- (set-keymap-parent map w3m-minor-mode-map)
- (while (< start end)
- (if on
- (progn
- (setq next (or (text-property-any start end
- 'w3m-href-anchor nil)
- end))
- (put-text-property start next 'keymap map))
- (setq next (or (text-property-not-all start end
- 'w3m-href-anchor nil)
- end))
- (put-text-property start next 'keymap w3m-minor-mode-map))
- (setq start next
- on (not on))))
- (put-text-property (point-min) (point-max) 'keymap w3m-minor-mode-map))))
-
-(defvar charset) ;; Bound by `article-wash-html'.
-
-(defun gnus-article-wash-html-with-w3m-standalone ()
- "Wash the current buffer with w3m."
- (if (mm-w3m-standalone-supports-m17n-p)
- (progn
- (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'.
- ;; The default.
- (setq charset 'iso-8859-1))
- (let ((coding-system-for-write charset)
- (coding-system-for-read charset))
- (call-process-region
- (point-min) (point-max)
- "w3m" t t nil "-dump" "-T" "text/html"
- "-I" (symbol-name charset) "-O" (symbol-name charset))))
- (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html")))
+(defun article-wash-html ()
+ "Format an HTML article."
+ (interactive)
+ (let ((handles nil)
+ (buffer-read-only nil))
+ (when (gnus-buffer-live-p gnus-original-article-buffer)
+ (setq handles (mm-dissect-buffer t t)))
+ (article-goto-body)
+ (delete-region (point) (point-max))
+ (mm-inline-text-html handles)))
(defvar gnus-article-browse-html-temp-list nil
"List of temporary files created by `gnus-article-browse-html-parts'.
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
- (unless (memq type '(local ut original user iso8601 lapsed english))
+ (unless (memq type '(local ut original user iso8601 lapsed english
+ combined-lapsed))
(error "Unknown conversion type: %s" type))
(condition-case ()
(let ((time (date-to-time date)))
(/ (% (abs tz) 3600) 60)))))
;; Do an X-Sent lapsed format.
((eq type 'lapsed)
- ;; If the date is seriously mangled, the timezone functions are
- ;; liable to bug out, so we ignore all errors.
- (let* ((now (current-time))
- (real-time (subtract-time now time))
- (real-sec (and real-time
- (+ (* (float (car real-time)) 65536)
- (cadr real-time))))
- (sec (and real-time (abs real-sec)))
- num prev)
- (cond
- ((null real-time)
- "X-Sent: Unknown")
- ((zerop sec)
- "X-Sent: Now")
- (t
- (concat
- "X-Sent: "
- ;; This is a bit convoluted, but basically we go
- ;; through the time units for years, weeks, etc,
- ;; and divide things to see whether that results
- ;; in positive answers.
- (mapconcat
- (lambda (unit)
- (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
- ;; The (remaining) seconds are too few to
- ;; be divided into this time unit.
- ""
- ;; It's big enough, so we output it.
- (setq sec (- sec (* num (cdr unit))))
- (prog1
- (concat (if prev ", " "") (int-to-string
- (floor num))
- " " (symbol-name (car unit))
- (if (> num 1) "s" ""))
- (setq prev t))))
- article-time-units "")
- ;; If dates are odd, then it might appear like the
- ;; article was sent in the future.
- (if (> real-sec 0)
- " ago"
- " in the future"))))))
+ (concat "X-Sent: " (article-lapsed-string time)))
+ ;; A combined date/lapsed format.
+ ((eq type 'combined-lapsed)
+ (let ((date-string (article-make-date-line date 'original))
+ (segments 3)
+ lapsed-string)
+ (while (and
+ (setq lapsed-string
+ (concat " (" (article-lapsed-string time segments) ")"))
+ (> (+ (length date-string)
+ (length lapsed-string))
+ (+ fill-column 6))
+ (> segments 0))
+ (setq segments (1- segments)))
+ (if (> segments 0)
+ (concat date-string lapsed-string)
+ date-string)))
;; Display the date in proper English
((eq type 'english)
(let ((dtime (decode-time time)))
(format "%02d" (nth 2 dtime))
":"
(format "%02d" (nth 1 dtime)))))))
- (error
+ (foo
(format "Date: %s (from Gnus)" date))))
+(defun article-lapsed-string (time &optional max-segments)
+ ;; If the date is seriously mangled, the timezone functions are
+ ;; liable to bug out, so we ignore all errors.
+ (let* ((now (current-time))
+ (real-time (subtract-time now time))
+ (real-sec (and real-time
+ (+ (* (float (car real-time)) 65536)
+ (cadr real-time))))
+ (sec (and real-time (abs real-sec)))
+ (segments 0)
+ num prev)
+ (unless max-segments
+ (setq max-segments (length article-time-units)))
+ (cond
+ ((null real-time)
+ "Unknown")
+ ((zerop sec)
+ "Now")
+ (t
+ (concat
+ ;; This is a bit convoluted, but basically we go
+ ;; through the time units for years, weeks, etc,
+ ;; and divide things to see whether that results
+ ;; in positive answers.
+ (mapconcat
+ (lambda (unit)
+ (if (or (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ (>= segments max-segments))
+ ;; The (remaining) seconds are too few to
+ ;; be divided into this time unit.
+ ""
+ ;; It's big enough, so we output it.
+ (setq sec (- sec (* num (cdr unit))))
+ (prog1
+ (concat (if prev ", " "") (int-to-string
+ (floor num))
+ " " (symbol-name (car unit))
+ (if (> num 1) "s" ""))
+ (setq prev t
+ segments (1+ segments)))))
+ article-time-units "")
+ ;; If dates are odd, then it might appear like the
+ ;; article was sent in the future.
+ (if (> real-sec 0)
+ " ago"
+ " in the future"))))))
+
(defun article-date-local (&optional highlight)
"Convert the current article date to the local timezone."
(interactive (list t))
(interactive (list t))
(article-date-ut 'lapsed highlight))
+(defun article-date-combined-lapsed (&optional highlight)
+ "Convert the current article date to time lapsed since it was sent."
+ (interactive (list t))
+ (article-date-ut 'combined-lapsed highlight))
+
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
(save-match-data
(let (deactivate-mark)
- (save-excursion
+ (save-window-excursion
(ignore-errors
(walk-windows
(lambda (w)
(set-buffer (window-buffer w))
(when (eq major-mode 'gnus-article-mode)
- (let ((mark (point-marker)))
+ (let ((mark (point-marker))
+ (old-point (point)))
(goto-char (point-min))
- (when (re-search-forward "^X-Sent:" nil t)
- (article-date-lapsed t))
- (goto-char (marker-position mark))
+ (when (re-search-forward "^X-Sent:\\|^Date:" nil t)
+ ;; If the point is on the Date line, then use that
+ ;; absolute position. Otherwise, use the mark.
+ ;; This will ensure that point stays at the "same
+ ;; place".
+ (when (or (< old-point (match-beginning 0))
+ (> old-point (progn
+ (forward-line 1)
+ (while (and (not (eobp))
+ (looking-at "X-Sent:\\|Date:"))
+ (forward-line))
+
projects / gnus / blobdiff