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 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  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
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile
  31   (require 'cl)
  32   (require 'ring))
  33
  34 ;;; Function aliases later to be redefined for XEmacs usage.
  35
  36 (defvar gnus-mouse-2 [mouse-2])
  37 (defvar gnus-down-mouse-3 [down-mouse-3])
  38 (defvar gnus-down-mouse-2 [down-mouse-2])
  39 (defvar gnus-widget-button-keymap nil)
  40 (defvar gnus-mode-line-modified
  41   (if (or (featurep 'xemacs)
  42           (< emacs-major-version 20))
  43       '("--**-" . "-----")
  44     '("**" "--")))
  45
  46 (eval-and-compile
  47   (autoload 'gnus-xmas-define "gnus-xmas")
  48   (autoload 'gnus-xmas-redefine "gnus-xmas")
  49   (autoload 'appt-select-lowest-window "appt"))
  50
  51 (cond ((featurep 'xemacs)
  52        (autoload 'smiley-region "smiley"))
  53       ;; override XEmacs version
  54       ((>= emacs-major-version 21)
  55        (autoload 'smiley-region "smiley-ems"))
  56       (t
  57        (autoload 'smiley-region "smiley-mule")))
  58
  59 (defun gnus-kill-all-overlays ()
  60   "Delete all overlays in the current buffer."
  61   (let* ((overlayss (overlay-lists))
  62          (buffer-read-only nil)
  63          (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
  64     (while overlays
  65       (delete-overlay (pop overlays)))))
  66
  67 ;;; Mule functions.
  68
  69 (eval-and-compile
  70   (defalias 'gnus-char-width
  71     (if (fboundp 'char-width)
  72         'char-width
  73       (lambda (ch) 1)))) ;; A simple hack.
  74
  75 (eval-and-compile
  76   (if (featurep 'xemacs)
  77       (gnus-xmas-define)
  78     (defvar gnus-mouse-face-prop 'mouse-face
  79       "Property used for highlighting mouse regions.")))
  80
  81 (eval-and-compile
  82   (let ((case-fold-search t))
  83     (cond
  84      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
  85                     (symbol-name system-type))
  86       (setq nnheader-file-name-translation-alist
  87             (append nnheader-file-name-translation-alist
  88                     (mapcar (lambda (c) (cons c ?_))
  89                             '(?: ?* ?\" ?< ?> ??))
  90                     (if (string-match "windows-nt\\|cygwin32"
  91                                       (symbol-name system-type))
  92                         nil
  93                       '((?+ . ?-)))))))))
  94
  95 (defvar gnus-tmp-unread)
  96 (defvar gnus-tmp-replied)
  97 (defvar gnus-tmp-score-char)
  98 (defvar gnus-tmp-indentation)
  99 (defvar gnus-tmp-opening-bracket)
 100 (defvar gnus-tmp-lines)
 101 (defvar gnus-tmp-name)
 102 (defvar gnus-tmp-closing-bracket)
 103 (defvar gnus-tmp-subject-or-nil)
 104 (defvar gnus-check-before-posting)
 105
 106 (defun gnus-ems-redefine ()
 107   (cond
 108    ((featurep 'xemacs)
 109     (gnus-xmas-redefine))
 110
 111    ((featurep 'mule)
 112     ;; Mule and new Emacs definitions
 113
 114     ;; [Note] Now there are three kinds of mule implementations,
 115     ;; original MULE, XEmacs/mule and Emacs 20+ including
 116     ;; MULE features.  Unfortunately these API are different.  In
 117     ;; particular, Emacs (including original MULE) and XEmacs are
 118     ;; quite different.  However, this version of Gnus doesn't support
 119     ;; anything other than XEmacs 20+ and Emacs 20.3+.
 120
 121     ;; Predicates to check are following:
 122     ;; (boundp 'MULE) is t only if MULE (original; anything older than
 123     ;;                     Mule 2.3) is running.
 124     ;; (featurep 'mule) is t when every mule variants are running.
 125
 126     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 127     ;; checking `emacs-version'.  In this case, the implementation for
 128     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 129
 130     (defvar gnus-summary-display-table nil
 131       "Display table used in summary mode buffers.")
 132
 133     (defalias 'gnus-summary-set-display-table (lambda ()))
 134
 135     (if (fboundp 'truncate-string-to-width)
 136         (fset 'gnus-truncate-string 'truncate-string-to-width)
 137       (fset 'gnus-truncate-string 'truncate-string))
 138
 139     (when (boundp 'gnus-check-before-posting)
 140       (setq gnus-check-before-posting
 141             (delq 'long-lines
 142                   (delq 'control-chars gnus-check-before-posting))))
 143     ))
 144   (when (featurep 'mule)
 145     (defun gnus-tilde-max-form (el max-width)
 146       "Return a form that limits EL to MAX-WIDTH."
 147       (let ((max (abs max-width)))
 148         (if (symbolp el)
 149             (if (< max-width 0)
 150                 `(let ((width (string-width ,el)))
 151                    (gnus-truncate-string ,el width (- width ,max)))
 152               `(gnus-truncate-string ,el ,max))
 153           (if (< max-width 0)
 154               `(let* ((val (eval ,el))
 155                       (width (string-width val)))
 156                  (gnus-truncate-string val width (- width ,max)))
 157             `(let ((val (eval ,el)))
 158                (gnus-truncate-string val ,max))))))
 159
 160     (defun gnus-tilde-cut-form (el cut-width)
 161       "Return a form that cuts CUT-WIDTH off of EL."
 162       (let ((cut (abs cut-width)))
 163         (if (symbolp el)
 164             (if (< cut-width 0)
 165                 `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
 166               `(gnus-truncate-string ,el (string-width ,el) ,cut))
 167           (if (< cut-width 0)
 168               `(let ((val (eval ,el)))
 169                  (gnus-truncate-string val (- (string-width val) ,cut)))
 170             `(let ((val (eval ,el)))
 171                (gnus-truncate-string val (string-width val) ,cut))))))
 172     ))
 173
 174 (defun gnus-region-active-p ()
 175   "Say whether the region is active."
 176   (and (boundp 'transient-mark-mode)
 177        transient-mark-mode
 178        (boundp 'mark-active)
 179        mark-active))
 180
 181 (if (fboundp 'add-minor-mode)
 182     (defalias 'gnus-add-minor-mode 'add-minor-mode)
 183   (defun gnus-add-minor-mode (mode name map &rest rest)
 184     (set (make-local-variable mode) t)
 185     (unless (assq mode minor-mode-alist)
 186       (push `(,mode ,name) minor-mode-alist))
 187     (unless (assq mode minor-mode-map-alist)
 188       (push (cons mode map)
 189             minor-mode-map-alist))))
 190
 191 (defun gnus-x-splash ()
 192   "Show a splash screen using a pixmap in the current buffer."
 193   (let ((dir (nnheader-find-etc-directory "gnus"))
 194         pixmap file height beg i)
 195     (save-excursion
 196       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 197       (let ((buffer-read-only nil)
 198             width height)
 199         (erase-buffer)
 200         (when (and dir
 201                    (file-exists-p (setq file
 202                                         (expand-file-name "x-splash" dir))))
 203           (with-temp-buffer
 204             (insert-file-contents-as-binary file)
 205             (goto-char (point-min))
 206             (ignore-errors
 207               (setq pixmap (read (current-buffer))))))
 208         (when pixmap
 209           (make-face 'gnus-splash)
 210           (setq height (/ (car pixmap) (frame-char-height))
 211                 width (/ (cadr pixmap) (frame-char-width)))
 212           (set-face-foreground 'gnus-splash "Brown")
 213           (set-face-stipple 'gnus-splash pixmap)
 214           (insert-char ?\n (* (/ (window-height) 2 height) height))
 215           (setq i height)
 216           (while (> i 0)
 217             (insert-char ?\  (* (/ (window-width) 2 width) width))
 218             (setq beg (point))
 219             (insert-char ?\  width)
 220             (set-text-properties beg (point) '(face gnus-splash))
 221             (insert ?\n)
 222             (decf i))
 223           (goto-char (point-min))
 224           (sit-for 0))))))
 225
 226 ;;; Image functions.
 227
 228 (defun gnus-image-type-available-p (type)
 229   (and (fboundp 'image-type-available-p)
 230        (image-type-available-p type)))
 231
 232 (defun gnus-create-image (file &optional type data-p &rest props)
 233   (let ((face (plist-get props :face)))
 234     (when face
 235       (setq props (plist-put props :foreground (face-foreground face)))
 236       (setq props (plist-put props :background (face-background face))))
 237     (apply 'create-image file type data-p props)))
 238
 239 (defun gnus-put-image (glyph &optional string)
 240   (insert-image glyph (or string " "))
 241   (unless string
 242     (put-text-property (1- (point)) (point)
 243                        'gnus-image-text-deletable t))
 244   glyph)
 245
 246 (defun gnus-remove-image (image)
 247   (dolist (position (message-text-with-property 'display))
 248     (when (equal (get-text-property position 'display) image)
 249       (put-text-property position (1+ position) 'display nil)
 250       (when (get-text-property position 'gnus-image-text-deletable)
 251         (delete-region position (1+ position))))))
 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