procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

shr.el (shr-expand-newlines): Make nested boxes work.

Browse source
This commit is contained in:
Lars Ingebrigtsen 2011-01-25 08:42:32 +00:00 • committed by Katsumi Yamaoka
parent 0fe719e691
commit d709b79ac8
2 changed files with 39 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lisp/gnus/ChangeLog
View file

@ -1,3 +1,7 @@
2011-01-25 Lars Ingebrigtsen <larsi@gnus.org>
* shr.el (shr-expand-newlines): Make nested boxes work.
2011-01-24 Lars Ingebrigtsen <larsi@gnus.org>
* shr.el (shr-expand-newlines): Proof of concept implemantation of boxy

38
lisp/gnus/shr.el
View file

@ -648,6 +648,15 @@ ones, in case fg and bg are nil."
(defun shr-expand-newlines (start end color)
(save-restriction
;; Skip past all white space at the start and ends.
(goto-char start)
(skip-chars-forward " \t\n")
(beginning-of-line)
(setq start (point))
(goto-char end)
(skip-chars-backward " \t\n")
(forward-line 1)
(setq end (point))
(narrow-to-region start end)
(let ((width (shr-natural-width))
column)
@ -655,13 +664,36 @@ ones, in case fg and bg are nil."
(while (not (eobp))
(end-of-line)
(when (and (< (setq current-column (current-column)) width)
(not (overlays-at (point))))
(< (setq current-column (shr-previous-newline-padding-width
current-column))
width))
(let ((overlay (make-overlay (point) (1+ (point)))))
(overlay-put overlay 'before-string
(propertize (make-string (- width current-column) ? )
'face (list :background color)))))
(concat
(mapconcat
(lambda (overlay)
(let ((string (getf (overlay-properties overlay) 'before-string)))
(if (not string)
""
(overlay-put overlay 'before-string "")
string)))
(overlays-at (point))
"")
(propertize (make-string (- width current-column) ? )
'face (list :background color))))))
(forward-line 1)))))
(defun shr-previous-newline-padding-width (width)
(let ((overlays (overlays-at (point)))
(previous-width 0))
(if (null overlays)
width
(dolist (overlay overlays)
(setq previous-width
(+ previous-width
(length (getf (overlay-properties overlay) 'before-string)))))
(+ width previous-width))))
(defun shr-put-color-1 (start end type color)
(let* ((old-props (get-text-property start 'face))
(do-put (not (memq type old-props)))