X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=6f0a2a1d7f21fb8c7c47935ebcc03ce0ef0fe512;hb=6a25cffa8161aedf763c884fcc612080939437c8;hp=d16841e72d7abdb5ed8213ab34ce367435bb3374;hpb=c9173857852350261b1b8c12510414f81ccab25e;p=gnus diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index d16841e72..6f0a2a1d7 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -1,6 +1,6 @@ ;;; 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 @@ -27,10 +27,19 @@ ;;; Code: +(eval-when-compile + (autoload 'gnus-active "gnus" nil nil 'macro) + (autoload 'gnus-group-entry "gnus" nil nil 'macro) + (autoload 'gnus-info-level "gnus" nil nil 'macro) + (autoload 'gnus-info-marks "gnus" nil nil 'macro) + (autoload 'gnus-info-method "gnus" nil nil 'macro) + (autoload 'gnus-info-score "gnus" nil nil 'macro)) + (require 'text-props) (defvar menu-bar-mode (featurep 'menubar)) (require 'messagexmas) (require 'wid-edit) +(require 'run-at-time) (defgroup gnus-xmas nil "XEmacsoid support for Gnus" @@ -95,27 +104,13 @@ Possibly the `etc' directory has not been installed."))) (defvar standard-display-table) (defvar gnus-tree-minimize-window) -(defun gnus-xmas-set-text-properties (start end props &optional buffer) - "You should NEVER use this function. It is ideologically blasphemous. -It is provided only to ease porting of broken FSF Emacs programs." - (if (stringp buffer) - nil - (map-extents (lambda (extent ignored) - (remove-text-properties - start end - (list (extent-property extent 'text-prop) nil) - buffer) - nil) - buffer start end nil nil 'text-prop) - (gnus-add-text-properties start end props buffer))) - (defun gnus-xmas-highlight-selected-summary () ;; Highlight selected article in summary buffer (when gnus-summary-selected-face (when gnus-newsgroup-selected-overlay (delete-extent gnus-newsgroup-selected-overlay)) (setq gnus-newsgroup-selected-overlay - (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) + (make-extent (point-at-bol) (point-at-eol))) (set-extent-face gnus-newsgroup-selected-overlay gnus-summary-selected-face))) @@ -248,7 +243,7 @@ call it with the value of the `gnus-data' text property." (select-window selected)))))) ;; Select the lowest window on the frame. -(defun gnus-xmas-appt-select-lowest-window () +(defun gnus-xmas-select-lowest-window () (let* ((lowest-window (selected-window)) (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges)))))) (last-window (previous-window)) @@ -336,12 +331,10 @@ call it with the value of the `gnus-data' text property." (gnus-xmas-menu-add browse gnus-browse-menu)) -(defun gnus-xmas-grouplens-menu-add () - (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? @@ -388,10 +381,7 @@ call it with the value of the `gnus-data' text property." (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)) - (defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) + (defalias 'gnus-assq-delete-all 'gnus-xmas-assq-delete-all) (unless (boundp 'standard-display-table) (setq standard-display-table nil)) @@ -413,7 +403,10 @@ call it with the value of the `gnus-data' text property." 'x-color-values (lambda (color) (color-instance-rgb-components - (make-color-instance color)))))) + (make-color-instance color))))) + + (unless (fboundp 'char-width) + (defalias 'char-width (lambda (ch) 1)))) (defun gnus-xmas-redefine () "Redefine lots of Gnus functions for XEmacs." @@ -426,19 +419,21 @@ call it with the value of the `gnus-data' text property." (defalias 'gnus-read-event-char 'gnus-xmas-read-event-char) (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) + (defalias 'gnus-select-lowest-window + 'gnus-xmas-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-put-image 'gnus-xmas-put-image) (defalias 'gnus-create-image 'gnus-xmas-create-image) + (defalias 'gnus-remove-image 'gnus-xmas-remove-image) ;; 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 @@ -446,7 +441,6 @@ call it with the value of the `gnus-data' text property." ;; -- didier (add-hook 'gnus-score-mode-hook 'gnus-xmas-score-menu-add) (add-hook 'gnus-binary-mode-hook 'gnus-xmas-binary-menu-add) - (add-hook 'gnus-grouplens-mode-hook 'gnus-xmas-grouplens-menu-add) (add-hook 'gnus-server-mode-hook 'gnus-xmas-server-menu-add) (add-hook 'gnus-browse-mode-hook 'gnus-xmas-browse-menu-add) (add-hook 'gnus-draft-mode-hook 'gnus-xmas-draft-menu-add) @@ -472,6 +466,7 @@ call it with the value of the `gnus-data' text property." :color-symbols (("thing" . ,(car gnus-logo-colors)) ("shadow" . ,(cadr gnus-logo-colors)) + ("oort" . "#eeeeee") ("background" . ,(face-background 'default)))]) ((featurep 'xbm) `[xbm :file ,logo-xbm]) @@ -554,6 +549,8 @@ If it is non-nil, it must be a toolbar. The five valid values are [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.") @@ -611,6 +608,8 @@ If it is non-nil, it must be a toolbar. The five valid values are 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 @@ -644,43 +643,6 @@ XEmacs compatibility workaround." '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)) @@ -737,9 +699,9 @@ XEmacs compatibility workaround." (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t) (text-property-any b e 'gnus-undeletable t)))) -(defun gnus-xmas-mime-button-menu (event) +(defun gnus-xmas-mime-button-menu (event prefix) "Construct a context-sensitive menu of MIME commands." - (interactive "e") + (interactive "e\nP") (let ((response (get-popup-menu-response `("MIME Part" ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t]) @@ -751,7 +713,7 @@ XEmacs compatibility workaround." (defun gnus-group-add-icon () "Add an icon to the current line according to `gnus-group-icon-list'." (let* ((p (point)) - (end (progn (end-of-line) (point))) + (end (point-at-eol)) ;; now find out where the line starts and leave point there. (beg (progn (beginning-of-line) (point)))) (save-restriction @@ -821,18 +783,75 @@ XEmacs compatibility workaround." 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 "[.]")))))) - -(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))) + (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-literally 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-literally 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 category) + "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 category) + (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 &optional category) + (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 category)) + +(defun gnus-xmas-assq-delete-all (key alist) + (let ((elem nil)) + (while (setq elem (assq key alist)) + (setq alist (delq elem alist))) + alist)) (provide 'gnus-xmas) +;;; arch-tag: 4e84de3f-ea0a-4ee3-bfeb-e03d46fcacef ;;; gnus-xmas.el ends here