;;; 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, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(gnus-xmas-menu-add grouplens
gnus-grouplens-menu))
-(defun gnus-xmas-read-event-char ()
+(defun gnus-xmas-read-event-char (&optional prompt)
"Get the next event."
+ (when prompt
+ (message "%s" prompt))
(let ((event (next-command-event)))
(sit-for 0)
;; We junk all non-key events. Is this naughty?
(defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
(defalias 'gnus-deactivate-mark 'ignore)
(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-mark-active-p 'region-exists-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-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
;; where each variable is defined, in order not to mess with user settings.
:color-symbols
(("thing" . ,(car gnus-logo-colors))
("shadow" . ,(cadr gnus-logo-colors))
+ ("oort" . "#eeeeee")
("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 (data)
- "Display any XFace headers in BUFFER."
- (save-excursion
- (let ((xface-glyph
- (cond
- ((featurep 'xface)
- (make-glyph (vector 'xface :data
- (concat "X-Face: " data))))
- ((featurep 'xpm)
- (let ((cur (or buffer (current-buffer))))
- (save-excursion
- (gnus-set-work-buffer)
- (insert data)
- (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-mailing-list-menu))
(defun gnus-xmas-image-type-available-p (type)
- (featurep type))
-
-(defun gnus-xmas-create-image (file)
- (with-temp-buffer
- (insert-file-contents file)
- (mm-create-image-xemacs (car (last (split-string file "[.]"))))))
+ (and window-system
+ (featurep (if (eq type 'pbm) 'xbm 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)
- (let ((annot (make-annotation glyph nil 'text)))
- (set-extent-property annot 'mm t)
- (set-extent-property annot 'duplicable t)))
+ "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)
projects / gnus / blobdiff