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