X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-ems.el;h=d7d90767124fe6e737878e00b8057c6fb9d8afd6;hb=fdd7950c0506b73666d1a9a0259a9fef17b3a897;hp=12a412191ce2185f121f79bf97f94f586b394d1b;hpb=ed5b20a3a40c832e1d9c6c7009579f6457fff8dd;p=gnus diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el index 12a412191..d7d907671 100644 --- a/lisp/gnus-ems.el +++ b/lisp/gnus-ems.el @@ -1,16 +1,17 @@ ;;; 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, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -18,9 +19,7 @@ ;; GNU General Public License for more details. ;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -37,19 +36,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-xmas-redefine "gnus-xmas")) -(if (featurep 'xemacs) - (autoload 'smiley-region "smiley") - (autoload 'smiley-region "smiley-ems")) ; override XEmacs version +(autoload 'gnus-get-buffer-create "gnus") +(autoload 'nnheader-find-etc-directory "nnheader") +(autoload 'smiley-region "smiley") (defun gnus-kill-all-overlays () "Delete all overlays in the current buffer." @@ -69,32 +66,12 @@ (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) @@ -105,6 +82,8 @@ (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 +95,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 +136,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,149 +155,107 @@ (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-x-splash () - "Show a splash screen using a pixmap in the current buffer." - (let ((dir (nnheader-find-etc-directory "gnus")) - pixmap file height beg i) - (save-excursion - (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer)) - (let ((buffer-read-only nil) - width height) - (erase-buffer) - (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)))))) - (when pixmap - (make-face 'gnus-splash) - (setq height (/ (car pixmap) (frame-char-height)) - width (/ (cadr pixmap) (frame-char-width))) - (set-face-foreground 'gnus-splash "Brown") - (set-face-stipple 'gnus-splash pixmap) - (insert-char ?\n (* (/ (window-height) 2 height) height)) - (setq i height) - (while (> i 0) - (insert-char ?\ (* (/ (window-width) 2 width) width)) - (setq beg (point)) - (insert-char ?\ width) - (set-text-properties beg (point) '(face gnus-splash)) - (insert ?\n) - (decf i)) - (goto-char (point-min)) - (sit-for 0)))))) - -(defvar gnus-article-xface-ring-internal nil - "Cache for face data.") - -;; Worth customizing? -(defvar gnus-article-xface-ring-size 6 - "Length of the ring used for `gnus-article-xface-ring-internal'.") - -(defvar gnus-article-compface-xbm - (condition-case () - (eq 0 (string-match "#define" - (shell-command-to-string "uncompface -X"))) - (error nil)) - "Non-nil means the compface program supports the -X option. -That produces XBM output.") - -(defun gnus-article-display-xface (data) - "Display the XFace header FACE in the current buffer. -Requires support for images in your Emacs and the external programs -`uncompface', and `icontopbm'. On a GNU/Linux system these -might be in packages with names like `compface' or `faces-xface' and -`netpbm' or `libgr-progs', for instance. See also -`gnus-article-compface-xbm'. - -This function is for Emacs 21+. See `gnus-xmas-article-display-xface' -for XEmacs." - ;; It might be worth converting uncompface's output in Lisp. - - (when (if (fboundp 'display-graphic-p) - (display-graphic-p)) - (unless gnus-article-xface-ring-internal ; Only load ring when needed. - (setq gnus-article-xface-ring-internal - (make-ring gnus-article-xface-ring-size))) - (save-excursion - (let* ((cur (current-buffer)) - (image (cdr-safe (assoc data (ring-elements - gnus-article-xface-ring-internal)))) - default-enable-multibyte-characters) - (unless image - (with-temp-buffer - (insert data) - (and (eq 0 (apply #'call-process-region (point-min) (point-max) - "uncompface" - 'delete '(t nil) nil - (if gnus-article-compface-xbm - '("-X")))) - (if gnus-article-compface-xbm - t - (goto-char (point-min)) - (progn (insert "/* Width=48, Height=48 */\n") t) - (eq 0 (call-process-region (point-min) (point-max) - "icontopbm" - 'delete '(t nil)))) - ;; Miles Bader says that faces don't look right as - ;; light on dark. - (if (eq 'dark (cdr-safe (assq 'background-mode - (frame-parameters)))) - (setq image (create-image (buffer-string) - (if gnus-article-compface-xbm - 'xbm - 'pbm) - t - :ascent 'center - :foreground "black" - :background "white")) - (setq image (create-image (buffer-string) - (if gnus-article-compface-xbm - 'xbm - 'pbm) - t - :ascent 'center))))) - (ring-insert gnus-article-xface-ring-internal (cons data image))) - (when image - (goto-char (point-min)) - (re-search-forward "^From:" nil 'move) - (gnus-add-wash-type 'xface) - (gnus-add-image 'xface image) - (insert-image image " ") - (put-text-property (1- (point)) (point) - 'gnus-image-text-deletable t)))))) +(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. + +(autoload 'gnus-alive-p "gnus-util") +(autoload 'mm-disable-multibyte "mm-util") ;;; Image functions. (defun gnus-image-type-available-p (type) (and (fboundp 'image-type-available-p) - (image-type-available-p type))) - -(defun gnus-create-image (file) - (create-image file)) + (image-type-available-p type) + (if (fboundp 'display-images-p) + (display-images-p) + t))) + +(defun gnus-create-image (file &optional type data-p &rest props) + (let ((face (plist-get props :face))) + (when face + (setq props (plist-put props :foreground (face-foreground face))) + (setq props (plist-put props :background (face-background face)))) + (ignore-errors + (apply 'create-image file type data-p props)))) + +(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)))))) -(defun gnus-put-image (glyph &optional string) - (insert-image glyph string)) - -(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) - (if (get-text-property position 'gnus-image-text-deletable) - (delete-region position (1+ position)))))) +(eval-and-compile + ;; XEmacs does not have window-inside-pixel-edges + (defalias 'gnus-window-inside-pixel-edges + (if (fboundp 'window-inside-pixel-edges) + 'window-inside-pixel-edges + 'window-pixel-edges)) + + (if (fboundp 'set-process-plist) + (progn + (defalias 'gnus-set-process-plist 'set-process-plist) + (defalias 'gnus-process-plist 'process-plist) + (defalias 'gnus-process-get 'process-get) + (defalias 'gnus-process-put 'process-put)) + (defun gnus-set-process-plist (process plist) + "Replace the plist of PROCESS with PLIST. Returns PLIST." + (put 'gnus-process-plist-internal process plist)) + + (defun gnus-process-plist (process) + "Return the plist of PROCESS." + ;; This form works but can't prevent the plist data from + ;; growing infinitely. + ;;(get 'gnus-process-plist-internal process) + (let* ((plist (symbol-plist 'gnus-process-plist-internal)) + (tem (memq process plist))) + (prog1 + (cadr tem) + ;; Remove it from the plist data. + (when tem + (if (eq plist tem) + (progn + (setcar plist (caddr plist)) + (setcdr plist (or (cdddr plist) '(nil)))) + (setcdr (nthcdr (- (length plist) (length tem) 1) plist) + (cddr tem))))))) + + (defun gnus-process-get (process propname) + "Return the value of PROCESS' PROPNAME property. +This is the last value stored with `(gnus-process-put PROCESS PROPNAME VALUE)'." + (plist-get (gnus-process-plist process) propname)) + + (defun gnus-process-put (process propname value) + "Change PROCESS' PROPNAME property to VALUE. +It can be retrieved with `(gnus-process-get PROCESS PROPNAME)'." + (gnus-set-process-plist process + (plist-put (gnus-process-plist process) + propname value))))) (provide 'gnus-ems)