emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/gnus/gnus-ems.el, v [EMACS_22_BASE]


From: Miles Bader
Subject: [Emacs-diffs] Changes to emacs/lisp/gnus/gnus-ems.el, v [EMACS_22_BASE]
Date: Thu, 14 Jun 2007 10:02:58 +0000

CVSROOT:        /cvsroot/emacs
Module name:    emacs
Branch:         EMACS_22_BASE
Changes by:     Miles Bader <miles>     07/06/14 10:02:56

Index: lisp/gnus/gnus-ems.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/gnus-ems.el,v
retrieving revision 1.23
retrieving revision 1.23.2.1
diff -u -b -r1.23 -r1.23.2.1
--- lisp/gnus/gnus-ems.el       21 Jan 2007 02:54:13 -0000      1.23
+++ lisp/gnus/gnus-ems.el       14 Jun 2007 10:02:54 -0000      1.23.2.1
@@ -172,40 +172,95 @@
 
 (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)
+  (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 nil)
+       (file (nnheader-find-etc-directory "images/gnus/x-splash" t))
+       pixmap fcw fch width height fringes sbars left yoffset top ls)
        (erase-buffer)
-       (when (and dir
-                  (file-exists-p (setq file
-                                       (expand-file-name "x-splash" dir))))
+    (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))
-             (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))))))
+      (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))))
+      (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.
 




reply via email to

[Prev in Thread] Current Thread [Next in Thread]