mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-01-30 19:53:09 +00:00
Misc Gnus fixes by Lars Magne Ingebrigtsen <larsi@gnus.org>.
2010-08-29 Adam Sjøgren <asjo@koldfront.dk> * gnus-html.el (gnus-html-put-image): Use XEmacs-compatible image functions. 2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org> * 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.
This commit is contained in:
Katsumi Yamaoka
parent
655efd7175
commit
b1992461d7
@ -1,5 +1,29 @@
|
||||
2010-08-29 Adam Sjøgren <asjo@koldfront.dk>
|
||||
|
||||
* gnus-html.el (gnus-html-put-image): Use XEmacs-compatible image
|
||||
functions.
|
||||
|
||||
2010-08-29 Lars Magne Ingebrigtsen <larsi@gnus.org>
|
||||
|
||||
* 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 <larsi@gnus.org>
|
||||
|
||||
@ -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:
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 "</" tag ">") 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 </pre_int>s that were left over.
|
||||
(while (re-search-forward "</pre_int>" 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 "<img.*src=[\"']\\([^\"']+\\)" nil t)
|
||||
(let ((url (match-string 1)))
|
||||
(when (or (null safe-url-regexp)
|
||||
(string-match safe-url-regexp url))
|
||||
(unless (file-exists-p (gnus-html-image-id url))
|
||||
(push url urls)
|
||||
(push (gnus-html-image-id url) urls)
|
||||
(push "-o" urls)))))
|
||||
(let ((process
|
||||
(apply 'start-process
|
||||
"images" nil "curl"
|
||||
"-s" "--create-dirs"
|
||||
"--location"
|
||||
"--max-time" "60"
|
||||
urls)))
|
||||
(process-kill-without-query process))))))
|
||||
|
||||
(provide 'gnus-html)
|
||||
|
||||
;;; gnus-html.el ends here
|
||||
|
||||
@ -76,6 +76,12 @@ See `gnus-group-goto-unread'."
|
||||
:version "23.1" ;; No Gnus
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom gnus-summary-stop-at-end-of-message nil
|
||||
"If non-nil, don't select the next message when using `SPC'."
|
||||
:link '(custom-manual "(gnus)Group Maneuvering")
|
||||
:group 'gnus-summary-maneuvering
|
||||
:type 'boolean)
|
||||
|
||||
(defcustom gnus-fetch-old-headers nil
|
||||
"*Non-nil means that Gnus will try to build threads by grabbing old headers.
|
||||
If an unread article in the group refers to an older, already
|
||||
@ -7781,7 +7787,7 @@ Also see the variable `gnus-article-skip-boring'."
|
||||
(setq endp (or (gnus-article-next-page lines)
|
||||
(gnus-article-only-boring-p))))
|
||||
(when endp
|
||||
(cond (stop
|
||||
(cond ((or stop gnus-summary-stop-at-end-of-message)
|
||||
(gnus-message 3 "End of message"))
|
||||
(circular
|
||||
(gnus-summary-beginning-of-article))
|
||||
|
||||
@ -105,10 +105,9 @@
|
||||
,disposition ,description ,cache ,id))
|
||||
|
||||
(defcustom mm-text-html-renderer
|
||||
(cond ((executable-find "w3m")
|
||||
(if (locate-library "w3m")
|
||||
'w3m
|
||||
'w3m-standalone))
|
||||
(cond ((and (executable-find "w3m")
|
||||
(executable-find "curl"))
|
||||
'gnus-article-html)
|
||||
((executable-find "links") 'links)
|
||||
((executable-find "lynx") 'lynx)
|
||||
((locate-library "w3") 'w3)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user