X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=233912e585fd1f1687fd7276532e085f78f5f309;hb=be3efdf400634499a01f048533e13fb6915aec90;hp=54b8e8866a905078feedcc1ccf9cd4a667a58414;hpb=8e3b5632ec98e072544d84cabedc63039501243c;p=gnus diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index 54b8e8866..233912e58 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -1,7 +1,7 @@ ;;; gnus-xmas.el --- Gnus functions for XEmacs -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -20,8 +20,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -39,6 +39,7 @@ (defvar menu-bar-mode (featurep 'menubar)) (require 'messagexmas) (require 'wid-edit) +(require 'timer-funcs) (defgroup gnus-xmas nil "XEmacsoid support for Gnus" @@ -103,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))) @@ -256,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)) @@ -344,10 +331,6 @@ 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 (&optional prompt) "Get the next event." (when prompt @@ -400,10 +383,6 @@ call it with the value of the `gnus-data' text property." (defalias 'gnus-window-edges 'window-pixel-edges) (defalias 'gnus-assq-delete-all 'gnus-xmas-assq-delete-all) - (if (and (<= emacs-major-version 19) - (< emacs-minor-version 14)) - (defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties)) - (unless (boundp 'standard-display-table) (setq standard-display-table nil)) @@ -424,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." @@ -437,8 +419,8 @@ 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 @@ -448,23 +430,19 @@ call it with the value of the `gnus-data' text property." (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-mime-security-button-menu + 'gnus-xmas-mime-security-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 ;; where each variable is defined, in order not to mess with user settings. ;; -- 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) @@ -541,7 +519,7 @@ call it with the value of the `gnus-data' text property." (rest (- wheight pheight))) (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))) ;; Paint it. - (put-text-property (point-min) (point-max) 'face 'gnus-splash-face))) + (put-text-property (point-min) (point-max) 'face 'gnus-splash))) (setq modeline-buffer-identification (list (concat gnus-version ": *Group*"))) (set-buffer-modified-p t)) @@ -549,17 +527,53 @@ call it with the value of the `gnus-data' text property." ;;; The toolbar. -(defcustom gnus-use-toolbar (if (featurep 'toolbar) - 'default-toolbar - nil) - "*If nil, do not use a toolbar. -If it is non-nil, it must be a toolbar. The five valid values are -`default-toolbar', `top-toolbar', `bottom-toolbar', -`right-toolbar', and `left-toolbar'." - :type '(choice (const default-toolbar) - (const top-toolbar) (const bottom-toolbar) - (const left-toolbar) (const right-toolbar) +(defun gnus-xmas-update-toolbars () + "Update the toolbars' appearance." + (when (and (not noninteractive) + (featurep 'gnus-xmas)) + (save-excursion + (dolist (buffer (buffer-list)) + (set-buffer buffer) + (cond ((eq major-mode 'gnus-group-mode) + (gnus-xmas-setup-group-toolbar)) + ((eq major-mode 'gnus-summary-mode) + (gnus-xmas-setup-summary-toolbar))))))) + +(defcustom gnus-use-toolbar (if (featurep 'toolbar) 'default) + "*Position to display the toolbar. Nil means do not use a toolbar. +If it is non-nil, it should be one of the symbols `default', `top', +`bottom', `right', and `left'. `default' means to use the default +toolbar, the rest mean to display the toolbar on the place which those +names show." + :type '(choice (const default) + (const top) (const bottom) (const left) (const right) (const :tag "no toolbar" nil)) + :set (lambda (symbol value) + (set-default + symbol + (if (or (not value) + (memq value (list 'default 'top 'bottom 'right 'left))) + value + 'default)) + (gnus-xmas-update-toolbars)) + :group 'gnus-xmas) + +(defcustom gnus-toolbar-thickness + (if (featurep 'toolbar) + (cons (specifier-instance default-toolbar-height) + (specifier-instance default-toolbar-width))) + "*Cons of the height and the width specifying the thickness of a toolbar. +The height is used for the toolbar displayed on the top or the bottom, +the width is used for the toolbar displayed on the right or the left." + :type '(cons :tag "height & width" + (integer :tag "height") (integer :tag "width")) + :set (lambda (symbol value) + (set-default + symbol + (if (and (consp value) (natnump (car value)) (natnump (cdr value))) + value + '(37 . 40))) + (gnus-xmas-update-toolbars)) :group 'gnus-xmas) (defvar gnus-group-toolbar @@ -641,19 +655,57 @@ If it is non-nil, it must be a toolbar. The five valid values are [gnus-summary-exit gnus-summary-exit t "Exit this summary"]) "The summary buffer mail toolbar.") +(defun gnus-xmas-setup-toolbar (toolbar) + (when (featurep 'toolbar) + (if (and gnus-use-toolbar + (message-xmas-setup-toolbar toolbar nil "gnus")) + (let ((bar (or (intern-soft (format "%s-toolbar" gnus-use-toolbar)) + 'default-toolbar)) + (height (car gnus-toolbar-thickness)) + (width (cdr gnus-toolbar-thickness)) + (cur (current-buffer)) + bars) + (set-specifier (symbol-value bar) toolbar cur) + (set-specifier default-toolbar-height height cur) + (set-specifier default-toolbar-width width cur) + (set-specifier top-toolbar-height height cur) + (set-specifier bottom-toolbar-height height cur) + (set-specifier right-toolbar-width width cur) + (set-specifier left-toolbar-width width cur) + (if (eq bar 'default-toolbar) + (progn + (remove-specifier default-toolbar-visible-p cur) + (remove-specifier top-toolbar cur) + (remove-specifier top-toolbar-visible-p cur) + (remove-specifier bottom-toolbar cur) + (remove-specifier bottom-toolbar-visible-p cur) + (remove-specifier right-toolbar cur) + (remove-specifier right-toolbar-visible-p cur) + (remove-specifier left-toolbar cur) + (remove-specifier left-toolbar-visible-p cur)) + (set-specifier (symbol-value (intern (format "%s-visible-p" bar))) + t cur) + (setq bars (delq bar (list 'default-toolbar + 'bottom-toolbar 'top-toolbar + 'right-toolbar 'left-toolbar))) + (while bars + (set-specifier (symbol-value (intern (format "%s-visible-p" + (pop bars)))) + nil cur)))) + (let ((cur (current-buffer))) + (set-specifier default-toolbar-visible-p nil cur) + (set-specifier top-toolbar-visible-p nil cur) + (set-specifier bottom-toolbar-visible-p nil cur) + (set-specifier right-toolbar-visible-p nil cur) + (set-specifier left-toolbar-visible-p nil cur))))) + (defun gnus-xmas-setup-group-toolbar () - (and gnus-use-toolbar - (message-xmas-setup-toolbar gnus-group-toolbar nil "gnus") - (set-specifier (symbol-value gnus-use-toolbar) - (cons (current-buffer) gnus-group-toolbar)))) + (gnus-xmas-setup-toolbar gnus-group-toolbar)) (defun gnus-xmas-setup-summary-toolbar () - (let ((bar (if (gnus-news-group-p gnus-newsgroup-name) - gnus-summary-toolbar gnus-summary-mail-toolbar))) - (and gnus-use-toolbar - (message-xmas-setup-toolbar bar nil "gnus") - (set-specifier (symbol-value gnus-use-toolbar) - (cons (current-buffer) bar))))) + (gnus-xmas-setup-toolbar (if (gnus-news-group-p gnus-newsgroup-name) + gnus-summary-toolbar + gnus-summary-mail-toolbar))) (defun gnus-xmas-mail-strip-quoted-names (address) "Protect mail-strip-quoted-names from nil input. @@ -734,10 +786,25 @@ XEmacs compatibility workaround." (goto-char (event-point event)) (funcall (event-function response) (event-object response)))) +(defun gnus-xmas-mime-security-button-menu (event prefix) + "Construct a context-sensitive menu of security commands." + (interactive "e\nP") + (let ((response + (get-popup-menu-response + `("Security Part" + ,@(delq nil + (mapcar (lambda (c) + (unless (eq (car c) 'undefined) + `[,(caddr c) ,(car c) t])) + gnus-mime-security-button-commands)))))) + (set-buffer (event-buffer event)) + (goto-char (event-point event)) + (funcall (event-function response) (event-object response)))) + (defun gnus-group-add-icon () "Add an icon to the current line according to `gnus-group-icon-list'." (let* ((p (point)) - (end (gnus-point-at-eol)) + (end (point-at-eol)) ;; now find out where the line starts and leave point there. (beg (progn (beginning-of-line) (point)))) (save-restriction @@ -861,39 +928,15 @@ Warning: Don't insert text immediately after the image." glyph) (defun gnus-xmas-remove-image (image &optional category) + "Remove the image matching IMAGE and CATEGORY found first." (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) + (set-extent-property ext 'end-glyph nil) + t)) nil nil nil nil nil 'gnus-image category)) -(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)) - -;; This macro is because XEmacs versions prior to 21.2 do not have the -;; PROTOCOL argument to `open-network-stream'. -(defmacro gnus-xmas-open-network-stream (name buffer host service &optional protocol) - "Like `open-network-stream' but take into account older XEmacs versions." - (if (and (featurep 'xemacs) - (fboundp 'open-network-stream) - (emacs-version>= 21 2)) - `(open-network-stream ,name ,buffer ,host ,service ,protocol) - `(open-network-stream ,name ,buffer ,host ,service))) - (defun gnus-xmas-assq-delete-all (key alist) (let ((elem nil)) (while (setq elem (assq key alist)) @@ -902,4 +945,5 @@ Warning: Don't insert text immediately after the image." (provide 'gnus-xmas) +;;; arch-tag: 4e84de3f-ea0a-4ee3-bfeb-e03d46fcacef ;;; gnus-xmas.el ends here