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 (defun gnus-mule-cite-add-face (number prefix face)
  57   ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
  58   (when face
  59     (let ((inhibit-point-motion-hooks t)
  60           from to)
  61       (goto-line number)
  62       (unless (eobp)            ; Sometimes things become confused (broken).
  63         (forward-char (chars-in-string prefix))
  64         (skip-chars-forward " \t")
  65         (setq from (point))
  66         (end-of-line 1)
  67         (skip-chars-backward " \t")
  68         (setq to (point))
  69         (when (< from to)
  70           (push (setq overlay (gnus-make-overlay from to))
  71                 gnus-cite-overlay-list)
  72           (gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
  73
  74 (defvar gnus-mule-bitmap-image-file nil)
  75 (defun gnus-mule-group-startup-message (&optional x y)
  76   "Insert startup message in current buffer."
  77   ;; Insert the message.
  78   (erase-buffer)
  79   (insert
  80    (if (featurep 'bitmap)
  81      (format "              %s
  82
  83 "
  84              "" (if (and (stringp gnus-mule-bitmap-image-file)
  85                          (file-exists-p gnus-mule-bitmap-image-file))
  86                     (insert-file gnus-mule-bitmap-image-file)))
  87      (format "              %s
  88           _    ___ _             _
  89           _ ___ __ ___  __    _ ___
  90           __   _     ___    __  ___
  91               _           ___     _
  92              _  _ __             _
  93              ___   __            _
  94                    __           _
  95                     _      _   _
  96                    _      _    _
  97                       _  _    _
  98                   __  ___
  99                  _   _ _     _
 100                 _   _
 101               _    _
 102              _    _
 103             _
 104           __
 105
 106 "
 107              "")))
 108   ;; And then hack it.
 109   (gnus-indent-rigidly (point-min) (point-max)
 110                        (/ (max (- (window-width) (or x 46)) 0) 2))
 111   (goto-char (point-min))
 112   (forward-line 1)
 113   (let* ((pheight (count-lines (point-min) (point-max)))
 114          (wheight (window-height))
 115          (rest (- wheight pheight)))
 116     (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
 117   ;; Fontify some.
 118   (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
 119   (goto-char (point-min))
 120   (setq mode-line-buffer-identification (concat " " gnus-version))
 121   (setq gnus-simple-splash t)
 122   (set-buffer-modified-p t))
 123
 124 (eval-and-compile
 125   (if (string-match "XEmacs\\|Lucid" emacs-version)
 126       nil
 127
 128     (defvar gnus-mouse-face-prop 'mouse-face
 129       "Property used for highlighting mouse regions."))
 130
 131   (cond
 132    ((string-match "XEmacs\\|Lucid" emacs-version)
 133     (gnus-xmas-define))
 134
 135    ((or (not (boundp 'emacs-minor-version))
 136         (and (< emacs-major-version 20)
 137              (< emacs-minor-version 30)))
 138     ;; Remove the `intangible' prop.
 139     (let ((props (and (boundp 'gnus-hidden-properties)
 140                       gnus-hidden-properties)))
 141       (while (and props (not (eq (car (cdr props)) 'intangible)))
 142         (setq props (cdr props)))
 143       (when props
 144         (setcdr props (cdr (cdr (cdr props))))))
 145     (unless (fboundp 'buffer-substring-no-properties)
 146       (defun buffer-substring-no-properties (beg end)
 147         (format "%s" (buffer-substring beg end)))))
 148
 149    ((boundp 'MULE)
 150     (provide 'gnusutil))))
 151
 152 (eval-and-compile
 153   (cond
 154    ((not window-system)
 155     (defun gnus-dummy-func (&rest args))
 156     (let ((funcs '(mouse-set-point set-face-foreground
 157                                    set-face-background x-popup-menu)))
 158       (while funcs
 159         (unless (fboundp (car funcs))
 160           (fset (car funcs) 'gnus-dummy-func))
 161         (setq funcs (cdr funcs)))))))
 162
 163 (eval-and-compile
 164   (let ((case-fold-search t))
 165     (cond
 166      ((string-match "windows-nt\\|os/2\\|emx" (symbol-name system-type))
 167       (setq nnheader-file-name-translation-alist
 168             (append nnheader-file-name-translation-alist
 169                     '((?: . ?_)
 170                       (?+ . ?-))))))))
 171
 172 (defvar gnus-tmp-unread)
 173 (defvar gnus-tmp-replied)
 174 (defvar gnus-tmp-score-char)
 175 (defvar gnus-tmp-indentation)
 176 (defvar gnus-tmp-opening-bracket)
 177 (defvar gnus-tmp-lines)
 178 (defvar gnus-tmp-name)
 179 (defvar gnus-tmp-closing-bracket)
 180 (defvar gnus-tmp-subject-or-nil)
 181
 182 (defun gnus-ems-redefine ()
 183   (cond
 184    ((string-match "XEmacs\\|Lucid" emacs-version)
 185     (gnus-xmas-redefine))
 186
 187    ((featurep 'mule)
 188     ;; Mule and new Emacs definitions
 189
 190     ;; [Note] Now there are three kinds of mule implementations,
 191     ;; original MULE, XEmacs/mule and beta version of Emacs including
 192     ;; some mule features. Unfortunately these API are different. In
 193     ;; particular, Emacs (including original MULE) and XEmacs are
 194     ;; quite different.
 195     ;; Predicates to check are following:
 196     ;; (boundp 'MULE) is t only if MULE (original; anything older than
 197     ;;                     Mule 2.3) is running.
 198     ;; (featurep 'mule) is t when every mule variants are running.
 199
 200     ;; These implementations may be able to share between original
 201     ;; MULE and beta version of new Emacs. In addition, it is able to
 202     ;; detect XEmacs/mule by (featurep 'mule) and to check variable
 203     ;; `emacs-version'. In this case, implementation for XEmacs/mule
 204     ;; may be able to share between XEmacs and XEmacs/mule.
 205
 206     (defvar gnus-summary-display-table nil
 207       "Display table used in summary mode buffers.")
 208     (fset 'gnus-summary-set-display-table (lambda ()))
 209
 210     (if (fboundp 'truncate-string-to-width)
 211         (fset 'gnus-truncate-string 'truncate-string-to-width)
 212       (fset 'gnus-truncate-string 'truncate-string))
 213
 214     (defun gnus-tilde-max-form (el max-width)
 215       "Return a form that limits EL to MAX-WIDTH."
 216       (let ((max (abs max-width)))
 217         (if (symbolp el)
 218             `(if (> (string-width ,el) ,max)
 219                  ,(if (< max-width 0)
 220                       `(gnus-truncate-string
 221                         ,el (string-width ,el)
 222                         (- (string-width ,el) ,max))
 223                     `(gnus-truncate-string ,el ,max))
 224                ,el)
 225           `(let ((val (eval ,el)))
 226              (if (> (string-width val) ,max)
 227                  ,(if (< max-width 0)
 228                       `(gnus-truncate-string
 229                         val (string-width val)
 230                         (- (string-width val) ,max))
 231                     `(gnus-truncate-string val ,max))
 232                val)))))
 233
 234     (defun gnus-tilde-cut-form (el cut-width)
 235       "Return a form that cuts CUT-WIDTH off of EL."
 236       (let ((cut (abs cut-width)))
 237         (if (symbolp el)
 238             `(if (> (string-width ,el) ,cut)
 239                  ,(if (< cut-width 0)
 240                       `(gnus-truncate-string
 241                         ,el (- (string-width ,el) ,cut))
 242                     `(gnus-truncate-string
 243                       ,el (- (string-width ,el) ,cut) ,cut))
 244                ,el)
 245           `(let ((val (eval ,el)))
 246              (if (> (string-width val) ,cut)
 247                  ,(if (< cut-width 0)
 248                       `(gnus-truncate-string
 249                         val (- (string-width val) ,cut))
 250                     `(gnus-truncate-string
 251                       val (- (string-width val) ,cut) ,cut))
 252                val)))))
 253
 254     (when window-system
 255       (require 'path-util)
 256       (if (module-installed-p 'bitmap)
 257           (fset 'gnus-group-startup-message 'gnus-mule-group-startup-message)
 258         ))
 259
 260     (when (boundp 'gnus-check-before-posting)
 261       (setq gnus-check-before-posting
 262             (delq 'long-lines
 263                   (delq 'control-chars gnus-check-before-posting))))
 264
 265     (when (fboundp 'chars-in-string)
 266       (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face))
 267
 268     )))
 269
 270 (defun gnus-region-active-p ()
 271   "Say whether the region is active."
 272   (and (boundp 'transient-mark-mode)
 273        transient-mark-mode
 274        (boundp 'mark-active)
 275        mark-active))
 276
 277 (defun gnus-add-minor-mode (mode name map)
 278   (if (fboundp 'add-minor-mode)
 279       (add-minor-mode mode name map)
 280     (set (make-local-variable mode) t)
 281     (unless (assq mode minor-mode-alist)
 282       (push `(,mode ,name) minor-mode-alist))
 283     (unless (assq mode minor-mode-map-alist)
 284       (push (cons mode map)
 285             minor-mode-map-alist))))
 286
 287 (defun gnus-x-splash ()
 288   "Show a splash screen using a pixmap in the current buffer."
 289   (let ((dir (nnheader-find-etc-directory "gnus"))
 290         pixmap file height beg i)
 291     (save-excursion
 292       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 293       (let ((buffer-read-only nil))
 294         (erase-buffer)
 295         (when (and dir
 296                    (file-exists-p (setq file (concat dir "x-splash"))))
 297           (with-temp-file nil
 298             (insert-file-contents file)
 299             (goto-char (point-min))
 300             (ignore-errors
 301               (setq pixmap (read (current-buffer))))))
 302         (when pixmap
 303           (unless (facep 'gnus-splash)
 304             (make-face 'gnus-splash))
 305           (setq height (/ (car pixmap) (frame-char-height))
 306                 width (/ (cadr pixmap) (frame-char-width)))
 307           (set-face-foreground 'gnus-splash "ForestGreen")
 308           (set-face-stipple 'gnus-splash pixmap)
 309           (insert-char ?\n (* (/ (window-height) 2 height) height))
 310           (setq i height)
 311           (while (> i 0)
 312             (insert-char ?  (* (/ (window-width) 2 width) width))
 313             (setq beg (point))
 314             (insert-char ?  width)
 315             (set-text-properties beg (point) '(face gnus-splash))
 316             (insert "\n")
 317             (decf i))
 318           (goto-char (point-min))
 319           (sit-for 0))))))
 320
 321 (if (fboundp 'split-string)
 322     (fset 'gnus-split-string 'split-string)
 323   (defun gnus-split-string (string pattern)
 324     "Return a list of substrings of STRING which are separated by PATTERN."
 325     (let (parts (start 0))
 326       (while (string-match pattern string start)
 327         (setq parts (cons (substring string start (match-beginning 0)) parts)
 328               start (match-end 0)))
 329       (nreverse (cons (substring string start) parts)))))
 330
 331 (defun-maybe assoc-ignore-case (key alist)
 332   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 333   (setq key (downcase key))
 334   (let (element)
 335     (while (and alist (not element))
 336       (if (equal key (downcase (car (car alist))))
 337           (setq element (car alist)))
 338       (setq alist (cdr alist)))
 339     element))
 340
 341 \f
 342 ;;; Language support staffs.
 343
 344 (defvar-maybe current-language-environment "English"
 345   "The language environment.")
 346
 347 (defvar-maybe language-info-alist nil
 348   "Alist of language environment definitions.")
 349
 350 (defun-maybe get-language-info (lang-env key)
 351   "Return information listed under KEY for language environment LANG-ENV."
 352   (if (symbolp lang-env)
 353       (setq lang-env (symbol-name lang-env)))
 354   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 355     (if lang-slot
 356         (cdr (assq key (cdr lang-slot))))))
 357
 358 (defun-maybe set-language-info (lang-env key info)
 359   "Modify part of the definition of language environment LANG-ENV."
 360   (if (symbolp lang-env)
 361       (setq lang-env (symbol-name lang-env)))
 362   (let (lang-slot key-slot)
 363     (setq lang-slot (assoc lang-env language-info-alist))
 364     (if (null lang-slot)                ; If no slot for the language, add it.
 365         (setq lang-slot (list lang-env)
 366               language-info-alist (cons lang-slot language-info-alist)))
 367     (setq key-slot (assq key lang-slot))
 368     (if (null key-slot)                 ; If no slot for the key, add it.
 369         (progn
 370           (setq key-slot (list key))
 371           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 372     (setcdr key-slot info)))
 373
 374 (provide 'gnus-ems)
 375
 376 ;; Local Variables:
 377 ;; byte-compile-warnings: '(redefine callargs)
 378 ;; End:
 379
 380 ;;; gnus-ems.el ends here