X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-ems.el;h=32b126a27132ba1a36df1e6567d6213010928159;hb=2e050501fb1fee86325437d6b0d6f2bce4141ec8;hp=22a5e28beaabd150f2b3b36c5910f7aad49d45b3;hpb=866d052667412dc9acb651a923de0a02b5bc5d72;p=gnus diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el index 22a5e28be..32b126a27 100644 --- a/lisp/gnus-ems.el +++ b/lisp/gnus-ems.el @@ -1,17 +1,17 @@ ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; 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 @@ -19,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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -44,10 +42,10 @@ (eval-and-compile (autoload 'gnus-xmas-define "gnus-xmas") - (autoload 'gnus-xmas-redefine "gnus-xmas") - (autoload 'gnus-get-buffer-create "gnus") - (autoload 'nnheader-find-etc-directory "nnheader")) + (autoload 'gnus-xmas-redefine "gnus-xmas")) +(autoload 'gnus-get-buffer-create "gnus") +(autoload 'nnheader-find-etc-directory "nnheader") (autoload 'smiley-region "smiley") (defun gnus-kill-all-overlays () @@ -74,19 +72,18 @@ (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 @@ -162,25 +159,31 @@ "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") + (defun gnus-x-splash () "Show a splash screen using a pixmap in the current buffer." (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) + (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) + 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))))))) + (let ((coding-system-for-read 'raw-text)) + (with-temp-buffer + (mm-disable-multibyte) + (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) @@ -188,10 +191,18 @@ fringes (if (fboundp 'window-fringes) (eval '(window-fringes)) '(10 11 nil)) - sbars (/ (or (frame-parameter nil 'scroll-bar-width) 14) fcw)) - (setq sbars (if (eq (frame-parameter nil 'vertical-scroll-bars) 'right) - (cons 0 sbars) - (cons sbars 0))) + 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) @@ -203,7 +214,8 @@ (car sbars) (/ (or (car fringes) 0) fcw)) yoffset (cadr (window-edges)) - top (max 0 (- (* (max (if (and tool-bar-mode + top (max 0 (- (* (max (if (and (boundp 'tool-bar-mode) + tool-bar-mode (not (featurep 'gtk)) (eq (frame-first-window) (selected-window))) @@ -213,23 +225,25 @@ height)) 2))) height) - yoffset - (/ (* (or line-spacing 0) 2) fch))) - height (- height (/ (or line-spacing 0) fch))) - (cond ((>= top 1) - (insert (propertize - " " - 'display `(space :width 0 :ascent 100)) - "\n" - (propertize - " " - 'display `(space :width 0 :height ,(1- top) :ascent 100)) - "\n")) - ((> top 0) - (insert (propertize - " " - 'display `(space :width 0 :height ,top :ascent 100)) - "\n"))) + 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 " " @@ -240,7 +254,7 @@ " " 'display `(space :width ,width :height ,height :ascent 0) 'face `(gnus-splash :stipple ,pixmap)))) - (goto-char (if (zerop top) (1- (point)) (point-min))) + (goto-char (if (<= (- top ls) 0) (1- (point)) (point-min))) (redraw-frame (selected-frame)) (sit-for 0)))) @@ -262,7 +276,7 @@ (defun gnus-put-image (glyph &optional string category) (let ((point (point))) - (insert-image glyph (or string " ")) + (insert-image glyph (or string "*")) (put-text-property point (point) 'gnus-image-category category) (unless string (put-text-property (1- (point)) (point) @@ -291,7 +305,28 @@ (setq start end end nil)))))) +(if (fboundp 'set-process-plist) + (progn + (defalias 'gnus-set-process-plist 'set-process-plist) + (defalias 'gnus-process-plist 'process-plist)) + (defun gnus-set-process-plist (process plist) + "Replace the plist of PROCESS with PLIST. Returns PLIST." + (put 'gnus-process-plist process plist)) + (defun gnus-process-plist (process) + "Return the plist of PROCESS." + ;; Remove those of dead processes from `gnus-process-plist' + ;; to prevent it from growing. + (let ((plist (symbol-plist 'gnus-process-plist)) + proc) + (while (setq proc (car plist)) + (if (and (processp proc) + (memq (process-status proc) '(open run))) + (setq plist (cddr plist)) + (setcar plist (caddr plist)) + (setcdr plist (or (cdddr plist) '(nil)))))) + (get 'gnus-process-plist process))) + (provide 'gnus-ems) -;;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb +;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb ;;; gnus-ems.el ends here