;;; gnus-xmas.el --- Gnus functions for XEmacs
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(error "Can't find glyph directory. \
Possibly the `etc' directory has not been installed.")))
-;;(format "%02x%02x%02x" 114 66 20) "724214"
-
-(defvar gnus-xmas-logo-color-alist
- '((flame "#cc3300" "#ff2200")
- (pine "#c0cc93" "#f8ffb8")
- (moss "#a1cc93" "#d2ffb8")
- (irish "#04cc90" "#05ff97")
- (sky "#049acc" "#05deff")
- (tin "#6886cc" "#82b6ff")
- (velvet "#7c68cc" "#8c82ff")
- (grape "#b264cc" "#cf7df")
- (labia "#cc64c2" "#fd7dff")
- (berry "#cc6485" "#ff7db5")
- (dino "#724214" "#1e3f03")
- (neutral "#b4b4b4" "#878787")
- (september "#bf9900" "#ffcc00"))
- "Color alist used for the Gnus logo.")
-
-(defcustom gnus-xmas-logo-color-style 'dino
- "*Color styles used for the Gnus logo."
- :type '(choice (const flame) (const pine) (const moss)
- (const irish) (const sky) (const tin)
- (const velvet) (const grape) (const labia)
- (const berry) (const neutral) (const september)
- (const dino))
- :group 'gnus-xmas)
-
-(defvar gnus-xmas-logo-colors
- (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
- "Colors used for the Gnus logo.")
-
;;; Internal variables.
;; Don't warn about these undefined variables.
(defalias 'gnus-window-edges 'window-pixel-edges)
(if (and (<= emacs-major-version 19)
- (< emacs-minor-version 14))
+ (< emacs-minor-version 14))
(defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
(unless (boundp 'standard-display-table)
(defalias 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
(defalias 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
(defalias 'gnus-appt-select-lowest-window
- 'gnus-xmas-appt-select-lowest-window)
+ 'gnus-xmas-appt-select-lowest-window)
(defalias 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
(defalias 'gnus-character-to-event 'character-to-event)
(defalias 'gnus-mode-line-buffer-identification
- 'gnus-xmas-mode-line-buffer-identification)
+ 'gnus-xmas-mode-line-buffer-identification)
(defalias 'gnus-key-press-event-p 'key-press-event-p)
(defalias 'gnus-region-active-p 'region-active-p)
(defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
(defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
+ (defalias 'gnus-image-type-available-p 'gnus-xmas-image-type-available-p)
+ (defalias 'gnus-put-image 'gnus-xmas-put-image)
+ (defalias 'gnus-create-image 'gnus-xmas-create-image)
+ (defalias 'gnus-remove-image 'gnus-xmas-remove-image)
+
+ (when (or (< emacs-major-version 21)
+ (and (= emacs-major-version 21)
+ (< emacs-minor-version 3)))
+ (defalias 'gnus-completing-read 'gnus-xmas-completing-read))
;; These ones are not defcutom'ed, sometimes not even defvar'ed. They
;; probably should. If that is done, the code below should then be moved
`[xpm
:file ,logo-xpm
:color-symbols
- (("thing" . ,(car gnus-xmas-logo-colors))
- ("shadow" . ,(cadr gnus-xmas-logo-colors))
+ (("thing" . ,(car gnus-logo-colors))
+ ("shadow" . ,(cadr gnus-logo-colors))
("background" . ,(face-background 'default)))])
((featurep 'xbm)
`[xbm :file ,logo-xbm])
[gnus-group-unsubscribe gnus-group-unsubscribe t "Unsubscribe group"]
[gnus-group-subscribe gnus-group-subscribe t "Subscribe group"]
[gnus-group-kill-group gnus-group-kill-group t "Kill group"]
+ [gnus-summary-mail-save
+ gnus-group-save-newsrc t "Save .newsrc files"] ; borrowed icon.
[gnus-group-exit gnus-group-exit t "Exit Gnus"])
"The group buffer toolbar.")
gnus-summary-save-article-file t "Save article in file"]
[gnus-summary-save-article
gnus-summary-save-article t "Save article"]
+ [gnus-summary-cancel-article ; usenet : cancellation :: mail : deletion.
+ gnus-summary-delete-article t "Delete message"]
[gnus-summary-catchup
gnus-summary-catchup t "Catchup"]
[gnus-summary-catchup-and-exit
'call-process-region (point-min) (point-max) command t '(t nil) nil
args))
-(defface gnus-x-face '((t (:foreground "black" :background "white")))
- "Face to show X face"
- :group 'gnus-xmas)
-
-(defun gnus-xmas-article-display-xface (beg end &optional buffer)
- "Display any XFace headers in BUFFER."
- (save-excursion
- (let ((xface-glyph
- (cond
- ((featurep 'xface)
- (make-glyph (vector 'xface :data
- (concat "X-Face: "
- (if buffer
- (with-current-buffer buffer
- (buffer-substring beg end))
- (buffer-substring beg end))))))
- ((featurep 'xpm)
- (let ((cur (or buffer (current-buffer))))
- (save-excursion
- (gnus-set-work-buffer)
- (insert-buffer-substring cur beg end)
- (let ((coding-system-for-read 'binary)
- (coding-system-for-write 'binary))
- (gnus-xmas-call-region "uncompface")
- (goto-char (point-min))
- (insert "/* Width=48, Height=48 */\n")
- (gnus-xmas-call-region "icontopbm")
- (gnus-xmas-call-region "ppmtoxpm")
- (make-glyph
- (vector 'xpm :data (buffer-string)))))))
- (t
- (make-glyph [nothing]))))
- (ext (make-extent (progn
- (goto-char (point-min))
- (re-search-forward "^From:" nil t)
- (point))
- (1+ (point)))))
- (set-glyph-face xface-glyph 'gnus-x-face)
- (set-extent-begin-glyph ext xface-glyph)
- (set-extent-property ext 'duplicable t))))
-
(defvar gnus-xmas-modeline-left-extent
(let ((ext (copy-extent modeline-buffer-id-left-extent)))
ext))
(gnus-xmas-menu-add mailing-list
gnus-mailing-list-menu))
+(defun gnus-xmas-image-type-available-p (type)
+ (when (eq type 'pbm)
+ (setq type 'xbm))
+ (featurep type))
+
+(defun gnus-xmas-create-image (file &optional type data-p &rest props)
+ (let ((type (if type
+ (symbol-name type)
+ (car (last (split-string file "[.]")))))
+ (face (plist-get props :face))
+ glyph)
+ (when (equal type "pbm")
+ (with-temp-buffer
+ (if data-p
+ (insert file)
+ (insert-file-contents file))
+ (shell-command-on-region (point-min) (point-max)
+ "ppmtoxpm 2>/dev/null" t)
+ (setq file (buffer-string)
+ type "xpm"
+ data-p t)))
+ (setq glyph
+ (if (equal type "xbm")
+ (make-glyph (list (cons 'x file)))
+ (with-temp-buffer
+ (if data-p
+ (insert file)
+ (insert-file-contents file))
+ (make-glyph
+ (vector
+ (or (intern type)
+ (mm-image-type-from-buffer))
+ :data (buffer-string))))))
+ (when face
+ (set-glyph-face glyph face))
+ glyph))
+
+(defun gnus-xmas-put-image (glyph &optional string)
+ "Insert STRING, but display GLYPH.
+Warning: Don't insert text immediately after the image."
+ (let ((begin (point))
+ extent)
+ (if (and (bobp) (not string))
+ (setq string " "))
+ (if string
+ (insert string)
+ (setq begin (1- begin)))
+ (setq extent (make-extent begin (point)))
+ (set-extent-property extent 'gnus-image t)
+ (set-extent-property extent 'duplicable t)
+ (if string
+ (set-extent-property extent 'invisible t))
+ (set-extent-property extent 'end-glyph glyph))
+ glyph)
+
+(defun gnus-xmas-remove-image (image)
+ (map-extents
+ (lambda (ext unused)
+ (when (equal (extent-end-glyph ext) image)
+ (set-extent-property ext 'invisible nil)
+ (set-extent-property ext 'end-glyph nil))
+ nil)
+ nil nil nil nil nil 'gnus-image))
+
+(defun gnus-xmas-completing-read (prompt table &optional
+ predicate require-match history)
+ (when (and history
+ (not (boundp history)))
+ (set history nil))
+ (completing-read
+ (if (symbol-value history)
+ (concat prompt " (" (car (symbol-value history)) "): ")
+ (concat prompt ": "))
+ table
+ predicate
+ require-match
+ nil
+ history))
+
(provide 'gnus-xmas)
;;; gnus-xmas.el ends here
projects / gnus / blobdiff