X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fshr.el;h=876d7b1e60c8c366c363e0dc4a3ae362596196cb;hb=340c8b70fc039577fbff744d6a224177be8436ee;hp=8bb532eb27edacaa86705579c302c30e4c1e8780;hpb=2c7930a5eaed5a455762e959ed8ba5c0d2afd2bb;p=gnus diff --git a/lisp/shr.el b/lisp/shr.el index 8bb532eb2..876d7b1e6 100644 --- a/lisp/shr.el +++ b/lisp/shr.el @@ -90,6 +90,7 @@ cid: URL as the argument.") (defvar shr-list-mode nil) (defvar shr-content-cache nil) (defvar shr-kinsoku-shorten nil) +(defvar shr-table-depth 0) (defvar shr-map (let ((map (make-sparse-keymap))) @@ -153,7 +154,7 @@ redirects somewhere else." (defun shr-browse-image () "Browse the image under point." (interactive) - (let ((url (get-text-property (point) 'shr-image))) + (let ((url (get-text-property (point) 'image-url))) (if (not url) (message "No image under point") (message "Browsing %s..." url) @@ -162,7 +163,7 @@ redirects somewhere else." (defun shr-insert-image () "Insert the image under point into the buffer." (interactive) - (let ((url (get-text-property (point) 'shr-image))) + (let ((url (get-text-property (point) 'image-url))) (if (not url) (message "No image under point") (message "Inserting %s..." url) @@ -180,7 +181,7 @@ redirects somewhere else." result)) (dolist (sub dom) (if (stringp sub) - (push (cons :text sub) result) + (push (cons 'text sub) result) (push (shr-transform-dom sub) result))) (nreverse result))) @@ -193,7 +194,7 @@ redirects somewhere else." (defun shr-generic (cont) (dolist (sub cont) (cond - ((eq (car sub) :text) + ((eq (car sub) 'text) (shr-insert (cdr sub))) ((listp (cdr sub)) (shr-descend sub))))) @@ -234,20 +235,23 @@ redirects somewhere else." (aref elem 0))))) (delete-char -1))) (insert elem) - (while (> (current-column) shr-width) - (unless (prog1 - (shr-find-fill-point) - (when (eq (preceding-char) ? ) - (delete-char -1)) - (insert "\n")) - (put-text-property (1- (point)) (point) 'shr-break t) - ;; No space is needed at the beginning of a line. - (when (eq (following-char) ? ) - (delete-char 1))) - (when (> shr-indentation 0) - (shr-indent)) - (end-of-line)) - (insert " ")) + (let (found) + (while (and (> (current-column) shr-width) + (progn + (setq found (shr-find-fill-point)) + (not (eolp)))) + (when (eq (preceding-char) ? ) + (delete-char -1)) + (insert "\n") + (unless found + (put-text-property (1- (point)) (point) 'shr-break t) + ;; No space is needed at the beginning of a line. + (when (eq (following-char) ? ) + (delete-char 1))) + (when (> shr-indentation 0) + (shr-indent)) + (end-of-line)) + (insert " "))) (unless (string-match "[ \t\n]\\'" text) (delete-char -1))))) @@ -285,7 +289,9 @@ redirects somewhere else." (aref (char-category-set (following-char)) ?>))) (backward-char 1)) (while (and (>= (setq count (1- count)) 0) - (aref (char-category-set (following-char)) ?>)) + (aref (char-category-set (following-char)) ?>) + (aref fill-find-break-point-function-table + (following-char))) (forward-char 1))) (when (eq (following-char) ? ) (forward-char 1)) @@ -337,9 +343,13 @@ redirects somewhere else." "Browse the URL under point." (interactive) (let ((url (get-text-property (point) 'shr-url))) - (if (not url) - (message "No link under point") - (browse-url url)))) + (cond + ((not url) + (message "No link under point")) + ((string-match "^mailto:" url) + (browse-url-mailto url)) + (t + (browse-url url))))) (defun shr-save-contents (directory) "Save the contents from URL in a file." @@ -369,18 +379,17 @@ redirects somewhere else." (let ((alt (buffer-substring start end)) (inhibit-read-only t)) (delete-region start end) - (shr-put-image data start alt)))))) + (goto-char start) + (shr-put-image data alt)))))) (kill-buffer (current-buffer))) -(defun shr-put-image (data point alt) +(defun shr-put-image (data alt) (if (display-graphic-p) (let ((image (ignore-errors (shr-rescale-image data)))) (when image - (put-image image point alt))) - (save-excursion - (goto-char point) - (insert alt)))) + (insert-image image (or alt "*")))) + (insert alt))) (defun shr-rescale-image (data) (if (or (not (fboundp 'imagemagick-types)) @@ -409,6 +418,11 @@ redirects somewhere else." image))) image))) +;; url-cache-extract autoloads url-cache. +(declare-function url-cache-create-filename "url-cache" (url)) +(autoload 'mm-disable-multibyte "mm-util") +(autoload 'browse-url-mailto "browse-url") + (defun shr-get-image-data (url) "Get image data for URL. Return a string with image data." @@ -426,6 +440,8 @@ Return a string with image data." (apply #'shr-fontize-cont cont types) (shr-ensure-paragraph)) +(autoload 'widget-convert-button "wid-edit") + (defun shr-urlify (start url) (widget-convert-button 'url-link start (point) @@ -470,14 +486,6 @@ Return a string with image data." (defun shr-tag-s (cont) (shr-fontize-cont cont 'strike-through)) -(defun shr-tag-span (cont) - (let ((start (point)) - (color (cdr (assq 'color (shr-parse-style (cdr (assq :style cont))))))) - (shr-generic cont) - (when color - (let ((overlay (make-overlay start (point)))) - (overlay-put overlay 'face (cons 'foreground-color color)))))) - (defun shr-parse-style (style) (when style (let ((plist nil)) @@ -501,24 +509,43 @@ Return a string with image data." (shr-urlify (or shr-start start) url))) (defun shr-tag-object (cont) - (let ((url (cdr (assq :src (cdr (assq 'embed cont))))) - (start (point))) + (let ((start (point)) + url) + (dolist (elem cont) + (when (eq (car elem) 'embed) + (setq url (or url (cdr (assq :src (cdr elem)))))) + (when (and (eq (car elem) 'param) + (equal (cdr (assq :name (cdr elem))) "movie")) + (setq url (or url (cdr (assq :value (cdr elem))))))) (when url (shr-insert " [multimedia] ") - (shr-urlify start url)))) + (shr-urlify start url)) + (shr-generic cont))) + +(defun shr-tag-video (cont) + (let ((image (cdr (assq :poster cont))) + (url (cdr (assq :src cont))) + (start (point))) + (shr-tag-img nil image) + (shr-urlify start url))) -(defun shr-tag-img (cont) - (when (and cont - (cdr (assq :src cont))) +(defun shr-tag-img (cont &optional url) + (when (or url + (and cont + (cdr (assq :src cont)))) (when (and (> (current-column) 0) (not (eq shr-state 'image))) (insert "\n")) (let ((alt (cdr (assq :alt cont))) - (url (cdr (assq :src cont)))) + (url (or url (cdr (assq :src cont))))) (let ((start (point-marker))) (when (zerop (length alt)) - (setq alt "[img]")) + (setq alt "*")) (cond + ((or (member (cdr (assq :height cont)) '("0" "1")) + (member (cdr (assq :width cont)) '("0" "1"))) + ;; Ignore zero-sized or single-pixel images. + ) ((and (not shr-inhibit-images) (string-match "\\`cid:" url)) (let ((url (substring url (match-end 0))) @@ -526,27 +553,27 @@ Return a string with image data." (if (or (not shr-content-function) (not (setq image (funcall shr-content-function url)))) (insert alt) - (shr-put-image image (point) alt)))) + (shr-put-image image alt)))) ((or shr-inhibit-images (and shr-blocked-images (string-match shr-blocked-images url))) (setq shr-start (point)) (let ((shr-state 'space)) - (if (> (length alt) 8) - (shr-insert (substring alt 0 8)) + (if (> (string-width alt) 8) + (shr-insert (truncate-string-to-width alt 8)) (shr-insert alt)))) ((url-is-cached (shr-encode-url url)) - (shr-put-image (shr-get-image-data url) (point) alt)) + (shr-put-image (shr-get-image-data url) alt)) (t (insert alt) (ignore-errors (url-retrieve (shr-encode-url url) 'shr-image-fetched (list (current-buffer) start (point-marker)) t)))) - (insert " ") (put-text-property start (point) 'keymap shr-map) (put-text-property start (point) 'shr-alt alt) - (put-text-property start (point) 'shr-image url) + (put-text-property start (point) 'image-url url) + (put-text-property start (point) 'help-echo alt) (setq shr-state 'image))))) (defun shr-tag-pre (cont) @@ -630,6 +657,7 @@ Return a string with image data." (setq cont (or (cdr (assq 'tbody cont)) cont)) (let* ((shr-inhibit-images t) + (shr-table-depth (1+ shr-table-depth)) (shr-kinsoku-shorten t) ;; Find all suggested widths. (columns (shr-column-specs cont)) @@ -651,8 +679,9 @@ Return a string with image data." ;; Finally, insert all the images after the table. The Emacs buffer ;; model isn't strong enough to allow us to put the images actually ;; into the tables. - (dolist (elem (shr-find-elements cont 'img)) - (shr-tag-img (cdr elem)))) + (when (zerop shr-table-depth) + (dolist (elem (shr-find-elements cont 'img)) + (shr-tag-img (cdr elem))))) (defun shr-tag-table (cont) (shr-ensure-paragraph)