Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-xmas.el @ 136:b980b6286996 r20-2b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b2
author cvs
date Mon, 13 Aug 2007 09:31:12 +0200
parents d2f30a177268
children 43dd3413c7c7
comparison
equal deleted inserted replaced
135:4636a6841cd6 136:b980b6286996
198 198
199 (defun gnus-xmas-summary-set-display-table () 199 (defun gnus-xmas-summary-set-display-table ()
200 ;; Setup the display table -- like `gnus-summary-setup-display-table', 200 ;; Setup the display table -- like `gnus-summary-setup-display-table',
201 ;; but done in an XEmacsish way. 201 ;; but done in an XEmacsish way.
202 (let ((table (make-display-table)) 202 (let ((table (make-display-table))
203 (default-table (specifier-instance current-display-table))
204 (i 32)) 203 (i 32))
205 ;; Nix out all the control chars... 204 ;; Nix out all the control chars...
206 (while (>= (setq i (1- i)) 0) 205 (while (>= (setq i (1- i)) 0)
207 (aset table i [??])) 206 (aset table i [??]))
208 ;; ... but not newline and cr, of course. (cr is necessary for the 207 ;; ... but not newline and cr, of course. (cr is necessary for the
209 ;; selective display). 208 ;; selective display).
210 (aset table ?\n nil) 209 (aset table ?\n nil)
211 (aset table ?\r nil) 210 (aset table ?\r nil)
212 ;; We nix out any glyphs over 126 that are not set already. 211 ;; We nix out any glyphs over 126 below ctl-arrow.
213 (when default-table 212 (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
214 (let ((i 256)) 213 (while (>= (setq i (1- i)) 127)
215 (while (>= (setq i (1- i)) 127) 214 (aset table i [??])))
216 ;; Only modify if the default entry is nil.
217 (unless (aref default-table i)
218 (aset table i [??])))))
219 ;; Can't use `set-specifier' because of a bug in 19.14 and earlier 215 ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
220 (add-spec-to-specifier current-display-table table (current-buffer) nil))) 216 (add-spec-to-specifier current-display-table table (current-buffer) nil)))
221 217
222 (defun gnus-xmas-add-text-properties (start end props &optional object) 218 (defun gnus-xmas-add-text-properties (start end props &optional object)
223 (add-text-properties start end props object) 219 (add-text-properties start end props object)
733 :group 'gnus-xmas) 729 :group 'gnus-xmas)
734 730
735 (defun gnus-xmas-article-display-xface (beg end) 731 (defun gnus-xmas-article-display-xface (beg end)
736 "Display any XFace headers in the current article." 732 "Display any XFace headers in the current article."
737 (save-excursion 733 (save-excursion
738 (let (xface-glyph) 734 (let ((xface-glyph
739 (if (featurep 'xface) 735 (if (featurep 'xface)
740 (setq xface-glyph 736 (make-glyph (vector 'xface :data
741 (make-glyph (vector 'xface :data 737 (concat "X-Face: "
742 (concat "X-Face: " 738 (buffer-substring beg end))))
743 (buffer-substring beg end))))) 739 (let ((cur (current-buffer)))
744 (let ((cur (current-buffer))) 740 (save-excursion
745 (save-excursion 741 (gnus-set-work-buffer)
746 (gnus-set-work-buffer) 742 (insert (format "%s" (buffer-substring beg end cur)))
747 (insert (format "%s" (buffer-substring beg end cur))) 743 (gnus-xmas-call-region "uncompface")
748 (gnus-xmas-call-region "uncompface") 744 (goto-char (point-min))
749 (goto-char (point-min)) 745 (insert "/* Width=48, Height=48 */\n")
750 (insert "/* Width=48, Height=48 */\n") 746 (gnus-xmas-call-region "icontopbm")
751 (gnus-xmas-call-region "icontopbm") 747 (gnus-xmas-call-region "ppmtoxpm")
752 (gnus-xmas-call-region "ppmtoxpm") 748 (make-glyph
753 (setq xface-glyph 749 (vector 'xpm :data (buffer-string))))))))
754 (make-glyph
755 (vector 'xpm :data (buffer-string )))))))
756 (set-glyph-face xface-glyph 'gnus-x-face) 750 (set-glyph-face xface-glyph 'gnus-x-face)
757 (goto-char (point-min)) 751 (goto-char (point-min))
758 (re-search-forward "^From:" nil t) 752 (re-search-forward "^From:" nil t)
759 (set-extent-begin-glyph 753 (set-extent-begin-glyph
760 (make-extent (point) (1+ (point))) xface-glyph)))) 754 (make-extent (point) (1+ (point))) xface-glyph))))