[bpt/emacs.git] / lisp / gnus / gnus-ems.el

;;; 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, 2008, 2009, 2010 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news

;; This file is part of GNU Emacs.

;; 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 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(eval-when-compile
  (require 'cl)
  (require 'ring))

;;; Function aliases later to be redefined for XEmacs usage.

(defvar gnus-mouse-2 [mouse-2])
(defvar gnus-down-mouse-3 [down-mouse-3])
(defvar gnus-down-mouse-2 [down-mouse-2])
(defvar gnus-widget-button-keymap nil)
(defvar gnus-mode-line-modified
  (if (featurep 'xemacs)
      '("--**-" . "-----")
    '("**" "--")))

(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 'smiley-region "smiley")

(defun gnus-kill-all-overlays ()
  "Delete all overlays in the current buffer."
  (let* ((overlayss (overlay-lists))
	 (buffer-read-only nil)
	 (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
    (while overlays
      (delete-overlay (pop overlays)))))

;;; Mule functions.

(defun gnus-mule-max-width-function (el max-width)
  `(let* ((val (eval (, el)))
	  (valstr (if (numberp val)
		      (int-to-string val) val)))
     (if (> (length valstr) ,max-width)
	 (truncate-string-to-width valstr ,max-width)
       valstr)))

(eval-and-compile
  (if (featurep 'xemacs)
      (gnus-xmas-define)
    (defvar gnus-mouse-face-prop 'mouse-face
      "Property used for highlighting mouse regions.")))

(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
   ((featurep 'xemacs)
    (gnus-xmas-redefine))

   ((featurep 'mule)
    ;; Mule and new Emacs definitions

    ;; [Note] Now there are three kinds of mule implementations,
    ;; original MULE, XEmacs/mule and Emacs 20+ including
    ;; 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
    ;;                     Mule 2.3) is running.
    ;; (featurep 'mule) is t when other mule variants are running.

    ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
    ;; (featurep 'xemacs).  In this case, the implementation for
    ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.

    (defvar gnus-summary-display-table nil
      "Display table used in summary mode buffers.")
    (defalias 'gnus-max-width-function 'gnus-mule-max-width-function)

    (when (boundp 'gnus-check-before-posting)
      (setq gnus-check-before-posting
	    (delq 'long-lines
		  (delq 'control-chars gnus-check-before-posting))))

    (defun gnus-summary-line-format-spec ()
      (insert gnus-tmp-unread gnus-tmp-replied
	      gnus-tmp-score-char gnus-tmp-indentation)
      (put-text-property
       (point)
       (progn
	 (insert
	  gnus-tmp-opening-bracket
	  (format "%4d: %-20s"
		  gnus-tmp-lines
		  (if (> (length gnus-tmp-name) 20)
		      (truncate-string-to-width gnus-tmp-name 20)
		    gnus-tmp-name))
	  gnus-tmp-closing-bracket)
	 (point))
       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)
       transient-mark-mode
       (boundp 'mark-active)
       mark-active))

(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")

(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 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)
       (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))))))

(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)

;;; gnus-ems.el ends here
Commit	Line	Data
eec82323	1	;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
e84b4b86 TTN	2
e84b4b86 TTN	3	;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
114f9c96	4	;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
eec82323	5
6748645f	6	;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
eec82323 LMI	7	;; Keywords: news
	8
	9	;; This file is part of GNU Emacs.
	10
5e809f55	11	;; GNU Emacs is free software: you can redistribute it and/or modify
eec82323	12	;; it under the terms of the GNU General Public License as published by
5e809f55 GM	13	;; the Free Software Foundation, either version 3 of the License, or
5e809f55 GM	14	;; (at your option) any later version.
eec82323 LMI	15
	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; You should have received a copy of the GNU General Public License
5e809f55	22	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
eec82323 LMI	23
	24	;;; Commentary:
	25
	26	;;; Code:
	27
4bcf2f05 DL	28	(eval-when-compile
	29	(require 'cl)
	30	(require 'ring))
eec82323 LMI	31
	32	;;; Function aliases later to be redefined for XEmacs usage.
	33
eec82323	34	(defvar gnus-mouse-2 [mouse-2])
16409b0b	35	(defvar gnus-down-mouse-3 [down-mouse-3])
eec82323	36	(defvar gnus-down-mouse-2 [down-mouse-2])
16409b0b	37	(defvar gnus-widget-button-keymap nil)
a8151ef7	38	(defvar gnus-mode-line-modified
01c52d31	39	(if (featurep 'xemacs)
a8151ef7 LMI	40	'("--**-" . "-----")
a8151ef7 LMI	41	'("**" "--")))
eec82323 LMI	42
	43	(eval-and-compile
	44	(autoload 'gnus-xmas-define "gnus-xmas")
1e957e64	45	(autoload 'gnus-xmas-redefine "gnus-xmas"))
eec82323	46
1e957e64 GM	47	(autoload 'gnus-get-buffer-create "gnus")
1e957e64 GM	48	(autoload 'nnheader-find-etc-directory "nnheader")
23f87bed	49	(autoload 'smiley-region "smiley")
06c43cdf DL	50
	51	(defun gnus-kill-all-overlays ()
	52	"Delete all overlays in the current buffer."
	53	(let* ((overlayss (overlay-lists))
	54	(buffer-read-only nil)
	55	(overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
	56	(while overlays
	57	(delete-overlay (pop overlays)))))
2d2f7f3e	58
eec82323 LMI	59	;;; Mule functions.
eec82323 LMI	60
eec82323	61	(defun gnus-mule-max-width-function (el max-width)
16409b0b GM	62	`(let* ((val (eval (, el)))
	63	(valstr (if (numberp val)
	64	(int-to-string val) val)))
	65	(if (> (length valstr) ,max-width)
	66	(truncate-string-to-width valstr ,max-width)
	67	valstr)))
6748645f	68
eec82323	69	(eval-and-compile
06c43cdf	70	(if (featurep 'xemacs)
16409b0b	71	(gnus-xmas-define)
eec82323	72	(defvar gnus-mouse-face-prop 'mouse-face
16409b0b	73	"Property used for highlighting mouse regions.")))
eec82323	74
9efa445f DN	75	(defvar gnus-tmp-unread)
	76	(defvar gnus-tmp-replied)
	77	(defvar gnus-tmp-score-char)
	78	(defvar gnus-tmp-indentation)
	79	(defvar gnus-tmp-opening-bracket)
	80	(defvar gnus-tmp-lines)
	81	(defvar gnus-tmp-name)
	82	(defvar gnus-tmp-closing-bracket)
	83	(defvar gnus-tmp-subject-or-nil)
	84	(defvar gnus-check-before-posting)
	85	(defvar gnus-mouse-face)
	86	(defvar gnus-group-buffer)
eec82323 LMI	87
	88	(defun gnus-ems-redefine ()
	89	(cond
4ddf0e64	90	((featurep 'xemacs)
eec82323 LMI	91	(gnus-xmas-redefine))
	92
	93	((featurep 'mule)
	94	;; Mule and new Emacs definitions
	95
	96	;; [Note] Now there are three kinds of mule implementations,
16409b0b	97	;; original MULE, XEmacs/mule and Emacs 20+ including
23f87bed MB	98	;; MULE features. Unfortunately these APIs are different. In
23f87bed MB	99	;; particular, Emacs (including original Mule) and XEmacs are
feee6240	100	;; quite different. However, this version of Gnus doesn't support
16409b0b GM	101	;; anything other than XEmacs 20+ and Emacs 20.3+.
16409b0b GM	102
eec82323	103	;; Predicates to check are following:
23f87bed	104	;; (boundp 'MULE) is t only if Mule (original; anything older than
eec82323	105	;; Mule 2.3) is running.
23f87bed	106	;; (featurep 'mule) is t when other mule variants are running.
eec82323	107
16409b0b	108	;; It is possible to detect XEmacs/mule by (featurep 'mule) and
23f87bed	109	;; (featurep 'xemacs). In this case, the implementation for
16409b0b	110	;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
eec82323 LMI	111
	112	(defvar gnus-summary-display-table nil
	113	"Display table used in summary mode buffers.")
16409b0b	114	(defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
eec82323 LMI	115
	116	(when (boundp 'gnus-check-before-posting)
	117	(setq gnus-check-before-posting
	118	(delq 'long-lines
	119	(delq 'control-chars gnus-check-before-posting))))
	120
	121	(defun gnus-summary-line-format-spec ()
	122	(insert gnus-tmp-unread gnus-tmp-replied
	123	gnus-tmp-score-char gnus-tmp-indentation)
	124	(put-text-property
	125	(point)
	126	(progn
	127	(insert
	128	gnus-tmp-opening-bracket
	129	(format "%4d: %-20s"
	130	gnus-tmp-lines
	131	(if (> (length gnus-tmp-name) 20)
16409b0b	132	(truncate-string-to-width gnus-tmp-name 20)
eec82323 LMI	133	gnus-tmp-name))
	134	gnus-tmp-closing-bracket)
	135	(point))
	136	gnus-mouse-face-prop gnus-mouse-face)
16409b0b	137	(insert " " gnus-tmp-subject-or-nil "\n")))))
eec82323	138
01c52d31 MB	139	;; Clone of `appt-select-lowest-window' in appt.el.
	140	(defun gnus-select-lowest-window ()
	141	"Select the lowest window on the frame."
	142	(let ((lowest-window (selected-window))
	143	(bottom-edge (nth 3 (window-edges))))
	144	(walk-windows (lambda (w)
	145	(let ((next-bottom-edge (nth 3 (window-edges w))))
	146	(when (< bottom-edge next-bottom-edge)
	147	(setq bottom-edge next-bottom-edge
	148	lowest-window w)))))
	149	(select-window lowest-window)))
	150
eec82323 LMI	151	(defun gnus-region-active-p ()
	152	"Say whether the region is active."
	153	(and (boundp 'transient-mark-mode)
	154	transient-mark-mode
	155	(boundp 'mark-active)
	156	mark-active))
	157
23f87bed MB	158	(defun gnus-mark-active-p ()
	159	"Non-nil means the mark and region are currently active in this buffer."
	160	mark-active) ; aliased to region-exists-p in XEmacs.
	161
db48b197	162	(autoload 'gnus-alive-p "gnus-util")
407da272	163	(autoload 'mm-disable-multibyte "mm-util")
db48b197	164
6748645f LMI	165	(defun gnus-x-splash ()
6748645f LMI	166	"Show a splash screen using a pixmap in the current buffer."
524705ae MB	167	(interactive)
	168	(unless window-system
	169	(error "`gnus-x-splash' requires running on the window system"))
	170	(switch-to-buffer (gnus-get-buffer-create (if (or (gnus-alive-p)
	171	(interactive-p))
	172	"gnus-x-splash"
	173	gnus-group-buffer)))
37cc095b	174	(let ((inhibit-read-only t)
524705ae MB	175	(file (nnheader-find-etc-directory "images/gnus/x-splash" t))
	176	pixmap fcw fch width height fringes sbars left yoffset top ls)
	177	(erase-buffer)
5cedca8d	178	(sit-for 0) ;; Necessary for measuring the window size correctly.
524705ae MB	179	(when (and file
524705ae MB	180	(ignore-errors
2b57967e	181	(let ((coding-system-for-read 'raw-text))
524705ae	182	(with-temp-buffer
2b57967e	183	(mm-disable-multibyte)
524705ae MB	184	(insert-file-contents file)
	185	(goto-char (point-min))
	186	(setq pixmap (read (current-buffer)))))))
	187	(setq fcw (float (frame-char-width))
	188	fch (float (frame-char-height))
	189	width (/ (car pixmap) fcw)
	190	height (/ (cadr pixmap) fch)
	191	fringes (if (fboundp 'window-fringes)
	192	(eval '(window-fringes))
	193	'(10 11 nil))
	194	sbars (frame-parameter nil 'vertical-scroll-bars))
	195	(cond ((eq sbars 'right)
	196	(setq sbars
	197	(cons 0 (/ (or (frame-parameter nil 'scroll-bar-width) 14)
	198	fcw))))
	199	(sbars
	200	(setq sbars
	201	(cons (/ (or (frame-parameter nil 'scroll-bar-width) 14)
	202	fcw)
60ece9b0 MB	203	0)))
	204	(t
	205	(setq sbars '(0 . 0))))
524705ae MB	206	(setq left (- (* (round (/ (1- (/ (+ (window-width)
	207	(car sbars) (cdr sbars)
	208	(/ (+ (or (car fringes) 0)
	209	(or (cadr fringes) 0))
	210	fcw))
	211	width))
	212	2))
	213	width)
	214	(car sbars)
	215	(/ (or (car fringes) 0) fcw))
	216	yoffset (cadr (window-edges))
1e957e64 GM	217	top (max 0 (- (* (max (if (and (boundp 'tool-bar-mode)
1e957e64 GM	218	tool-bar-mode
524705ae MB	219	(not (featurep 'gtk))
	220	(eq (frame-first-window)
	221	(selected-window)))
	222	1 0)
	223	(round (/ (1- (/ (+ (1- (window-height))
	224	(* 2 yoffset))
	225	height))
	226	2)))
	227	height)
	228	yoffset))
	229	ls (/ (or line-spacing 0) fch)
	230	height (max 0 (- height ls)))
	231	(cond ((>= (- top ls) 1)
	232	(insert
	233	(propertize
	234	" "
	235	'display `(space :width 0 :ascent 100))
	236	"\n"
	237	(propertize
	238	" "
	239	'display `(space :width 0 :height ,(- top ls 1) :ascent 100))
	240	"\n"))
	241	((> (- top ls) 0)
	242	(insert
	243	(propertize
	244	" "
	245	'display `(space :width 0 :height ,(- top ls) :ascent 100))
	246	"\n")))
	247	(if (and (> width 0) (> left 0))
	248	(insert (propertize
	249	" "
	250	'display `(space :width ,left :height ,height :ascent 0)))
	251	(setq width (+ width left)))
	252	(when (> width 0)
	253	(insert (propertize
	254	" "
	255	'display `(space :width ,width :height ,height :ascent 0)
	256	'face `(gnus-splash :stipple ,pixmap))))
	257	(goto-char (if (<= (- top ls) 0) (1- (point)) (point-min)))
	258	(redraw-frame (selected-frame))
	259	(sit-for 0))))
6748645f	260
23f87bed MB	261	;;; Image functions.
	262
	263	(defun gnus-image-type-available-p (type)
	264	(and (fboundp 'image-type-available-p)
11e95b02 MB	265	(image-type-available-p type)
	266	(if (fboundp 'display-images-p)
	267	(display-images-p)
	268	t)))
23f87bed MB	269
	270	(defun gnus-create-image (file &optional type data-p &rest props)
	271	(let ((face (plist-get props :face)))
	272	(when face
	273	(setq props (plist-put props :foreground (face-foreground face)))
	274	(setq props (plist-put props :background (face-background face))))
4478e074 G	275	(ignore-errors
4478e074 G	276	(apply 'create-image file type data-p props))))
23f87bed	277
0c32d782 KY	278	(defun gnus-put-image (glyph &optional string category)
0c32d782 KY	279	(let ((point (point)))
b6fda8fc	280	(insert-image glyph (or string "*"))
0c32d782 KY	281	(put-text-property point (point) 'gnus-image-category category)
	282	(unless string
	283	(put-text-property (1- (point)) (point)
	284	'gnus-image-text-deletable t))
23f87bed MB	285	glyph))
	286
	287	(defun gnus-remove-image (image &optional category)
01c52d31 MB	288	"Remove the image matching IMAGE and CATEGORY found first."
	289	(let ((start (point-min))
	290	val end)
	291	(while (and (not end)
	292	(or (setq val (get-text-property start 'display))
	293	(and (setq start
	294	(next-single-property-change start 'display))
	295	(setq val (get-text-property start 'display)))))
	296	(setq end (or (next-single-property-change start 'display)
	297	(point-max)))
	298	(if (and (equal val image)
	299	(equal (get-text-property start 'gnus-image-category)
23f87bed	300	category))
01c52d31 MB	301	(progn
	302	(put-text-property start end 'display nil)
	303	(when (get-text-property start 'gnus-image-text-deletable)
	304	(delete-region start end)))
	305	(unless (= end (point-max))
	306	(setq start end
	307	end nil))))))
6748645f	308
a14b3417 KY	309	(eval-and-compile
	310	(if (fboundp 'set-process-plist)
	311	(progn
	312	(defalias 'gnus-set-process-plist 'set-process-plist)
	313	(defalias 'gnus-process-plist 'process-plist)
	314	(defalias 'gnus-process-get 'process-get)
	315	(defalias 'gnus-process-put 'process-put))
	316	(defun gnus-set-process-plist (process plist)
	317	"Replace the plist of PROCESS with PLIST. Returns PLIST."
3fb8f8a1 KY	318	(put 'gnus-process-plist-internal process plist))
3fb8f8a1 KY	319
a14b3417 KY	320	(defun gnus-process-plist (process)
a14b3417 KY	321	"Return the plist of PROCESS."
3fb8f8a1 KY	322	;; This form works but can't prevent the plist data from
	323	;; growing infinitely.
	324	;;(get 'gnus-process-plist-internal process)
	325	(let* ((plist (symbol-plist 'gnus-process-plist-internal))
	326	(tem (memq process plist)))
	327	(prog1
	328	(cadr tem)
	329	;; Remove it from the plist data.
	330	(when tem
	331	(if (eq plist tem)
	332	(progn
	333	(setcar plist (caddr plist))
	334	(setcdr plist (or (cdddr plist) '(nil))))
	335	(setcdr (nthcdr (- (length plist) (length tem) 1) plist)
	336	(cddr tem)))))))
	337
a14b3417 KY	338	(defun gnus-process-get (process propname)
	339	"Return the value of PROCESS' PROPNAME property.
	340	This is the last value stored with `(gnus-process-put PROCESS PROPNAME VALUE)'."
	341	(plist-get (gnus-process-plist process) propname))
3fb8f8a1	342
a14b3417 KY	343	(defun gnus-process-put (process propname value)
	344	"Change PROCESS' PROPNAME property to VALUE.
	345	It can be retrieved with `(gnus-process-get PROCESS PROPNAME)'."
	346	(gnus-set-process-plist process
b89666af	347	(plist-put (gnus-process-plist process)
a14b3417	348	propname value)))))
2cdd366f	349
eec82323 LMI	350	(provide 'gnus-ems)
eec82323 LMI	351
eec82323	352	;;; gnus-ems.el ends here