X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-ems.el;h=a49d46a94d6492b15f2aace86a19f2c1dbbd0325;hp=14d91b18beefc088ea2a7ae499bd24f07926ca11;hb=17f456f97c1659bcdc5935b91a011cdad96b9150;hpb=299c947dde266c2d2cec625b91c662a3c9f71dad

diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el
index 14d91b18b..a49d46a94 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, 2003
-;;        Free Software Foundation, Inc.
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;   2004, 2005, 2006, 2007 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news
@@ -9,7 +10,7 @@
 
 ;; 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)
+;; the Free Software Foundation; either version 3, or (at your option)
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
@@ -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,21 +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"))
 
 (autoload 'smiley-region "smiley")
-;; Fixme: shouldn't require message
-(autoload 'message-text-with-property "message")
 
 (defun gnus-kill-all-overlays ()
   "Delete all overlays in the current buffer."
@@ -71,31 +68,24 @@
 	 (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-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))
+(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
@@ -148,6 +138,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)
@@ -159,58 +161,111 @@
   "Non-nil means the mark and region are currently active in this buffer."
   mark-active) ; aliased to region-exists-p in XEmacs.
 
-(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))))
+(autoload 'gnus-alive-p "gnus-util")
 
 (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))))
-	  (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))
-		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))))))
+  (interactive)
+  (unless window-system
+    (error "`gnus-x-splash' requires running on the window system"))
+  (switch-to-buffer (gnus-get-buffer-create (if (or (gnus-alive-p)
+						    (interactive-p))
+						"*gnus-x-splash*"
+					      gnus-group-buffer)))
+  (let ((inhibit-read-only t)
+	(file (nnheader-find-etc-directory "images/gnus/x-splash" t))
+	pixmap fcw fch width height fringes sbars left yoffset top ls)
+    (erase-buffer)
+    (sit-for 0) ;; Necessary for measuring the window size correctly.
+    (when (and file
+	       (ignore-errors
+		(let ((coding-system-for-read 'raw-text)
+		      default-enable-multibyte-characters)
+		  (with-temp-buffer
+		    (insert-file-contents file)
+		    (goto-char (point-min))
+		    (setq pixmap (read (current-buffer)))))))
+      (setq fcw (float (frame-char-width))
+	    fch (float (frame-char-height))
+	    width (/ (car pixmap) fcw)
+	    height (/ (cadr pixmap) fch)
+	    fringes (if (fboundp 'window-fringes)
+			(eval '(window-fringes))
+		      '(10 11 nil))
+	    sbars (frame-parameter nil 'vertical-scroll-bars))
+      (cond ((eq sbars 'right)
+	     (setq sbars
+		   (cons 0 (/ (or (frame-parameter nil 'scroll-bar-width) 14)
+			      fcw))))
+	    (sbars
+	     (setq sbars
+		   (cons (/ (or (frame-parameter nil 'scroll-bar-width) 14)
+			    fcw)
+			 0)))
+	    (t
+	     (setq sbars '(0 . 0))))
+      (setq left (- (* (round (/ (1- (/ (+ (window-width)
+					   (car sbars) (cdr sbars)
+					   (/ (+ (or (car fringes) 0)
+						 (or (cadr fringes) 0))
+					      fcw))
+					width))
+				 2))
+		       width)
+		    (car sbars)
+		    (/ (or (car fringes) 0) fcw))
+	    yoffset (cadr (window-edges))
+	    top (max 0 (- (* (max (if (and tool-bar-mode
+					   (not (featurep 'gtk))
+					   (eq (frame-first-window)
+					       (selected-window)))
+				      1 0)
+				  (round (/ (1- (/ (+ (1- (window-height))
+						      (* 2 yoffset))
+						   height))
+					    2)))
+			     height)
+			  yoffset))
+	    ls (/ (or line-spacing 0) fch)
+	    height (max 0 (- height ls)))
+      (cond ((>= (- top ls) 1)
+	     (insert
+	      (propertize
+	       " "
+	       'display `(space :width 0 :ascent 100))
+	      "\n"
+	      (propertize
+	       " "
+	       'display `(space :width 0 :height ,(- top ls 1) :ascent 100))
+	      "\n"))
+	    ((> (- top ls) 0)
+	     (insert
+	      (propertize
+	       " "
+	       'display `(space :width 0 :height ,(- top ls) :ascent 100))
+	      "\n")))
+      (if (and (> width 0) (> left 0))
+	  (insert (propertize
+		   " "
+		   'display `(space :width ,left :height ,height :ascent 0)))
+	(setq width (+ width left)))
+      (when (> width 0)
+	(insert (propertize
+		 " "
+		 'display `(space :width ,width :height ,height :ascent 0)
+		 'face `(gnus-splash :stipple ,pixmap))))
+      (goto-char (if (<= (- top ls) 0) (1- (point)) (point-min)))
+      (redraw-frame (selected-frame))
+      (sit-for 0))))
 
 ;;; Image functions.
 
 (defun gnus-image-type-available-p (type)
   (and (fboundp 'image-type-available-p)
-       (image-type-available-p type)))
+       (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)))
@@ -220,22 +275,37 @@
     (apply 'create-image file type data-p props)))
 
 (defun gnus-put-image (glyph &optional string category)
-  (insert-image glyph (or string " "))
-  (put-text-property (1- (point)) (point) 'gnus-image-category category)
-  (unless string
-    (put-text-property (1- (point)) (point)
-		       'gnus-image-text-deletable t))
-  glyph)
+  (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)
-  (dolist (position (message-text-with-property 'display))
-    (when (and (equal (get-text-property position 'display) image)
-	       (equal (get-text-property position 'gnus-image-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))
-      (put-text-property position (1+ position) 'display nil)
-      (when (get-text-property position 'gnus-image-text-deletable)
-	(delete-region position (1+ position))))))
+	  (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