Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-xmas.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 1917ad0d78d7
children e04119814345
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
118 "You should NEVER use this function. It is ideologically blasphemous. 118 "You should NEVER use this function. It is ideologically blasphemous.
119 It is provided only to ease porting of broken FSF Emacs programs." 119 It is provided only to ease porting of broken FSF Emacs programs."
120 (if (stringp buffer) 120 (if (stringp buffer)
121 nil 121 nil
122 (map-extents (lambda (extent ignored) 122 (map-extents (lambda (extent ignored)
123 (remove-text-properties 123 (remove-text-properties
124 start end 124 start end
125 (list (extent-property extent 'text-prop) nil) 125 (list (extent-property extent 'text-prop) nil)
126 buffer)) 126 buffer))
127 buffer start end nil nil 'text-prop) 127 buffer start end nil nil 'text-prop)
128 (gnus-add-text-properties start end props buffer))) 128 (gnus-add-text-properties start end props buffer)))
130 (defun gnus-xmas-highlight-selected-summary () 130 (defun gnus-xmas-highlight-selected-summary ()
131 ;; Highlight selected article in summary buffer 131 ;; Highlight selected article in summary buffer
132 (when gnus-summary-selected-face 132 (when gnus-summary-selected-face
133 (when gnus-newsgroup-selected-overlay 133 (when gnus-newsgroup-selected-overlay
134 (delete-extent gnus-newsgroup-selected-overlay)) 134 (delete-extent gnus-newsgroup-selected-overlay))
135 (setq gnus-newsgroup-selected-overlay 135 (setq gnus-newsgroup-selected-overlay
136 (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) 136 (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
137 (set-extent-face gnus-newsgroup-selected-overlay 137 (set-extent-face gnus-newsgroup-selected-overlay
138 gnus-summary-selected-face))) 138 gnus-summary-selected-face)))
139 139
140 (defvar gnus-xmas-force-redisplay nil 140 (defvar gnus-xmas-force-redisplay nil
193 193
194 (defun gnus-xmas-extent-start-open (point) 194 (defun gnus-xmas-extent-start-open (point)
195 (map-extents (lambda (extent arg) 195 (map-extents (lambda (extent arg)
196 (set-extent-property extent 'start-open t)) 196 (set-extent-property extent 'start-open t))
197 nil point (min (1+ (point)) (point-max)))) 197 nil point (min (1+ (point)) (point-max))))
198 198
199 (defun gnus-xmas-article-push-button (event) 199 (defun gnus-xmas-article-push-button (event)
200 "Check text under the mouse pointer for a callback function. 200 "Check text under the mouse pointer for a callback function.
201 If the text under the mouse pointer has a `gnus-callback' property, 201 If the text under the mouse pointer has a `gnus-callback' property,
202 call it with the value of the `gnus-data' text property." 202 call it with the value of the `gnus-data' text property."
203 (interactive "e") 203 (interactive "e")
215 (defun gnus-xmas-article-add-button (from to fun &optional data) 215 (defun gnus-xmas-article-add-button (from to fun &optional data)
216 "Create a button between FROM and TO with callback FUN and data DATA." 216 "Create a button between FROM and TO with callback FUN and data DATA."
217 (when gnus-article-button-face 217 (when gnus-article-button-face
218 (gnus-overlay-put (gnus-make-overlay from to) 218 (gnus-overlay-put (gnus-make-overlay from to)
219 'face gnus-article-button-face)) 219 'face gnus-article-button-face))
220 (gnus-add-text-properties 220 (gnus-add-text-properties
221 from to 221 from to
222 (nconc 222 (nconc
223 (and gnus-article-mouse-face 223 (and gnus-article-mouse-face
224 (list 'mouse-face gnus-article-mouse-face)) 224 (list 'mouse-face gnus-article-mouse-face))
225 (list 'gnus-callback fun) 225 (list 'gnus-callback fun)
253 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges)))))) 253 (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
254 (last-window (previous-window)) 254 (last-window (previous-window))
255 (window-search t)) 255 (window-search t))
256 (while window-search 256 (while window-search
257 (let* ((this-window (next-window)) 257 (let* ((this-window (next-window))
258 (next-bottom-edge (car (cdr (cdr (cdr 258 (next-bottom-edge (car (cdr (cdr (cdr
259 (window-pixel-edges 259 (window-pixel-edges
260 this-window))))))) 260 this-window)))))))
261 (when (< bottom-edge next-bottom-edge) 261 (when (< bottom-edge next-bottom-edge)
262 (setq bottom-edge next-bottom-edge) 262 (setq bottom-edge next-bottom-edge)
263 (setq lowest-window this-window)) 263 (setq lowest-window this-window))
264 264
330 ;; We junk all non-key events. Is this naughty? 330 ;; We junk all non-key events. Is this naughty?
331 (while (not (or (key-press-event-p event) 331 (while (not (or (key-press-event-p event)
332 (button-press-event-p event))) 332 (button-press-event-p event)))
333 (dispatch-event event) 333 (dispatch-event event)
334 (setq event (next-command-event))) 334 (setq event (next-command-event)))
335 (cons (and (key-press-event-p event) 335 (cons (and (key-press-event-p event)
336 (event-to-character event)) 336 (event-to-character event))
337 event))) 337 event)))
338 338
339 (defun gnus-xmas-group-remove-excess-properties () 339 (defun gnus-xmas-group-remove-excess-properties ()
340 (let ((end (point)) 340 (let ((end (point))
341 (beg (progn (forward-line -1) (point)))) 341 (beg (progn (forward-line -1) (point))))
342 (remove-text-properties (1+ beg) end '(gnus-group nil)) 342 (remove-text-properties (1+ beg) end '(gnus-group nil))
343 (remove-text-properties 343 (remove-text-properties
344 beg end 344 beg end
345 '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil)) 345 '(gnus-topic nil gnus-topic-level nil gnus-topic-visible nil))
346 (goto-char end) 346 (goto-char end)
347 (map-extents 347 (map-extents
348 (lambda (e ma) 348 (lambda (e ma)
349 (set-extent-property e 'start-closed t)) 349 (set-extent-property e 'start-closed t))
350 (current-buffer) beg end))) 350 (current-buffer) beg end)))
351 351
352 (defun gnus-xmas-topic-remove-excess-properties () 352 (defun gnus-xmas-topic-remove-excess-properties ()
353 (let ((end (point)) 353 (let ((end (point))
354 (beg (progn (forward-line -1) (point)))) 354 (beg (progn (forward-line -1) (point))))
355 (remove-text-properties beg end '(gnus-group nil gnus-unread nil)) 355 (remove-text-properties beg end '(gnus-group nil gnus-unread nil))
356 (remove-text-properties (1+ beg) end '(gnus-topic nil)) 356 (remove-text-properties (1+ beg) end '(gnus-topic nil))
363 (ttime (mapcar (lambda (ti) (and ti (string-to-int ti))) 363 (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
364 (timezone-parse-time 364 (timezone-parse-time
365 (aref (timezone-parse-date date) 3)))) 365 (aref (timezone-parse-date date) 3))))
366 (edate (mapcar (lambda (ti) (and ti (string-to-int ti))) 366 (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
367 (timezone-parse-date "Jan 1 12:00:00 1970"))) 367 (timezone-parse-date "Jan 1 12:00:00 1970")))
368 (tday (- (timezone-absolute-from-gregorian 368 (tday (- (timezone-absolute-from-gregorian
369 (nth 1 tdate) (nth 2 tdate) (nth 0 tdate)) 369 (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
370 (timezone-absolute-from-gregorian 370 (timezone-absolute-from-gregorian
371 (nth 1 edate) (nth 2 edate) (nth 0 edate))))) 371 (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
372 (+ (nth 2 ttime) 372 (+ (nth 2 ttime)
373 (* (nth 1 ttime) 60) 373 (* (nth 1 ttime) 60)
374 (* (float (nth 0 ttime)) 60 60) 374 (* (float (nth 0 ttime)) 60 60)
375 (* (float tday) 60 60 24)))) 375 (* (float tday) 60 60 24))))
399 (fset 'gnus-move-overlay 'gnus-xmas-move-overlay) 399 (fset 'gnus-move-overlay 'gnus-xmas-move-overlay)
400 (fset 'gnus-overlay-end 'extent-end-position) 400 (fset 'gnus-overlay-end 'extent-end-position)
401 (fset 'gnus-extent-detached-p 'extent-detached-p) 401 (fset 'gnus-extent-detached-p 'extent-detached-p)
402 (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties) 402 (fset 'gnus-add-text-properties 'gnus-xmas-add-text-properties)
403 (fset 'gnus-put-text-property 'gnus-xmas-put-text-property) 403 (fset 'gnus-put-text-property 'gnus-xmas-put-text-property)
404 404
405 (require 'text-props) 405 (require 'text-props)
406 (if (and (<= emacs-major-version 19) 406 (if (and (<= emacs-major-version 19)
407 (< emacs-minor-version 14)) 407 (< emacs-minor-version 14))
408 (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) 408 (fset 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
409 409
417 417
418 (unless (fboundp 'encode-time) 418 (unless (fboundp 'encode-time)
419 (defun encode-time (sec minute hour day month year &optional zone) 419 (defun encode-time (sec minute hour day month year &optional zone)
420 (let ((seconds 420 (let ((seconds
421 (gnus-xmas-seconds-since-epoch 421 (gnus-xmas-seconds-since-epoch
422 (timezone-make-arpa-date 422 (timezone-make-arpa-date
423 year month day (timezone-make-time-string hour minute sec) 423 year month day (timezone-make-time-string hour minute sec)
424 zone)))) 424 zone))))
425 (list (floor (/ seconds (expt 2 16))) 425 (list (floor (/ seconds (expt 2 16)))
426 (round (mod seconds (expt 2 16))))))) 426 (round (mod seconds (expt 2 16)))))))
427 427
428 (defun gnus-byte-code (func) 428 (defun gnus-byte-code (func)
429 "Return a form that can be `eval'ed based on FUNC." 429 "Return a form that can be `eval'ed based on FUNC."
430 (let ((fval (symbol-function func))) 430 (let ((fval (symbol-function func)))
431 (if (compiled-function-p fval) 431 (if (compiled-function-p fval)
432 (list 'funcall fval) 432 (list 'funcall fval)
433 (cons 'progn (cdr (cdr fval)))))) 433 (cons 'progn (cdr (cdr fval))))))
434 434
435 (fset 'gnus-x-color-values 435 (fset 'gnus-x-color-values
436 (if (fboundp 'x-color-values) 436 (if (fboundp 'x-color-values)
437 'x-color-values 437 'x-color-values
438 (lambda (color) 438 (lambda (color)
439 (color-instance-rgb-components 439 (color-instance-rgb-components
440 (make-color-instance color)))))) 440 (make-color-instance color))))))
449 (fset 'gnus-article-add-button 'gnus-xmas-article-add-button) 449 (fset 'gnus-article-add-button 'gnus-xmas-article-add-button)
450 (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge) 450 (fset 'gnus-window-top-edge 'gnus-xmas-window-top-edge)
451 (fset 'gnus-read-event-char 'gnus-xmas-read-event-char) 451 (fset 'gnus-read-event-char 'gnus-xmas-read-event-char)
452 (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message) 452 (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
453 (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize) 453 (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
454 (fset 'gnus-appt-select-lowest-window 454 (fset 'gnus-appt-select-lowest-window
455 'gnus-xmas-appt-select-lowest-window) 455 'gnus-xmas-appt-select-lowest-window)
456 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) 456 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
457 (fset 'gnus-add-hook 'gnus-xmas-add-hook) 457 (fset 'gnus-add-hook 'gnus-xmas-add-hook)
458 (fset 'gnus-character-to-event 'character-to-event) 458 (fset 'gnus-character-to-event 'character-to-event)
459 (fset 'gnus-mode-line-buffer-identification 459 (fset 'gnus-mode-line-buffer-identification
460 'gnus-xmas-mode-line-buffer-identification) 460 'gnus-xmas-mode-line-buffer-identification)
461 (fset 'gnus-key-press-event-p 'key-press-event-p) 461 (fset 'gnus-key-press-event-p 'key-press-event-p)
462 (fset 'gnus-region-active-p 'region-active-p) 462 (fset 'gnus-region-active-p 'region-active-p)
463 463
464 (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) 464 (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add)
465 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) 465 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add)
466 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add) 466 (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)
467 (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) 467 (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add)
468 468
500 "Insert startup message in current buffer." 500 "Insert startup message in current buffer."
501 ;; Insert the message. 501 ;; Insert the message.
502 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 502 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
503 (erase-buffer) 503 (erase-buffer)
504 (let ((logo (and gnus-xmas-glyph-directory 504 (let ((logo (and gnus-xmas-glyph-directory
505 (concat 505 (concat
506 (file-name-as-directory gnus-xmas-glyph-directory) 506 (file-name-as-directory gnus-xmas-glyph-directory)
507 "gnus." 507 "gnus."
508 (if (featurep 'xpm) "xpm" "xbm")))) 508 (if (featurep 'xpm) "xpm" "xbm"))))
509 (xpm-color-symbols 509 (xpm-color-symbols
510 (and (featurep 'xpm) 510 (and (featurep 'xpm)
511 (append `(("thing" ,(car gnus-xmas-logo-colors)) 511 (append `(("thing" ,(car gnus-xmas-logo-colors))
512 ("shadow" ,(cadr gnus-xmas-logo-colors))) 512 ("shadow" ,(cadr gnus-xmas-logo-colors)))
513 xpm-color-symbols)))) 513 xpm-color-symbols))))
514 (if (and (featurep 'xpm) 514 (if (and (featurep 'xpm)
530 (rest (- wheight pheight))) 530 (rest (- wheight pheight)))
531 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) 531 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
532 532
533 (insert 533 (insert
534 (format " %s 534 (format " %s
535 _ ___ _ _ 535 _ ___ _ _
536 _ ___ __ ___ __ _ ___ 536 _ ___ __ ___ __ _ ___
537 __ _ ___ __ ___ 537 __ _ ___ __ ___
538 _ ___ _ 538 _ ___ _
539 _ _ __ _ 539 _ _ __ _
540 ___ __ _ 540 ___ __ _
541 __ _ 541 __ _
542 _ _ _ 542 _ _ _
543 _ _ _ 543 _ _ _
544 _ _ _ 544 _ _ _
545 __ ___ 545 __ ___
546 _ _ _ _ 546 _ _ _ _
547 _ _ 547 _ _
548 _ _ 548 _ _
549 _ _ 549 _ _
550 _ 550 _
551 __ 551 __
552 552
553 " 553 "
554 "")) 554 ""))
555 ;; And then hack it. 555 ;; And then hack it.
556 (gnus-indent-rigidly (point-min) (point-max) 556 (gnus-indent-rigidly (point-min) (point-max)
557 (/ (max (- (window-width) (or x 46)) 0) 2)) 557 (/ (max (- (window-width) (or x 46)) 0) 2))
558 (goto-char (point-min)) 558 (goto-char (point-min))
563 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) 563 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
564 ;; Fontify some. 564 ;; Fontify some.
565 (goto-char (point-min)) 565 (goto-char (point-min))
566 (put-text-property (point-min) (point-max) 'face 'gnus-splash-face) 566 (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
567 (goto-char (point-min)) 567 (goto-char (point-min))
568 (setq modeline-buffer-identification 568 (setq modeline-buffer-identification
569 (list (concat gnus-version ": *Group*"))) 569 (list (concat gnus-version ": *Group*")))
570 (set-buffer-modified-p t))) 570 (set-buffer-modified-p t)))
571 571
572 572
573 ;;; The toolbar. 573 ;;; The toolbar.
578 "*If nil, do not use a toolbar. 578 "*If nil, do not use a toolbar.
579 If it is non-nil, it must be a toolbar. The five legal values are 579 If it is non-nil, it must be a toolbar. The five legal values are
580 `default-toolbar', `top-toolbar', `bottom-toolbar', 580 `default-toolbar', `top-toolbar', `bottom-toolbar',
581 `right-toolbar', and `left-toolbar'.") 581 `right-toolbar', and `left-toolbar'.")
582 582
583 (defvar gnus-group-toolbar 583 (defvar gnus-group-toolbar
584 '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] 584 '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
585 [gnus-group-get-new-news-this-group 585 [gnus-group-get-new-news-this-group
586 gnus-group-get-new-news-this-group t "Get new news in this group"] 586 gnus-group-get-new-news-this-group t "Get new news in this group"]
587 [gnus-group-catchup-current 587 [gnus-group-catchup-current
588 gnus-group-catchup-current t "Catchup group"] 588 gnus-group-catchup-current t "Catchup group"]
589 [gnus-group-describe-group 589 [gnus-group-describe-group
590 gnus-group-describe-group t "Describe group"] 590 gnus-group-describe-group t "Describe group"]
591 [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"] 591 [gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
592 [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"] 592 [gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
593 [gnus-group-kill-group gnus-group-kill-group t "Kill group"] 593 [gnus-group-kill-group gnus-group-kill-group t "Kill group"]
594 [gnus-group-exit gnus-group-exit t "Exit Gnus"] 594 [gnus-group-exit gnus-group-exit t "Exit Gnus"]
595 ) 595 )
596 "The group buffer toolbar.") 596 "The group buffer toolbar.")
597 597
598 (defvar gnus-summary-toolbar 598 (defvar gnus-summary-toolbar
599 '([gnus-summary-prev-unread 599 '([gnus-summary-prev-unread
600 gnus-summary-prev-unread-article t "Prev unread article"] 600 gnus-summary-prev-page-or-article t "Page up"]
601 [gnus-summary-next-unread 601 [gnus-summary-next-unread
602 gnus-summary-next-unread-article t "Next unread article"] 602 gnus-summary-next-page t "Page down"]
603 [gnus-summary-post-news 603 [gnus-summary-post-news
604 gnus-summary-post-news t "Post an article"] 604 gnus-summary-post-news t "Post an article"]
605 [gnus-summary-followup-with-original 605 [gnus-summary-followup-with-original
606 gnus-summary-followup-with-original t 606 gnus-summary-followup-with-original t
607 "Post a followup and yank the original"] 607 "Post a followup and yank the original"]
608 [gnus-summary-followup 608 [gnus-summary-followup
609 gnus-summary-followup t "Post a followup"] 609 gnus-summary-followup t "Post a followup"]
610 [gnus-summary-reply-with-original 610 [gnus-summary-reply-with-original
611 gnus-summary-reply-with-original t "Mail a reply and yank the original"] 611 gnus-summary-reply-with-original t "Mail a reply and yank the original"]
612 [gnus-summary-reply 612 [gnus-summary-reply
613 gnus-summary-reply t "Mail a reply"] 613 gnus-summary-reply t "Mail a reply"]
614 [gnus-summary-caesar-message 614 [gnus-summary-caesar-message
615 gnus-summary-caesar-message t "Rot 13"] 615 gnus-summary-caesar-message t "Rot 13"]
616 [gnus-uu-decode-uu 616 [gnus-uu-decode-uu
617 gnus-uu-decode-uu t "Decode uuencoded articles"] 617 gnus-uu-decode-uu t "Decode uuencoded articles"]
618 [gnus-summary-save-article-file 618 [gnus-summary-save-article-file
619 gnus-summary-save-article-file t "Save article in file"] 619 gnus-summary-save-article-file t "Save article in file"]
620 [gnus-summary-save-article 620 [gnus-summary-save-article
621 gnus-summary-save-article t "Save article"] 621 gnus-summary-save-article t "Save article"]
622 [gnus-uu-post-news 622 [gnus-uu-post-news
623 gnus-uu-post-news t "Post an uuencoded article"] 623 gnus-uu-post-news t "Post an uuencoded article"]
624 [gnus-summary-cancel-article 624 [gnus-summary-cancel-article
625 gnus-summary-cancel-article t "Cancel article"] 625 gnus-summary-cancel-article t "Cancel article"]
626 [gnus-summary-catchup 626 [gnus-summary-catchup
627 gnus-summary-catchup t "Catchup"] 627 gnus-summary-catchup t "Catchup"]
631 ) 631 )
632 "The summary buffer toolbar.") 632 "The summary buffer toolbar.")
633 633
634 (defvar gnus-summary-mail-toolbar 634 (defvar gnus-summary-mail-toolbar
635 '( 635 '(
636 [gnus-summary-prev-unread 636 [gnus-summary-prev-unread
637 gnus-summary-prev-unread-article t "Prev unread article"] 637 gnus-summary-prev-unread-article t "Prev unread article"]
638 [gnus-summary-next-unread 638 [gnus-summary-next-unread
639 gnus-summary-next-unread-article t "Next unread article"] 639 gnus-summary-next-unread-article t "Next unread article"]
640 [gnus-summary-mail-reply gnus-summary-reply t "Reply"] 640 [gnus-summary-mail-reply gnus-summary-reply t "Reply"]
641 ; [gnus-summary-mail-get gnus-mail-get t "Message get"] 641 ; [gnus-summary-mail-get gnus-mail-get t "Message get"]
642 [gnus-summary-mail-originate gnus-summary-post-news t "Originate"] 642 [gnus-summary-mail-originate gnus-summary-post-news t "Originate"]
643 [gnus-summary-mail-save gnus-summary-save-article t "Save"] 643 [gnus-summary-mail-save gnus-summary-save-article t "Save"]
697 "Display any XFace headers in the current article." 697 "Display any XFace headers in the current article."
698 (save-excursion 698 (save-excursion
699 (let (xface-glyph) 699 (let (xface-glyph)
700 (if (featurep 'xface) 700 (if (featurep 'xface)
701 (setq xface-glyph 701 (setq xface-glyph
702 (make-glyph (vector 'xface :data 702 (make-glyph (vector 'xface :data
703 (concat "X-Face: " 703 (concat "X-Face: "
704 (buffer-substring beg end))))) 704 (buffer-substring beg end)))))
705 (let ((cur (current-buffer))) 705 (let ((cur (current-buffer)))
706 (save-excursion 706 (save-excursion
707 (gnus-set-work-buffer) 707 (gnus-set-work-buffer)
715 (make-glyph 715 (make-glyph
716 (vector 'xpm :data (buffer-string ))))))) 716 (vector 'xpm :data (buffer-string )))))))
717 (set-glyph-face xface-glyph 'gnus-x-face) 717 (set-glyph-face xface-glyph 'gnus-x-face)
718 (goto-char (point-min)) 718 (goto-char (point-min))
719 (re-search-forward "^From:" nil t) 719 (re-search-forward "^From:" nil t)
720 (set-extent-begin-glyph 720 (set-extent-begin-glyph
721 (make-extent (point) (1+ (point))) xface-glyph)))) 721 (make-extent (point) (1+ (point))) xface-glyph))))
722 722
723 (defvar gnus-xmas-pointer-glyph 723 (defvar gnus-xmas-pointer-glyph
724 (progn 724 (progn
725 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 725 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
726 (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer." 726 (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer."
727 (if (featurep 'xpm) "xpm" "xbm"))))) 727 (if (featurep 'xpm) "xpm" "xbm")))))
728 728
729 (defvar gnus-xmas-modeline-left-extent 729 (defvar gnus-xmas-modeline-left-extent
730 (let ((ext (copy-extent modeline-buffer-id-left-extent))) 730 (let ((ext (copy-extent modeline-buffer-id-left-extent)))
731 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) 731 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
732 ext)) 732 ext))
733 733
734 (defvar gnus-xmas-modeline-right-extent 734 (defvar gnus-xmas-modeline-right-extent
735 (let ((ext (copy-extent modeline-buffer-id-right-extent))) 735 (let ((ext (copy-extent modeline-buffer-id-right-extent)))
736 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) 736 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
737 ext)) 737 ext))
738 738
739 (defvar gnus-xmas-modeline-glyph 739 (defvar gnus-xmas-modeline-glyph
759 ((not (string-match "^Gnus:" line)) 759 ((not (string-match "^Gnus:" line))
760 (list line)) 760 (list line))
761 ;; We have a standard line, so we colorize and glyphize it a bit. 761 ;; We have a standard line, so we colorize and glyphize it a bit.
762 (t 762 (t
763 (setq chop (match-end 0)) 763 (setq chop (match-end 0))
764 (list 764 (list
765 (if gnus-xmas-modeline-glyph 765 (if gnus-xmas-modeline-glyph
766 (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph) 766 (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
767 (cons gnus-xmas-modeline-left-extent (substring line 0 chop))) 767 (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
768 (cons gnus-xmas-modeline-right-extent (substring line chop))))))) 768 (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
769 769