lisp/gnus/gnus-ems.el

   1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
   2
   3 ;; Copyright (C) 1995-2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile
  28   (require 'cl)
  29   (require 'ring))
  30
  31 ;;; Function aliases later to be redefined for XEmacs usage.
  32
  33 (defvar gnus-mouse-2 [mouse-2])
  34 (defvar gnus-down-mouse-3 [down-mouse-3])
  35 (defvar gnus-down-mouse-2 [down-mouse-2])
  36 (defvar gnus-widget-button-keymap nil)
  37 (defvar gnus-mode-line-modified
  38   (if (featurep 'xemacs)
  39       '("--**-" . "-----")
  40     '("**" "--")))
  41
  42 (eval-and-compile
  43   (autoload 'gnus-xmas-define "gnus-xmas")
  44   (autoload 'gnus-xmas-redefine "gnus-xmas"))
  45
  46 (autoload 'gnus-get-buffer-create "gnus")
  47 (autoload 'nnheader-find-etc-directory "nnheader")
  48 (autoload 'smiley-region "smiley")
  49
  50 (defun gnus-kill-all-overlays ()
  51   "Delete all overlays in the current buffer."
  52   (let* ((overlayss (overlay-lists))
  53          (buffer-read-only nil)
  54          (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
  55     (while overlays
  56       (delete-overlay (pop overlays)))))
  57
  58 ;;; Mule functions.
  59
  60 (defun gnus-mule-max-width-function (el max-width)
  61   `(let* ((val (eval (, el)))
  62           (valstr (if (numberp val)
  63                       (int-to-string val) val)))
  64      (if (> (length valstr) ,max-width)
  65          (truncate-string-to-width valstr ,max-width)
  66        valstr)))
  67
  68 (eval-and-compile
  69   (if (featurep 'xemacs)
  70       (gnus-xmas-define)
  71     (defvar gnus-mouse-face-prop 'mouse-face
  72       "Property used for highlighting mouse regions.")))
  73
  74 (defvar gnus-tmp-unread)
  75 (defvar gnus-tmp-replied)
  76 (defvar gnus-tmp-score-char)
  77 (defvar gnus-tmp-indentation)
  78 (defvar gnus-tmp-opening-bracket)
  79 (defvar gnus-tmp-lines)
  80 (defvar gnus-tmp-name)
  81 (defvar gnus-tmp-closing-bracket)
  82 (defvar gnus-tmp-subject-or-nil)
  83 (defvar gnus-check-before-posting)
  84 (defvar gnus-mouse-face)
  85 (defvar gnus-group-buffer)
  86
  87 (defun gnus-ems-redefine ()
  88   (cond
  89    ((featurep 'xemacs)
  90     (gnus-xmas-redefine))
  91
  92    ((featurep 'mule)
  93     ;; Mule and new Emacs definitions
  94
  95     ;; [Note] Now there are three kinds of mule implementations,
  96     ;; original MULE, XEmacs/mule and Emacs 20+ including
  97     ;; MULE features.  Unfortunately these APIs are different.  In
  98     ;; particular, Emacs (including original Mule) and XEmacs are
  99     ;; quite different.  However, this version of Gnus doesn't support
 100     ;; anything other than XEmacs 20+ and Emacs 20.3+.
 101
 102     ;; Predicates to check are following:
 103     ;; (boundp 'MULE) is t only if Mule (original; anything older than
 104     ;;                     Mule 2.3) is running.
 105     ;; (featurep 'mule) is t when other mule variants are running.
 106
 107     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 108     ;; (featurep 'xemacs).  In this case, the implementation for
 109     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 110
 111     (defvar gnus-summary-display-table nil
 112       "Display table used in summary mode buffers.")
 113     (defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
 114
 115     (when (boundp 'gnus-check-before-posting)
 116       (setq gnus-check-before-posting
 117             (delq 'long-lines
 118                   (delq 'control-chars gnus-check-before-posting))))
 119
 120     (defun gnus-summary-line-format-spec ()
 121       (insert gnus-tmp-unread gnus-tmp-replied
 122               gnus-tmp-score-char gnus-tmp-indentation)
 123       (put-text-property
 124        (point)
 125        (progn
 126          (insert
 127           gnus-tmp-opening-bracket
 128           (format "%4d: %-20s"
 129                   gnus-tmp-lines
 130                   (if (> (length gnus-tmp-name) 20)
 131                       (truncate-string-to-width gnus-tmp-name 20)
 132                     gnus-tmp-name))
 133           gnus-tmp-closing-bracket)
 134          (point))
 135        gnus-mouse-face-prop gnus-mouse-face)
 136       (insert " " gnus-tmp-subject-or-nil "\n")))))
 137
 138 ;; Clone of `appt-select-lowest-window' in appt.el.
 139 (defun gnus-select-lowest-window ()
 140 "Select the lowest window on the frame."
 141   (let ((lowest-window (selected-window))
 142         (bottom-edge (nth 3 (window-edges))))
 143     (walk-windows (lambda (w)
 144                     (let ((next-bottom-edge (nth 3 (window-edges w))))
 145                       (when (< bottom-edge next-bottom-edge)
 146                         (setq bottom-edge next-bottom-edge
 147                               lowest-window w)))))
 148     (select-window lowest-window)))
 149
 150 (defun gnus-region-active-p ()
 151   "Say whether the region is active."
 152   (and (boundp 'transient-mark-mode)
 153        transient-mark-mode
 154        (boundp 'mark-active)
 155        mark-active))
 156
 157 (defun gnus-mark-active-p ()
 158   "Non-nil means the mark and region are currently active in this buffer."
 159   mark-active) ; aliased to region-exists-p in XEmacs.
 160
 161 (autoload 'gnus-alive-p "gnus-util")
 162 (autoload 'mm-disable-multibyte "mm-util")
 163
 164 ;;; Image functions.
 165
 166 (defun gnus-image-type-available-p (type)
 167   (and (fboundp 'image-type-available-p)
 168        (image-type-available-p type)
 169        (if (fboundp 'display-images-p)
 170            (display-images-p)
 171          t)))
 172
 173 (defun gnus-create-image (file &optional type data-p &rest props)
 174   (let ((face (plist-get props :face)))
 175     (when face
 176       (setq props (plist-put props :foreground (face-foreground face)))
 177       (setq props (plist-put props :background (face-background face))))
 178     (ignore-errors
 179       (apply 'create-image file type data-p props))))
 180
 181 (defun gnus-put-image (glyph &optional string category)
 182   (let ((point (point)))
 183     (insert-image glyph (or string " "))
 184     (put-text-property point (point) 'gnus-image-category category)
 185     (unless string
 186       (put-text-property (1- (point)) (point)
 187                          'gnus-image-text-deletable t))
 188     glyph))
 189
 190 (defun gnus-remove-image (image &optional category)
 191   "Remove the image matching IMAGE and CATEGORY found first."
 192   (let ((start (point-min))
 193         val end)
 194     (while (and (not end)
 195                 (or (setq val (get-text-property start 'display))
 196                     (and (setq start
 197                                (next-single-property-change start 'display))
 198                          (setq val (get-text-property start 'display)))))
 199       (setq end (or (next-single-property-change start 'display)
 200                     (point-max)))
 201       (if (and (equal val image)
 202                (equal (get-text-property start 'gnus-image-category)
 203                       category))
 204           (progn
 205             (put-text-property start end 'display nil)
 206             (when (get-text-property start 'gnus-image-text-deletable)
 207               (delete-region start end)))
 208         (unless (= end (point-max))
 209           (setq start end
 210                 end nil))))))
 211
 212 (defmacro gnus-string-mark-left-to-right (string)
 213   (if (fboundp 'bidi-string-mark-left-to-right)
 214       `(bidi-string-mark-left-to-right ,string)
 215     string))
 216
 217 (eval-and-compile
 218   ;; XEmacs does not have window-inside-pixel-edges
 219   (defalias 'gnus-window-inside-pixel-edges
 220     (if (fboundp 'window-inside-pixel-edges)
 221         'window-inside-pixel-edges
 222       'window-pixel-edges))
 223
 224   (if (fboundp 'set-process-plist)
 225       (progn
 226         (defalias 'gnus-set-process-plist 'set-process-plist)
 227         (defalias 'gnus-process-plist 'process-plist)
 228         (defalias 'gnus-process-get 'process-get)
 229         (defalias 'gnus-process-put 'process-put))
 230     (defun gnus-set-process-plist (process plist)
 231       "Replace the plist of PROCESS with PLIST.  Returns PLIST."
 232       (put 'gnus-process-plist-internal process plist))
 233
 234     (defun gnus-process-plist (process)
 235       "Return the plist of PROCESS."
 236       ;; This form works but can't prevent the plist data from
 237       ;; growing infinitely.
 238       ;;(get 'gnus-process-plist-internal process)
 239       (let* ((plist (symbol-plist 'gnus-process-plist-internal))
 240              (tem (memq process plist)))
 241         (prog1
 242             (cadr tem)
 243           ;; Remove it from the plist data.
 244           (when tem
 245             (if (eq plist tem)
 246                 (progn
 247                   (setcar plist (caddr plist))
 248                   (setcdr plist (or (cdddr plist) '(nil))))
 249               (setcdr (nthcdr (- (length plist) (length tem) 1) plist)
 250                       (cddr tem)))))))
 251
 252     (defun gnus-process-get (process propname)
 253       "Return the value of PROCESS' PROPNAME property.
 254 This is the last value stored with `(gnus-process-put PROCESS PROPNAME VALUE)'."
 255       (plist-get (gnus-process-plist process) propname))
 256
 257     (defun gnus-process-put (process propname value)
 258       "Change PROCESS' PROPNAME property to VALUE.
 259 It can be retrieved with `(gnus-process-get PROCESS PROPNAME)'."
 260       (gnus-set-process-plist process
 261                               (plist-put (gnus-process-plist process)
 262                                          propname value)))))
 263
 264 (provide 'gnus-ems)
 265
 266 ;;; gnus-ems.el ends here