X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=fff2c223df89dbe4327feba15f356e415eb817cb;hb=d39d0135ddafb8f379ae99f2d524112ce222f277;hp=a183f79914032bd8ff7c4d215ac1e3ccee443a96;hpb=009197f9cb0346f02bb1e442ccd2efdaa82e8a71;p=gnus diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index a183f7991..fff2c223d 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, 2002 +;; 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))) @@ -340,8 +335,10 @@ call it with the value of the `gnus-data' text property." (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 +385,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 +407,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." @@ -427,13 +424,14 @@ call it with the value of the `gnus-data' text property." (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) @@ -473,6 +471,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]) @@ -555,6 +554,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.") @@ -612,6 +613,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 @@ -645,45 +648,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 the XFace in DATA." - (save-excursion - (let ((xface-glyph - (cond - ((featurep 'xface) - (make-glyph (vector 'xface :data - (concat "X-Face: " data)))) - ((featurep 'xpm) - (let ((cur (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]))))) - (set-glyph-face xface-glyph 'gnus-x-face) - - (gnus-article-goto-header "from") - ;;(gnus-put-image xface-glyph " ") - (let ((extent (make-extent (1- (point)) (point)))) - (set-extent-property extent 'gnus-image t) - (set-extent-property extent 'duplicable t) - (set-extent-property extent 'end-glyph xface-glyph)) - (gnus-add-wash-type 'xface) - (gnus-add-image 'xface xface-glyph)))) - (defvar gnus-xmas-modeline-left-extent (let ((ext (copy-extent modeline-buffer-id-left-extent))) ext)) @@ -740,9 +704,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]) @@ -754,7 +718,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 @@ -824,44 +788,73 @@ XEmacs compatibility workaround." gnus-mailing-list-menu)) (defun gnus-xmas-image-type-available-p (type) - (featurep type)) + (and window-system + (featurep (if (eq type 'pbm) 'xbm type)))) -(defun gnus-xmas-create-image (file &optional type data-p) +(defun gnus-xmas-create-image (file &optional type data-p &rest props) (let ((type (if type (symbol-name type) - (car (last (split-string file "[.]")))))) - (if (equal type "xbm") - (make-glyph (list (cons 'x file))) + (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)) - (make-glyph - (vector - (or (mm-image-type-from-buffer) - (intern type)) - :data (buffer-string))))))) - -(defun gnus-xmas-put-image (glyph &optional string) + (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) - (insert (or string " ")) + (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 'gnus-image category) (set-extent-property extent 'duplicable t) - (set-extent-property extent 'invisible t) - (set-extent-property extent 'end-glyph glyph))) + (if string + (set-extent-property extent 'invisible t)) + (set-extent-property extent 'end-glyph glyph)) + glyph) -(defun gnus-xmas-remove-image (image) +(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)) + 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)