gnus-ems.el 9.81 KB
Newer Older
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
1
;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
2 3

;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
5

6
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
7 8 9 10
;; Keywords: news

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
15 16 17 18 19 20 21

;; 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
22
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
23 24 25 26 27

;;; Commentary:

;;; Code:

Dave Love's avatar
Dave Love committed
28 29 30
(eval-when-compile
  (require 'cl)
  (require 'ring))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
31 32 33 34

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

(defvar gnus-mouse-2 [mouse-2])
35
(defvar gnus-down-mouse-3 [down-mouse-3])
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
36
(defvar gnus-down-mouse-2 [down-mouse-2])
37
(defvar gnus-widget-button-keymap nil)
38
(defvar gnus-mode-line-modified
39
  (if (featurep 'xemacs)
40 41
      '("--**-" . "-----")
    '("**" "--")))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
42 43 44

(eval-and-compile
  (autoload 'gnus-xmas-define "gnus-xmas")
45
  (autoload 'gnus-xmas-redefine "gnus-xmas"))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
46

47 48
(autoload 'gnus-get-buffer-create "gnus")
(autoload 'nnheader-find-etc-directory "nnheader")
49
(autoload 'smiley-region "smiley")
50 51 52 53 54 55 56 57

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

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
59 60 61
;;; Mule functions.

(defun gnus-mule-max-width-function (el max-width)
62 63 64 65 66 67
  `(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)))
68

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
69
(eval-and-compile
70
  (if (featurep 'xemacs)
71
      (gnus-xmas-define)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
72
    (defvar gnus-mouse-face-prop 'mouse-face
73
      "Property used for highlighting mouse regions.")))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
74

Dan Nicolaescu's avatar
Dan Nicolaescu committed
75 76 77 78 79 80 81 82 83 84 85 86
(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)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
87 88 89

(defun gnus-ems-redefine ()
  (cond
90
   ((featurep 'xemacs)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
91 92 93 94 95 96
    (gnus-xmas-redefine))

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

    ;; [Note] Now there are three kinds of mule implementations,
97
    ;; original MULE, XEmacs/mule and Emacs 20+ including
98 99
    ;; MULE features.  Unfortunately these APIs are different.  In
    ;; particular, Emacs (including original Mule) and XEmacs are
100
    ;; quite different.  However, this version of Gnus doesn't support
101 102
    ;; anything other than XEmacs 20+ and Emacs 20.3+.

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
103
    ;; Predicates to check are following:
104
    ;; (boundp 'MULE) is t only if Mule (original; anything older than
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
105
    ;;                     Mule 2.3) is running.
106
    ;; (featurep 'mule) is t when other mule variants are running.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
107

108
    ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
109
    ;; (featurep 'xemacs).  In this case, the implementation for
110
    ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
111 112 113

    (defvar gnus-summary-display-table nil
      "Display table used in summary mode buffers.")
114
    (defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131

    (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)
132
		      (truncate-string-to-width gnus-tmp-name 20)
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
133 134 135 136
		    gnus-tmp-name))
	  gnus-tmp-closing-bracket)
	 (point))
       gnus-mouse-face-prop gnus-mouse-face)
137
      (insert " " gnus-tmp-subject-or-nil "\n")))))
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
138

139 140 141 142 143 144 145 146 147 148 149 150
;; 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)))

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
151 152 153 154 155 156 157
(defun gnus-region-active-p ()
  "Say whether the region is active."
  (and (boundp 'transient-mark-mode)
       transient-mark-mode
       (boundp 'mark-active)
       mark-active))

158 159 160 161
(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.

Glenn Morris's avatar
Glenn Morris committed
162
(autoload 'gnus-alive-p "gnus-util")
163
(autoload 'mm-disable-multibyte "mm-util")
Glenn Morris's avatar
Glenn Morris committed
164

165 166
(defun gnus-x-splash ()
  "Show a splash screen using a pixmap in the current buffer."
Miles Bader's avatar
Miles Bader committed
167 168 169 170 171 172 173
  (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)))
Miles Bader's avatar
Miles Bader committed
174
  (let ((inhibit-read-only t)
Miles Bader's avatar
Miles Bader committed
175 176 177
	(file (nnheader-find-etc-directory "images/gnus/x-splash" t))
	pixmap fcw fch width height fringes sbars left yoffset top ls)
    (erase-buffer)
Miles Bader's avatar
Miles Bader committed
178
    (sit-for 0) ;; Necessary for measuring the window size correctly.
Miles Bader's avatar
Miles Bader committed
179 180
    (when (and file
	       (ignore-errors
181
		(let ((coding-system-for-read 'raw-text))
Miles Bader's avatar
Miles Bader committed
182
		  (with-temp-buffer
183
                    (mm-disable-multibyte)
Miles Bader's avatar
Miles Bader committed
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
		    (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)
Miles Bader's avatar
Miles Bader committed
203 204 205
			 0)))
	    (t
	     (setq sbars '(0 . 0))))
Miles Bader's avatar
Miles Bader committed
206 207 208 209 210 211 212 213 214 215 216
      (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))
217 218
	    top (max 0 (- (* (max (if (and (boundp 'tool-bar-mode)
					   tool-bar-mode
Miles Bader's avatar
Miles Bader committed
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259
					   (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))))
260

261 262 263 264
;;; Image functions.

(defun gnus-image-type-available-p (type)
  (and (fboundp 'image-type-available-p)
Miles Bader's avatar
Miles Bader committed
265 266 267 268
       (image-type-available-p type)
       (if (fboundp 'display-images-p)
	   (display-images-p)
	 t)))
269 270 271 272 273 274 275 276

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

277 278 279 280 281 282 283
(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))
284 285 286
    glyph))

(defun gnus-remove-image (image &optional category)
287 288 289 290 291 292 293 294 295 296 297 298
  "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)
299
		      category))
300 301 302 303 304 305 306
	  (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))))))
307

Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
308 309
(provide 'gnus-ems)

310
;; arch-tag: e7360b45-14b5-4171-aa39-69a44aed3cdb
Lars Magne Ingebrigtsen's avatar
Lars Magne Ingebrigtsen committed
311
;;; gnus-ems.el ends here