From: Katsumi Yamaoka Date: Mon, 30 Aug 2010 06:17:45 +0000 (+0000) Subject: Misc Gnus fixes by Lars Magne Ingebrigtsen . X-Git-Tag: emacs-pretest-24.0.90~104^2~275^2~438^2~48^2~215 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=b1992461d756e25b86912411a0ac9ea94d57cb12;p=emacs.git Misc Gnus fixes by Lars Magne Ingebrigtsen . 2010-08-29 Adam Sjøgren * gnus-html.el (gnus-html-put-image): Use XEmacs-compatible image functions. 2010-08-29 Lars Magne Ingebrigtsen * gnus-art.el (gnus-article-add-button): Take an optional parameter to say what the mouseover text should be. * gnus-html.el (gnus-html-prefetch-images): Use the summary-local version of the mm-w3m-safe-url-regexp variable to only download images in the groups where we want that to happen. * gnus-sum.el (gnus-summary-stop-at-end-of-message): New variable. * gnus-art.el (gnus-article-beginning-of-window): Make into defun for easier debugging. (gnus-article-beginning-of-window): Add kludge to allow spacing past big pictures in the article buffer. * mm-decode.el (mm-text-html-renderer): Default the html renderer to gnus-article-html. (mm-text-html-renderer): gnus-article-html needs curl in addition to w3m. --- diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index e6e0ff07a11..e23b94f2ac7 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,5 +1,29 @@ +2010-08-29 Adam Sjøgren + + * gnus-html.el (gnus-html-put-image): Use XEmacs-compatible image + functions. + 2010-08-29 Lars Magne Ingebrigtsen + * gnus-art.el (gnus-article-add-button): Take an optional parameter to + say what the mouseover text should be. + + * gnus-html.el (gnus-html-prefetch-images): Use the summary-local + version of the mm-w3m-safe-url-regexp variable to only download images + in the groups where we want that to happen. + + * gnus-sum.el (gnus-summary-stop-at-end-of-message): New variable. + + * gnus-art.el (gnus-article-beginning-of-window): Make into defun for + easier debugging. + (gnus-article-beginning-of-window): Add kludge to allow spacing past + big pictures in the article buffer. + + * mm-decode.el (mm-text-html-renderer): Default the html renderer to + gnus-article-html. + (mm-text-html-renderer): gnus-article-html needs curl in addition to + w3m. + * gnus-html.el: Start a new super-simple HTML renderer based on w3m. 2010-08-28 Lars Magne Ingebrigtsen diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 618d8e410cb..63a38d10c53 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6283,18 +6283,22 @@ Argument LINES specifies lines to be scrolled up." (gnus-article-next-page-1 lines) nil)) -(defmacro gnus-article-beginning-of-window () +(defun gnus-article-beginning-of-window () "Move point to the beginning of the window. In Emacs, the point is placed at the line number which `scroll-margin' specifies." (if (featurep 'xemacs) - '(move-to-window-line 0) - '(move-to-window-line - (min (max 0 scroll-margin) - (max 1 (- (window-height) - (if mode-line-format 1 0) - (if header-line-format 1 0) - 2)))))) + (move-to-window-line 0) + ;; There is an obscure bug in Emacs that makes it impossible to + ;; scroll past big pictures in the article buffer. Try to fix + ;; this by adding a sanity check by counting the lines visible. + (when (> (count-lines (window-start) (window-end)) 30) + (move-to-window-line + (min (max 0 scroll-margin) + (max 1 (- (window-height) + (if mode-line-format 1 0) + (if header-line-format 1 0) + 2))))))) (defun gnus-article-next-page-1 (lines) (unless (featurep 'xemacs) @@ -7899,7 +7903,7 @@ url is put as the `gnus-button-url' overlay property on the button." ;;; External functions: -(defun gnus-article-add-button (from to fun &optional data) +(defun gnus-article-add-button (from to fun &optional data text) "Create a button between FROM and TO with callback FUN and data DATA." (when gnus-article-button-face (gnus-overlay-put (gnus-make-overlay from to nil t) @@ -7911,6 +7915,7 @@ url is put as the `gnus-button-url' overlay property on the button." (list 'gnus-callback fun) (and data (list 'gnus-data data)))) (widget-convert-button 'link from to :action 'gnus-widget-press-button + :help-echo (or text "Follow the link") :button-keymap gnus-widget-button-keymap)) ;;; Internal functions: diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index 432990e3c2c..95ea48803c7 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -71,6 +71,13 @@ It should return non-nil if the article is to be prefetched." :group 'gnus-asynchronous :type 'function) +(defcustom gnus-async-post-fetch-function nil + "Function called after an article has been prefetched. +The function will be called narrowed to the region of the article +that was fetched." + :group 'gnus-asynchronous + :type 'function) + ;;; Internal variables. (defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*") @@ -227,6 +234,11 @@ It should return non-nil if the article is to be prefetched." (setq gnus-async-current-prefetch-article nil) (when arg (gnus-async-set-buffer) + (when gnus-async-post-fetch-function + (save-excursion + (save-restriction + (narrow-to-region mark (point-max)) + (funcall gnus-async-post-fetch-function summary)))) (gnus-async-with-semaphore (setq gnus-async-article-alist diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index 65367758560..eb35aca505a 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -28,42 +28,85 @@ ;;; Code: +(defcustom gnus-html-cache-directory (nnheader-concat gnus-directory "html-cache/") + "Where Gnus will cache images it downloads from the web." + :group 'gnus-art + :type 'directory) + +(defcustom gnus-html-cache-size 500000000 + "The size of the Gnus image cache." + :group 'gnus-art + :type 'integer) + +(defcustom gnus-html-frame-width 70 + "What width to use when rendering HTML." + :group 'gnus-art + :type 'integer) + ;;;###autoload (defun gnus-article-html (handle) (let ((article-buffer (current-buffer))) (save-restriction (narrow-to-region (point) (point)) (save-excursion - (set-buffer (car handle)) - (call-process-region (point-min) (point-max) - "w3m" - nil article-buffer nil - "-halfdump" - "-T" "text/html")) + (mm-with-part handle + (let* ((coding-system-for-read 'utf-8) + (coding-system-for-write 'utf-8) + (default-process-coding-system + (cons coding-system-for-read coding-system-for-write))) + (call-process-region (point-min) (point-max) + "w3m" + nil article-buffer nil + "-halfdump" + "-no-cookie" + "-O" "UTF-8" + "-o" "ext_halfdump=1" + "-t" (format "%s" tab-width) + "-cols" (format "%s" gnus-html-frame-width) + "-o" "display_image=off" + "-T" "text/html")))) (gnus-html-wash-tags)))) (defun gnus-html-wash-tags () - (let (tag parameters string start end) - ;;(subst-char-in-region (point-min) (point-max) ?_ ? ) + (let (tag parameters string start end images) + (mm-url-decode-entities) (goto-char (point-min)) - (while (re-search-forward "<\\([^ ]+\\)\\([^>]*\\)>\\([^<]*\\)<[^>]*>" nil t) + (while (re-search-forward "<\\([^ />]+\\)\\([^>]*\\)>" nil t) (setq tag (match-string 1) parameters (match-string 2) - string (match-string 3) - start (match-beginning 0) - end (+ start (length string))) - (replace-match string) + start (match-beginning 0)) + (when (plusp (length parameters)) + (set-text-properties 0 (1- (length parameters)) nil parameters)) + (delete-region start (point)) + (when (search-forward (concat "") nil t) + (delete-region (match-beginning 0) (match-end 0))) + (setq end (point)) (cond ;; Fetch and insert a picture. ((equal tag "img_alt") - ;; - ) + (when (string-match "src=\"\\([^\"]+\\)" parameters) + (setq parameters (match-string 1 parameters)) + (when (or (null mm-w3m-safe-url-regexp) + (string-match mm-w3m-safe-url-regexp parameters)) + (let ((file (gnus-html-image-id parameters))) + (if (file-exists-p file) + ;; It's already cached, so just insert it. + (when (gnus-html-put-image file (point)) + ;; Delete the ALT text. + (delete-region start end)) + ;; We don't have it, so schedule it for fetching + ;; asynchronously. + (push (list parameters + (set-marker (make-marker) start) + (point-marker)) + images)))))) ;; Add a link. ((equal tag "a") (when (string-match "href=\"\\([^\"]+\\)" parameters) (setq parameters (match-string 1 parameters)) (gnus-article-add-button start end - 'browse-url parameters) + 'browse-url parameters + parameters) (let ((overlay (gnus-make-overlay start end))) (gnus-overlay-put overlay 'evaporate t) (gnus-overlay-put overlay 'gnus-button-url parameters) @@ -71,6 +114,113 @@ (gnus-overlay-put overlay 'mouse-face gnus-article-mouse-face))))) ;; Whatever. Just ignore the tag. (t - (replace-match string)))))) + )) + (goto-char start)) + (goto-char (point-min)) + ;; The output from -halfdump isn't totally regular, so strip + ;; off any s that were left over. + (while (re-search-forward "" nil t) + (replace-match "" t t)) + (when images + (gnus-html-schedule-image-fetching (current-buffer) (nreverse images))))) + +(defun gnus-html-schedule-image-fetching (buffer images) + (let* ((url (caar images)) + (process (start-process + "images" nil "curl" + "-s" "--create-dirs" + "--location" + "--max-time" "60" + "-o" (gnus-html-image-id url) + url))) + (process-kill-without-query process) + (set-process-sentinel process 'gnus-html-curl-sentinel) + (set-process-plist process (list 'images images + 'buffer buffer)))) + +(defun gnus-html-image-id (url) + (expand-file-name (sha1 url) gnus-html-cache-directory)) + +(defun gnus-html-curl-sentinel (process event) + (when (string-match "finished" event) + (let* ((images (getf (process-plist process) 'images)) + (buffer (getf (process-plist process) 'buffer)) + (spec (pop images)) + (file (gnus-html-image-id (car spec)))) + (when (and (buffer-live-p buffer) + ;; If the position of the marker is 1, then that + ;; means that the text is was in has been deleted; + ;; i.e., that the user has selected a different + ;; article before the image arrived. + (not (= (marker-position (cadr spec)) 1))) + (save-excursion + (set-buffer buffer) + (let ((buffer-read-only nil)) + (when (gnus-html-put-image file (cadr spec)) + (delete-region (cadr spec) (caddr spec)))))) + (when images + (gnus-html-schedule-image-fetching buffer images))))) + +(defun gnus-html-put-image (file point) + (let ((image (ignore-errors + (create-image file)))) + (if (and image + ;; Kludge to avoid displaying 30x30 gif images, which + ;; seems to be a signal of a broken image. + (not (and (eq (getf (cdr image) :type) 'gif) + (= (car (image-size image t)) 30) + (= (cdr (image-size image t)) 30)))) + (progn + (put-image image point) + t) + (when (fboundp 'find-image) + (put-image (find-image '((:type xpm :file "lock-broken.xpm"))) + point)) + nil))) + +(defun gnus-html-prune-cache () + (let ((total-size 0) + files) + (dolist (file (directory-files gnus-html-cache-directory t nil t)) + (let ((attributes (file-attributes file))) + (unless (nth 0 attributes) + (incf total-size (nth 7 attributes)) + (push (list (time-to-seconds (nth 5 attributes)) + (nth 7 attributes) file) + files)))) + (when (> total-size gnus-html-cache-size) + (setq files (sort files (lambda (f1 f2) + (< (car f1) (car f2))))) + (dolist (file files) + (when (> total-size gnus-html-cache-size) + (decf total-size (cadr file)) + (delete-file (nth 2 file))))))) + +;;;###autoload +(defun gnus-html-prefetch-images (summary) + (let (safe-url-regexp urls) + (when (buffer-live-p summary) + (save-excursion + (set-buffer summary) + (setq safe-url-regexp mm-w3m-safe-url-regexp)) + (save-match-data + (while (re-search-forward "