X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-ems.el;h=b4a2fe960c67b86d58d484a5708632f62e27e2f5;hp=a053535dc43b8ff3122f8f8c326a75a56e8e9bf2;hb=ba2fe997b36918f5ed20351fe6871a9931f5eb09;hpb=c2c79b3b1829d43e94eea30b67d1404a24154457 diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el index a053535dc..b4a2fe960 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, 2003, 2004 -;; 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: @@ -43,13 +42,11 @@ (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") -;; Fixme: shouldn't require message -(autoload 'message-text-with-property "message") (defun gnus-kill-all-overlays () "Delete all overlays in the current buffer." @@ -75,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 @@ -163,59 +159,125 @@ "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." - (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)) + (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) + 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 (boundp 'tool-bar-mode) + 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))) (when face (setq props (plist-put props :foreground (face-foreground face))) (setq props (plist-put props :background (face-background face)))) - (apply 'create-image file type data-p props))) + (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 " ")) + (insert-image glyph (or string "*")) (put-text-property point (point) 'gnus-image-category category) (unless string (put-text-property (1- (point)) (point) @@ -223,13 +285,67 @@ 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)))))) + +(eval-and-compile + (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)