Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-xmas.el @ 155:43dd3413c7c7 r20-3b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b4
author cvs
date Mon, 13 Aug 2007 09:39:39 +0200
parents b980b6286996
children 0132846995bd
comparison
equal deleted inserted replaced
154:94141801dd7e 155:43dd3413c7c7
506 (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add) 506 (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add)
507 507
508 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar) 508 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
509 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) 509 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
510 510
511 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off) 511 (add-hook 'gnus-summary-mode-hook
512 512 'gnus-xmas-switch-horizontal-scrollbar-off))
513 (when (and (<= emacs-major-version 19)
514 (<= emacs-minor-version 13))
515 (setq gnus-article-x-face-too-ugly (when (eq (device-type) 'tty)
516 "."))
517 (fset 'gnus-highlight-selected-summary
518 'gnus-xmas-highlight-selected-summary)
519 (fset 'gnus-group-remove-excess-properties
520 'gnus-xmas-group-remove-excess-properties)
521 (fset 'gnus-topic-remove-excess-properties
522 'gnus-xmas-topic-remove-excess-properties)
523 (fset 'gnus-mode-line-buffer-identification 'identity)
524 (unless (boundp 'shell-command-switch)
525 (setq shell-command-switch "-c"))))
526 513
527 514
528 ;;; XEmacs logo and toolbar. 515 ;;; XEmacs logo and toolbar.
529 516
530 (defun gnus-xmas-group-startup-message (&optional x y) 517 (defun gnus-xmas-group-startup-message (&optional x y)
531 "Insert startup message in current buffer." 518 "Insert startup message in current buffer."
532 ;; Insert the message. 519 ;; Insert the message.
533 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 520 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
534 (erase-buffer) 521 (erase-buffer)
535 (let ((logo (and gnus-xmas-glyph-directory 522 (cond
536 (concat 523 ((and (console-on-window-system-p)
537 (file-name-as-directory gnus-xmas-glyph-directory) 524 (or (featurep 'xpm)
538 "gnus." 525 (featurep 'xbm)))
539 (if (featurep 'xpm) "xpm" "xbm")))) 526 (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
540 (xpm-color-symbols 527 (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
541 (and (featurep 'xpm) 528 (glyph (make-glyph
542 (append `(("thing" ,(car gnus-xmas-logo-colors)) 529 (list
543 ("shadow" ,(cadr gnus-xmas-logo-colors))) 530 (vector 'xpm
544 xpm-color-symbols)))) 531 ':file logo-xpm
545 (if (and (featurep 'xpm) 532 ':color-symbols
546 (not (equal (device-type) 'tty)) 533 `(("thing" . ,(car gnus-xmas-logo-colors))
547 logo 534 ("shadow" . ,(cadr gnus-xmas-logo-colors))
548 (file-exists-p logo)) 535 ("background" . ,(face-background 'default))))
549 (progn 536 (vector 'xbm :file logo-xbm)
550 (setq logo (make-glyph logo)) 537 (vector 'nothing)))))
551 (insert " ") 538 (insert " ")
552 (set-extent-begin-glyph (make-extent (point) (point)) logo) 539 (set-extent-begin-glyph (make-extent (point) (point)) glyph)
553 (goto-char (point-min)) 540 (goto-char (point-min))
554 (while (not (eobp)) 541 (while (not (eobp))
555 (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2) 542 (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
556 ? )) 543 ?\ ))
557 (forward-line 1)) 544 (forward-line 1)))
558 (goto-char (point-min)) 545 (goto-char (point-min))
559 (let* ((pheight (+ 20 (count-lines (point-min) (point-max)))) 546 (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
560 (wheight (window-height)) 547 (wheight (window-height))
561 (rest (- wheight pheight))) 548 (rest (- wheight pheight)))
562 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))) 549 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
563 550 (t
564 (insert 551 (insert
565 (format " %s 552 (format " %s
566 _ ___ _ _ 553 _ ___ _ _
567 _ ___ __ ___ __ _ ___ 554 _ ___ __ ___ __ _ ___
568 __ _ ___ __ ___ 555 __ _ ___ __ ___
569 _ ___ _ 556 _ ___ _
570 _ _ __ _ 557 _ _ __ _
580 _ _ 567 _ _
581 _ 568 _
582 __ 569 __
583 570
584 " 571 "
585 "")) 572 ""))
586 ;; And then hack it. 573 ;; And then hack it.
587 (gnus-indent-rigidly (point-min) (point-max) 574 (gnus-indent-rigidly (point-min) (point-max)
588 (/ (max (- (window-width) (or x 46)) 0) 2)) 575 (/ (max (- (window-width) (or x 46)) 0) 2))
589 (goto-char (point-min))
590 (forward-line 1)
591 (let* ((pheight (count-lines (point-min) (point-max)))
592 (wheight (window-height))
593 (rest (- wheight pheight)))
594 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
595 ;; Fontify some.
596 (goto-char (point-min)) 576 (goto-char (point-min))
597 (put-text-property (point-min) (point-max) 'face 'gnus-splash-face) 577 (forward-line 1)
598 (goto-char (point-min)) 578 (let* ((pheight (count-lines (point-min) (point-max)))
599 (setq modeline-buffer-identification 579 (wheight (window-height))
600 (list (concat gnus-version ": *Group*"))) 580 (rest (- wheight pheight)))
601 (set-buffer-modified-p t))) 581 (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
582 ;; Paint it.
583 (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
584 (setq modeline-buffer-identification
585 (list (concat gnus-version ": *Group*")))
586 (set-buffer-modified-p t))
602 587
603 588
604 ;;; The toolbar. 589 ;;; The toolbar.
605 590
606 (defcustom gnus-use-toolbar (if (featurep 'toolbar) 591 (defcustom gnus-use-toolbar (if (featurep 'toolbar)
751 (goto-char (point-min)) 736 (goto-char (point-min))
752 (re-search-forward "^From:" nil t) 737 (re-search-forward "^From:" nil t)
753 (set-extent-begin-glyph 738 (set-extent-begin-glyph
754 (make-extent (point) (1+ (point))) xface-glyph)))) 739 (make-extent (point) (1+ (point))) xface-glyph))))
755 740
756 (defvar gnus-xmas-pointer-glyph 741 ;;(defvar gnus-xmas-pointer-glyph
757 (progn 742 ;; (progn
758 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 743 ;; (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory
759 (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer." 744 ;; "gnus"))
760 (if (featurep 'xpm) "xpm" "xbm"))))) 745 ;; (let ((file-xpm (expand-file-name "gnus-pointer.xpm"
746 ;; gnus-xmas-glyph-directory))
747 ;; (file-xbm (expand-file-name "gnus-pointer.xbm"
748 ;; gnus-xmas-glyph-directory)))
749 ;; (make-pointer-glyph
750 ;; (list (vector 'xpm ':file file-xpm)
751 ;; (vector 'xbm ':file file-xbm))))))
761 752
762 (defvar gnus-xmas-modeline-left-extent 753 (defvar gnus-xmas-modeline-left-extent
763 (let ((ext (copy-extent modeline-buffer-id-left-extent))) 754 (let ((ext (copy-extent modeline-buffer-id-left-extent)))
764 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) 755 ; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
765 ext)) 756 ext))
766 757
767 (defvar gnus-xmas-modeline-right-extent 758 (defvar gnus-xmas-modeline-right-extent
768 (let ((ext (copy-extent modeline-buffer-id-right-extent))) 759 (let ((ext (copy-extent modeline-buffer-id-right-extent)))
769 ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph) 760 ; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
770 ext)) 761 ext))
771 762
772 (defvar gnus-xmas-modeline-glyph 763 (defvar gnus-xmas-modeline-glyph
773 (progn 764 (progn
774 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus")) 765 (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
775 (let* ((file (concat gnus-xmas-glyph-directory "gnus-pointer." 766 (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
776 (if (featurep 'xpm) "xpm" "xbm"))) 767 gnus-xmas-glyph-directory))
777 (glyph (make-glyph file))) 768 (file-xbm (expand-file-name "gnus-pointer.xbm"
778 (when (and (featurep 'x) 769 gnus-xmas-glyph-directory))
779 (file-exists-p file)) 770 (glyph (make-glyph
780 (set-glyph-face glyph 'modeline-buffer-id) 771 (list
781 (set-glyph-property glyph 'image (cons 'tty "Gnus:")) 772 ;; Let's try a nifty XPM
782 glyph)))) 773 (vector 'xpm ':file file-xpm)
774 ;; Then a not-so-nifty XBM
775 (vector 'xbm ':file file-xbm)
776 ;; Then the simple string
777 (vector 'string ':data "Gnus:")))))
778 (set-glyph-face glyph 'modeline-buffer-id)
779 glyph)))
783 780
784 (defun gnus-xmas-mode-line-buffer-identification (line) 781 (defun gnus-xmas-mode-line-buffer-identification (line)
785 (let ((line (car line)) 782 (let ((line (car line))
786 chop) 783 chop)
787 (cond 784 (cond