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,96,97,98,99 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;         Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
   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 2, or (at your option)
  13 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 ;;; Function aliases later to be redefined for XEmacs usage.
  32
  33 (defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
  34   "Non-nil if running under XEmacs.")
  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 gnus-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 (or (fboundp 'mail-file-babyl-p)
  52     (fset 'mail-file-babyl-p 'rmail-file-p))
  53
  54 ;;; Mule functions.
  55
  56 (eval-and-compile
  57   (if (string-match "XEmacs\\|Lucid" emacs-version)
  58       nil
  59
  60     (defvar gnus-mouse-face-prop 'mouse-face
  61       "Property used for highlighting mouse regions."))
  62
  63   (cond
  64    ((string-match "XEmacs\\|Lucid" emacs-version)
  65     (gnus-xmas-define))
  66
  67    ((or (not (boundp 'emacs-minor-version))
  68         (and (< emacs-major-version 20)
  69              (< emacs-minor-version 30)))
  70     ;; Remove the `intangible' prop.
  71     (let ((props (and (boundp 'gnus-hidden-properties)
  72                       gnus-hidden-properties)))
  73       (while (and props (not (eq (car (cdr props)) 'intangible)))
  74         (setq props (cdr props)))
  75       (when props
  76         (setcdr props (cdr (cdr (cdr props))))))
  77     (unless (fboundp 'buffer-substring-no-properties)
  78       (defun buffer-substring-no-properties (beg end)
  79         (format "%s" (buffer-substring beg end)))))
  80
  81    ((boundp 'MULE)
  82     (provide 'gnusutil))))
  83
  84 (eval-and-compile
  85   (cond
  86    ((not window-system)
  87     (defun gnus-dummy-func (&rest args))
  88     (let ((funcs '(mouse-set-point set-face-foreground
  89                                    set-face-background x-popup-menu)))
  90       (while funcs
  91         (unless (fboundp (car funcs))
  92           (fset (car funcs) 'gnus-dummy-func))
  93         (setq funcs (cdr funcs)))))))
  94
  95 (eval-and-compile
  96   (let ((case-fold-search t))
  97     (cond
  98      ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
  99                     (symbol-name system-type))
 100       (setq nnheader-file-name-translation-alist
 101             (append nnheader-file-name-translation-alist
 102                     '((?: . ?_)
 103                       (?+ . ?-))))))))
 104
 105 (defvar gnus-tmp-unread)
 106 (defvar gnus-tmp-replied)
 107 (defvar gnus-tmp-score-char)
 108 (defvar gnus-tmp-indentation)
 109 (defvar gnus-tmp-opening-bracket)
 110 (defvar gnus-tmp-lines)
 111 (defvar gnus-tmp-name)
 112 (defvar gnus-tmp-closing-bracket)
 113 (defvar gnus-tmp-subject-or-nil)
 114
 115 (defun gnus-ems-redefine ()
 116   (cond
 117    ((string-match "XEmacs\\|Lucid" emacs-version)
 118     (gnus-xmas-redefine))
 119
 120    ((featurep 'mule)
 121     ;; Mule and new Emacs definitions
 122
 123     ;; [Note] Now there are three kinds of mule implementations,
 124     ;; original MULE, XEmacs/mule and beta version of Emacs including
 125     ;; some mule features. Unfortunately these API are different. In
 126     ;; particular, Emacs (including original MULE) and XEmacs are
 127     ;; quite different.
 128     ;; Predicates to check are following:
 129     ;; (boundp 'MULE) is t only if MULE (original; anything older than
 130     ;;                     Mule 2.3) is running.
 131     ;; (featurep 'mule) is t when every mule variants are running.
 132
 133     ;; These implementations may be able to share between original
 134     ;; MULE and beta version of new Emacs. In addition, it is able to
 135     ;; detect XEmacs/mule by (featurep 'mule) and to check variable
 136     ;; `emacs-version'. In this case, implementation for XEmacs/mule
 137     ;; may be able to share between XEmacs and XEmacs/mule.
 138
 139     (defvar gnus-summary-display-table nil
 140       "Display table used in summary mode buffers.")
 141     (fset 'gnus-summary-set-display-table (lambda ()))
 142
 143     (if (fboundp 'truncate-string-to-width)
 144         (fset 'gnus-truncate-string 'truncate-string-to-width)
 145       (fset 'gnus-truncate-string 'truncate-string))
 146
 147     (defun gnus-tilde-max-form (el max-width)
 148       "Return a form that limits EL to MAX-WIDTH."
 149       (let ((max (abs max-width)))
 150         (if (symbolp el)
 151             `(if (> (string-width ,el) ,max)
 152                  ,(if (< max-width 0)
 153                       `(gnus-truncate-string
 154                         ,el (string-width ,el)
 155                         (- (string-width ,el) ,max))
 156                     `(gnus-truncate-string ,el ,max))
 157                ,el)
 158           `(let ((val (eval ,el)))
 159              (if (> (string-width val) ,max)
 160                  ,(if (< max-width 0)
 161                       `(gnus-truncate-string
 162                         val (string-width val)
 163                         (- (string-width val) ,max))
 164                     `(gnus-truncate-string val ,max))
 165                val)))))
 166
 167     (defun gnus-tilde-cut-form (el cut-width)
 168       "Return a form that cuts CUT-WIDTH off of EL."
 169       (let ((cut (abs cut-width)))
 170         (if (symbolp el)
 171             `(if (> (string-width ,el) ,cut)
 172                  ,(if (< cut-width 0)
 173                       `(gnus-truncate-string
 174                         ,el (- (string-width ,el) ,cut))
 175                     `(gnus-truncate-string
 176                       ,el (- (string-width ,el) ,cut) ,cut))
 177                ,el)
 178           `(let ((val (eval ,el)))
 179              (if (> (string-width val) ,cut)
 180                  ,(if (< cut-width 0)
 181                       `(gnus-truncate-string
 182                         val (- (string-width val) ,cut))
 183                     `(gnus-truncate-string
 184                       val (- (string-width val) ,cut) ,cut))
 185                val)))))
 186
 187     (when (boundp 'gnus-check-before-posting)
 188       (setq gnus-check-before-posting
 189             (delq 'long-lines
 190                   (delq 'control-chars gnus-check-before-posting))))
 191
 192     )))
 193
 194 (defun gnus-region-active-p ()
 195   "Say whether the region is active."
 196   (and (boundp 'transient-mark-mode)
 197        transient-mark-mode
 198        (boundp 'mark-active)
 199        mark-active))
 200
 201 (defun gnus-add-minor-mode (mode name map)
 202   (if (fboundp 'add-minor-mode)
 203       (add-minor-mode mode name map)
 204     (set (make-local-variable mode) t)
 205     (unless (assq mode minor-mode-alist)
 206       (push `(,mode ,name) minor-mode-alist))
 207     (unless (assq mode minor-mode-map-alist)
 208       (push (cons mode map)
 209             minor-mode-map-alist))))
 210
 211 (defun gnus-x-splash ()
 212   "Show a splash screen using a pixmap in the current buffer."
 213   (let ((dir (nnheader-find-etc-directory "gnus"))
 214         pixmap file height beg i)
 215     (save-excursion
 216       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 217       (let ((buffer-read-only nil))
 218         (erase-buffer)
 219         (when (and dir
 220                    (file-exists-p (setq file (concat dir "x-splash"))))
 221           (with-temp-buffer
 222             (insert-file-contents-as-binary file)
 223             (goto-char (point-min))
 224             (ignore-errors
 225               (setq pixmap (read (current-buffer))))))
 226         (when pixmap
 227           (unless (facep 'gnus-splash)
 228             (make-face 'gnus-splash))
 229           (setq height (/ (car pixmap) (frame-char-height))
 230                 width (/ (cadr pixmap) (frame-char-width)))
 231           (set-face-foreground 'gnus-splash "Brown")
 232           (set-face-stipple 'gnus-splash pixmap)
 233           (insert-char ?\n (* (/ (window-height) 2 height) height))
 234           (setq i height)
 235           (while (> i 0)
 236             (insert-char ?  (* (/ (window-width) 2 width) width))
 237             (setq beg (point))
 238             (insert-char ?  width)
 239             (set-text-properties beg (point) '(face gnus-splash))
 240             (insert "\n")
 241             (decf i))
 242           (goto-char (point-min))
 243           (sit-for 0))))))
 244
 245 (defun-maybe assoc-ignore-case (key alist)
 246   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 247   (setq key (downcase key))
 248   (let (element)
 249     (while (and alist (not element))
 250       (if (equal key (downcase (car (car alist))))
 251           (setq element (car alist)))
 252       (setq alist (cdr alist)))
 253     element))
 254
 255 \f
 256 ;;; Language support staffs.
 257
 258 (defvar-maybe current-language-environment "English"
 259   "The language environment.")
 260
 261 (defvar-maybe language-info-alist nil
 262   "Alist of language environment definitions.")
 263
 264 (defun-maybe get-language-info (lang-env key)
 265   "Return information listed under KEY for language environment LANG-ENV."
 266   (if (symbolp lang-env)
 267       (setq lang-env (symbol-name lang-env)))
 268   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 269     (if lang-slot
 270         (cdr (assq key (cdr lang-slot))))))
 271
 272 (defun-maybe set-language-info (lang-env key info)
 273   "Modify part of the definition of language environment LANG-ENV."
 274   (if (symbolp lang-env)
 275       (setq lang-env (symbol-name lang-env)))
 276   (let (lang-slot key-slot)
 277     (setq lang-slot (assoc lang-env language-info-alist))
 278     (if (null lang-slot)                ; If no slot for the language, add it.
 279         (setq lang-slot (list lang-env)
 280               language-info-alist (cons lang-slot language-info-alist)))
 281     (setq key-slot (assq key lang-slot))
 282     (if (null key-slot)                 ; If no slot for the key, add it.
 283         (progn
 284           (setq key-slot (list key))
 285           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 286     (setcdr key-slot info)))
 287
 288 (provide 'gnus-ems)
 289
 290 ;; Local Variables:
 291 ;; byte-compile-warnings: '(redefine callargs)
 292 ;; End:
 293
 294 ;;; gnus-ems.el ends here