X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-ems.el;h=aed735fe2ce48ec058d60e7fdb119bcd0d773dcd;hb=75880493a6a9dad9607a4002d4c6ab2895b110ca;hp=732fbe54c49dded209f3a74e4ecfc0d5efc2e2fd;hpb=d048be25d5e08f2ba33377c19350b647247f6fed;p=gnus diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el index 732fbe54c..aed735fe2 100644 --- a/lisp/gnus-ems.el +++ b/lisp/gnus-ems.el @@ -1,6 +1,7 @@ ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -19,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: @@ -37,19 +38,17 @@ (defvar gnus-down-mouse-2 [down-mouse-2]) (defvar gnus-widget-button-keymap nil) (defvar gnus-mode-line-modified - (if (or (featurep 'xemacs) - (< emacs-major-version 20)) + (if (featurep 'xemacs) '("--**-" . "-----") '("**" "--"))) (eval-and-compile (autoload 'gnus-xmas-define "gnus-xmas") (autoload 'gnus-xmas-redefine "gnus-xmas") - (autoload 'appt-select-lowest-window "appt")) + (autoload 'gnus-get-buffer-create "gnus") + (autoload 'nnheader-find-etc-directory "nnheader")) -(if (featurep 'xemacs) - (autoload 'smiley-region "smiley") - (autoload 'smiley-region "smiley-ems")) ; override XEmacs version +(autoload 'smiley-region "smiley") (defun gnus-kill-all-overlays () "Delete all overlays in the current buffer." @@ -69,42 +68,25 @@ (truncate-string-to-width valstr ,max-width) valstr))) -(eval-and-compile - (defalias 'gnus-char-width - (if (fboundp 'char-width) - 'char-width - (lambda (ch) 1)))) ;; A simple hack. - (eval-and-compile (if (featurep 'xemacs) (gnus-xmas-define) (defvar gnus-mouse-face-prop 'mouse-face "Property used for highlighting mouse regions."))) -(eval-and-compile - (let ((case-fold-search t)) - (cond - ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32" - (symbol-name system-type)) - (setq nnheader-file-name-translation-alist - (append nnheader-file-name-translation-alist - (mapcar (lambda (c) (cons c ?_)) - '(?: ?* ?\" ?< ?> ??)) - (if (string-match "windows-nt\\|cygwin32" - (symbol-name system-type)) - nil - '((?+ . ?-))))))))) - -(defvar gnus-tmp-unread) -(defvar gnus-tmp-replied) -(defvar gnus-tmp-score-char) -(defvar gnus-tmp-indentation) -(defvar gnus-tmp-opening-bracket) -(defvar gnus-tmp-lines) -(defvar gnus-tmp-name) -(defvar gnus-tmp-closing-bracket) -(defvar gnus-tmp-subject-or-nil) -(defvar gnus-check-before-posting) +(eval-when-compile + (defvar gnus-tmp-unread) + (defvar gnus-tmp-replied) + (defvar gnus-tmp-score-char) + (defvar gnus-tmp-indentation) + (defvar gnus-tmp-opening-bracket) + (defvar gnus-tmp-lines) + (defvar gnus-tmp-name) + (defvar gnus-tmp-closing-bracket) + (defvar gnus-tmp-subject-or-nil) + (defvar gnus-check-before-posting) + (defvar gnus-mouse-face) + (defvar gnus-group-buffer)) (defun gnus-ems-redefine () (cond @@ -116,18 +98,18 @@ ;; [Note] Now there are three kinds of mule implementations, ;; original MULE, XEmacs/mule and Emacs 20+ including - ;; MULE features. Unfortunately these API are different. In - ;; particular, Emacs (including original MULE) and XEmacs are - ;; quite different. Howvere, this version of Gnus doesn't support + ;; MULE features. Unfortunately these APIs are different. In + ;; particular, Emacs (including original Mule) and XEmacs are + ;; quite different. However, this version of Gnus doesn't support ;; anything other than XEmacs 20+ and Emacs 20.3+. ;; Predicates to check are following: - ;; (boundp 'MULE) is t only if MULE (original; anything older than + ;; (boundp 'MULE) is t only if Mule (original; anything older than ;; Mule 2.3) is running. - ;; (featurep 'mule) is t when every mule variants are running. + ;; (featurep 'mule) is t when other mule variants are running. ;; It is possible to detect XEmacs/mule by (featurep 'mule) and - ;; checking `emacs-version'. In this case, the implementation for + ;; (featurep 'xemacs). In this case, the implementation for ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule. (defvar gnus-summary-display-table nil @@ -157,6 +139,18 @@ gnus-mouse-face-prop gnus-mouse-face) (insert " " gnus-tmp-subject-or-nil "\n"))))) +;; Clone of `appt-select-lowest-window' in appt.el. +(defun gnus-select-lowest-window () +"Select the lowest window on the frame." + (let ((lowest-window (selected-window)) + (bottom-edge (nth 3 (window-edges)))) + (walk-windows (lambda (w) + (let ((next-bottom-edge (nth 3 (window-edges w)))) + (when (< bottom-edge next-bottom-edge) + (setq bottom-edge next-bottom-edge + lowest-window w))))) + (select-window lowest-window))) + (defun gnus-region-active-p () "Say whether the region is active." (and (boundp 'transient-mark-mode) @@ -164,15 +158,9 @@ (boundp 'mark-active) mark-active)) -(if (fboundp 'add-minor-mode) - (defalias 'gnus-add-minor-mode 'add-minor-mode) - (defun gnus-add-minor-mode (mode name map &rest rest) - (set (make-local-variable mode) t) - (unless (assq mode minor-mode-alist) - (push `(,mode ,name) minor-mode-alist)) - (unless (assq mode minor-mode-map-alist) - (push (cons mode map) - minor-mode-map-alist)))) +(defun gnus-mark-active-p () + "Non-nil means the mark and region are currently active in this buffer." + mark-active) ; aliased to region-exists-p in XEmacs. (defun gnus-x-splash () "Show a splash screen using a pixmap in the current buffer." @@ -186,11 +174,13 @@ (when (and dir (file-exists-p (setq file (expand-file-name "x-splash" dir)))) - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (ignore-errors - (setq pixmap (read (current-buffer)))))) + (let ((coding-system-for-read 'raw-text) + default-enable-multibyte-characters) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (ignore-errors + (setq pixmap (read (current-buffer))))))) (when pixmap (make-face 'gnus-splash) (setq height (/ (car pixmap) (frame-char-height)) @@ -222,19 +212,38 @@ (setq props (plist-put props :background (face-background face)))) (apply 'create-image file type data-p props))) -(defun gnus-put-image (glyph &optional string) - (insert-image glyph (or string " ")) - (unless string - (put-text-property (1- (point)) (point) - 'gnus-image-text-deletable t))) - -(defun gnus-remove-image (image) - (dolist (position (message-text-with-property 'display)) - (when (equal (get-text-property position 'display) image) - (put-text-property position (1+ position) 'display nil) - (when (get-text-property position 'gnus-image-text-deletable) - (delete-region position (1+ position)))))) +(defun gnus-put-image (glyph &optional string category) + (let ((point (point))) + (insert-image glyph (or string " ")) + (put-text-property point (point) 'gnus-image-category category) + (unless string + (put-text-property (1- (point)) (point) + 'gnus-image-text-deletable t)) + glyph)) + +(defun gnus-remove-image (image &optional category) + "Remove the image matching IMAGE and CATEGORY found first." + (let ((start (point-min)) + val end) + (while (and (not end) + (or (setq val (get-text-property start 'display)) + (and (setq start + (next-single-property-change start 'display)) + (setq val (get-text-property start 'display))))) + (setq end (or (next-single-property-change start 'display) + (point-max))) + (if (and (equal val image) + (equal (get-text-property start 'gnus-image-category) + category)) + (progn + (put-text-property start end 'display nil) + (when (get-text-property start 'gnus-image-text-deletable) + (delete-region start end))) + (unless (= end (point-max)) + (setq start end + end nil)))))) (provide 'gnus-ems) +;;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb ;;; gnus-ems.el ends here