git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-ems.el

   1 ;;; gnus-ems.el --- functions for making Semi-gnus work under different Emacsen
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4 ;;   2004, 2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;         Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
   8 ;; Keywords: news
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 (eval-when-compile
  32   (require 'cl)
  33   (require 'ring))
  34
  35 ;;; Function aliases later to be redefined for XEmacs usage.
  36
  37 (defvar gnus-mouse-2 [mouse-2])
  38 (defvar gnus-down-mouse-3 [down-mouse-3])
  39 (defvar gnus-down-mouse-2 [down-mouse-2])
  40 (defvar gnus-widget-button-keymap nil)
  41 (defvar gnus-mode-line-modified
  42   (if (featurep 'xemacs)
  43       '("--**-" . "-----")
  44     '("**" "--")))
  45
  46 (eval-and-compile
  47   (autoload 'gnus-xmas-define "gnus-xmas")
  48   (autoload 'gnus-xmas-redefine "gnus-xmas")
  49   (autoload 'gnus-get-buffer-create "gnus")
  50   (autoload 'nnheader-find-etc-directory "nnheader"))
  51
  52 (autoload 'smiley-region "smiley")
  53
  54 (defun gnus-kill-all-overlays ()
  55   "Delete all overlays in the current buffer."
  56   (let* ((overlayss (overlay-lists))
  57          (buffer-read-only nil)
  58          (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
  59     (while overlays
  60       (delete-overlay (pop overlays)))))
  61
  62 ;;; Mule functions.
  63
  64 (eval-and-compile
  65   (if (featurep 'xemacs)
  66       (gnus-xmas-define)
  67     (defvar gnus-mouse-face-prop 'mouse-face
  68       "Property used for highlighting mouse regions.")))
  69
  70 (eval-when-compile
  71   (defvar gnus-tmp-unread)
  72   (defvar gnus-tmp-replied)
  73   (defvar gnus-tmp-score-char)
  74   (defvar gnus-tmp-indentation)
  75   (defvar gnus-tmp-opening-bracket)
  76   (defvar gnus-tmp-lines)
  77   (defvar gnus-tmp-name)
  78   (defvar gnus-tmp-closing-bracket)
  79   (defvar gnus-tmp-subject-or-nil)
  80   (defvar gnus-check-before-posting)
  81   (defvar gnus-mouse-face)
  82   (defvar gnus-group-buffer))
  83
  84 (defun gnus-ems-redefine ()
  85   (cond
  86    ((featurep 'xemacs)
  87     (gnus-xmas-redefine))
  88
  89    ((featurep 'mule)
  90     ;; Mule and new Emacs definitions
  91
  92     ;; [Note] Now there are two kinds of mule implementations,
  93     ;; XEmacs/mule and Emacs 20+ including Mule features.
  94     ;; Unfortunately these APIs are different.  In particular, Emacs
  95     ;; and XEmacs are quite different.  However, this version of Gnus
  96     ;; doesn't support anything other than XEmacs 21+ and Emacs 21+.
  97
  98     ;; Predicate to check is the following:
  99     ;; (featurep 'mule) is t when other mule variants are running.
 100
 101     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 102     ;; (featurep 'xemacs).  In this case, the implementation for
 103     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 104
 105     (defvar gnus-summary-display-table nil
 106       "Display table used in summary mode buffers.")
 107
 108     (defalias 'gnus-summary-set-display-table (lambda ()))
 109
 110     (if (fboundp 'truncate-string-to-width)
 111         (fset 'gnus-truncate-string 'truncate-string-to-width)
 112       (fset 'gnus-truncate-string 'truncate-string))
 113
 114     (when (boundp 'gnus-check-before-posting)
 115       (setq gnus-check-before-posting
 116             (delq 'long-lines
 117                   (delq 'control-chars gnus-check-before-posting))))
 118     ))
 119   (when (featurep 'mule)
 120     (defun gnus-tilde-max-form (el max-width)
 121       "Return a form that limits EL to MAX-WIDTH."
 122       (let ((max (abs max-width)))
 123         (if (symbolp el)
 124             (if (< max-width 0)
 125                 `(let ((width (string-width ,el)))
 126                    (gnus-truncate-string ,el width (- width ,max)))
 127               `(gnus-truncate-string ,el ,max))
 128           (if (< max-width 0)
 129               `(let* ((val (eval ,el))
 130                       (width (string-width val)))
 131                  (gnus-truncate-string val width (- width ,max)))
 132             `(let ((val (eval ,el)))
 133                (gnus-truncate-string val ,max))))))
 134
 135     (defun gnus-tilde-cut-form (el cut-width)
 136       "Return a form that cuts CUT-WIDTH off of EL."
 137       (let ((cut (abs cut-width)))
 138         (if (symbolp el)
 139             (if (< cut-width 0)
 140                 `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
 141               `(gnus-truncate-string ,el (string-width ,el) ,cut))
 142           (if (< cut-width 0)
 143               `(let ((val (eval ,el)))
 144                  (gnus-truncate-string val (- (string-width val) ,cut)))
 145             `(let ((val (eval ,el)))
 146                (gnus-truncate-string val (string-width val) ,cut))))))
 147     ))
 148
 149 ;; Clone of `appt-select-lowest-window' in appt.el.
 150 (defun gnus-select-lowest-window ()
 151 "Select the lowest window on the frame."
 152   (let ((lowest-window (selected-window))
 153         (bottom-edge (nth 3 (window-edges))))
 154     (walk-windows (lambda (w)
 155                     (let ((next-bottom-edge (nth 3 (window-edges w))))
 156                       (when (< bottom-edge next-bottom-edge)
 157                         (setq bottom-edge next-bottom-edge
 158                               lowest-window w)))))
 159     (select-window lowest-window)))
 160
 161 (defun gnus-region-active-p ()
 162   "Say whether the region is active."
 163   (and (boundp 'transient-mark-mode)
 164        transient-mark-mode
 165        (boundp 'mark-active)
 166        mark-active))
 167
 168 (defun gnus-mark-active-p ()
 169   "Non-nil means the mark and region are currently active in this buffer."
 170   mark-active) ; aliased to region-exists-p in XEmacs.
 171
 172 (defun gnus-x-splash ()
 173   "Show a splash screen using a pixmap in the current buffer."
 174   (let ((dir (nnheader-find-etc-directory "gnus"))
 175         pixmap file height beg i)
 176     (save-excursion
 177       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 178       (let ((buffer-read-only nil)
 179             width height)
 180         (erase-buffer)
 181         (when (and dir
 182                    (file-exists-p (setq file
 183                                         (expand-file-name "x-splash" dir))))
 184           (let ((coding-system-for-read 'raw-text)
 185                 default-enable-multibyte-characters)
 186             (with-temp-buffer
 187               (insert-file-contents-as-binary file)
 188               (goto-char (point-min))
 189               (ignore-errors
 190                 (setq pixmap (read (current-buffer)))))))
 191         (when pixmap
 192           (make-face 'gnus-splash)
 193           (setq height (/ (car pixmap) (frame-char-height))
 194                 width (/ (cadr pixmap) (frame-char-width)))
 195           (set-face-foreground 'gnus-splash "Brown")
 196           (set-face-stipple 'gnus-splash pixmap)
 197           (insert-char ?\n (* (/ (window-height) 2 height) height))
 198           (setq i height)
 199           (while (> i 0)
 200             (insert-char ?\  (* (/ (window-width) 2 width) width))
 201             (setq beg (point))
 202             (insert-char ?\  width)
 203             (set-text-properties beg (point) '(face gnus-splash))
 204             (insert ?\n)
 205             (decf i))
 206           (goto-char (point-min))
 207           (sit-for 0))))))
 208
 209 ;;; Image functions.
 210
 211 (defun gnus-image-type-available-p (type)
 212   (and (fboundp 'image-type-available-p)
 213        (image-type-available-p type)))
 214
 215 (defun gnus-create-image (file &optional type data-p &rest props)
 216   (let ((face (plist-get props :face)))
 217     (when face
 218       (setq props (plist-put props :foreground (face-foreground face)))
 219       (setq props (plist-put props :background (face-background face))))
 220     (apply 'create-image file type data-p props)))
 221
 222 (defun gnus-put-image (glyph &optional string category)
 223   (let ((point (point)))
 224     (insert-image glyph (or string " "))
 225     (put-text-property point (point) 'gnus-image-category category)
 226     (unless string
 227       (put-text-property (1- (point)) (point)
 228                          'gnus-image-text-deletable t))
 229     glyph))
 230
 231 (defun gnus-remove-image (image &optional category)
 232   "Remove the image matching IMAGE and CATEGORY found first."
 233   (let ((start (point-min))
 234         val end)
 235     (while (and (not end)
 236                 (or (setq val (get-text-property start 'display))
 237                     (and (setq start
 238                                (next-single-property-change start 'display))
 239                          (setq val (get-text-property start 'display)))))
 240       (setq end (or (next-single-property-change start 'display)
 241                     (point-max)))
 242       (if (and (equal val image)
 243                (equal (get-text-property start 'gnus-image-category)
 244                       category))
 245           (progn
 246             (put-text-property start end 'display nil)
 247             (when (get-text-property start 'gnus-image-text-deletable)
 248               (delete-region start end)))
 249         (unless (= end (point-max))
 250           (setq start end
 251                 end nil))))))
 252
 253 (defun-maybe assoc-ignore-case (key alist)
 254   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 255   (setq key (downcase key))
 256   (let (element)
 257     (while (and alist (not element))
 258       (if (equal key (downcase (car (car alist))))
 259           (setq element (car alist)))
 260       (setq alist (cdr alist)))
 261     element))
 262
 263 \f
 264 ;;; Language support staffs.
 265
 266 (defvar-maybe current-language-environment "English"
 267   "The language environment.")
 268
 269 (defvar-maybe language-info-alist nil
 270   "Alist of language environment definitions.")
 271
 272 (defun-maybe get-language-info (lang-env key)
 273   "Return information listed under KEY for language environment LANG-ENV."
 274   (if (symbolp lang-env)
 275       (setq lang-env (symbol-name lang-env)))
 276   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 277     (if lang-slot
 278         (cdr (assq key (cdr lang-slot))))))
 279
 280 (defun-maybe set-language-info (lang-env key info)
 281   "Modify part of the definition of language environment LANG-ENV."
 282   (if (symbolp lang-env)
 283       (setq lang-env (symbol-name lang-env)))
 284   (let (lang-slot key-slot)
 285     (setq lang-slot (assoc lang-env language-info-alist))
 286     (if (null lang-slot)                ; If no slot for the language, add it.
 287         (setq lang-slot (list lang-env)
 288               language-info-alist (cons lang-slot language-info-alist)))
 289     (setq key-slot (assq key lang-slot))
 290     (if (null key-slot)                 ; If no slot for the key, add it.
 291         (progn
 292           (setq key-slot (list key))
 293           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 294     (setcdr key-slot info)))
 295
 296 (provide 'gnus-ems)
 297
 298 ;;; gnus-ems.el ends here