cgit.sxemacs.org Git - gnus/blob - lisp/gnus-ems.el

   1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
   2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   5 ;; Keywords: news
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (defvar gnus-mouse-2 [mouse-2])
  31
  32 (defalias 'gnus-make-overlay 'make-overlay)
  33 (defalias 'gnus-overlay-put 'overlay-put)
  34 (defalias 'gnus-move-overlay 'move-overlay)
  35 (defalias 'gnus-overlay-end 'overlay-end)
  36 (defalias 'gnus-extent-detached-p 'ignore)
  37 (defalias 'gnus-group-remove-excess-properties 'ignore)
  38 (defalias 'gnus-topic-remove-excess-properties 'ignore)
  39 (defalias 'gnus-extent-start-open 'ignore)
  40 (defalias 'gnus-set-text-properties 'set-text-properties)
  41 (defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
  42 (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
  43
  44 (eval-and-compile
  45   (autoload 'gnus-xmas-define "gnus-xmas")
  46   (autoload 'gnus-xmas-redefine "gnus-xmas")
  47   (autoload 'appt-select-lowest-window "appt.el"))
  48
  49 (or (fboundp 'mail-file-babyl-p)
  50     (fset 'mail-file-babyl-p 'rmail-file-p))
  51
  52 ;;; Mule functions.
  53
  54 (defun gnus-mule-truncate-string (str width)
  55   (let ((w (string-width str))
  56         (col 0) (idx 0) (p-idx 0) chr)
  57     (if (<= w width)
  58         str
  59       (while (< col width)
  60         (setq chr (aref str idx)
  61               col (+ col (char-width chr))
  62               p-idx idx
  63               idx (+ idx (char-bytes chr))
  64               ))
  65       (substring str 0 (if (= col width)
  66                            idx
  67                          p-idx)))))
  68
  69 (defun gnus-mule-cite-add-face (number prefix face)
  70   ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
  71   (if face
  72       (let ((inhibit-point-motion-hooks t)
  73             from to)
  74         (goto-line number)
  75         (if (boundp 'MULE)
  76             (forward-char (chars-in-string prefix))
  77           (forward-char (length prefix)))
  78         (skip-chars-forward " \t")
  79         (setq from (point))
  80         (end-of-line 1)
  81         (skip-chars-backward " \t")
  82         (setq to (point))
  83         (if (< from to)
  84             (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
  85
  86 (defun gnus-mule-max-width-function (el max-width)
  87   (` (let* ((val (eval (, el)))
  88             (valstr (if (numberp val)
  89                         (int-to-string val) val)))
  90        (if (> (length valstr) (, max-width))
  91            (gnus-truncate-string valstr (, max-width))
  92          valstr))))
  93
  94 (eval-and-compile
  95   (if (string-match "XEmacs\\|Lucid" emacs-version)
  96       ()
  97
  98     (defvar gnus-mouse-face-prop 'mouse-face
  99       "Property used for highlighting mouse regions.")
 100
 101     ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 102     (defvar gnus-display-type
 103       (condition-case nil
 104           (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
 105             (cond (display-resource (intern (downcase display-resource)))
 106                   ((x-display-color-p) 'color)
 107                   ((x-display-grayscale-p) 'grayscale)
 108                   (t 'mono)))
 109         (error 'mono))
 110       "A symbol indicating the display Emacs is running under.
 111 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 112 guesses this display attribute wrongly, either set this variable in
 113 your `~/.emacs' or set the resource `Emacs.displayType' in your
 114 `~/.Xdefaults'. See also `gnus-background-mode'.
 115
 116 This is a meta-variable that will affect what default values other
 117 variables get.  You would normally not change this variable, but
 118 pounce directly on the real variables themselves.")
 119
 120     (defvar gnus-background-mode
 121       (condition-case nil
 122           (let ((bg-resource (x-get-resource ".backgroundMode"
 123                                              "BackgroundMode"))
 124                 (params (frame-parameters)))
 125             (cond (bg-resource (intern (downcase bg-resource)))
 126                   ((and (cdr (assq 'background-color params))
 127                         (< (apply '+ (x-color-values
 128                                       (cdr (assq 'background-color params))))
 129                            (/ (apply '+ (x-color-values "white")) 3)))
 130                    'dark)
 131                   (t 'light)))
 132         (error 'light))
 133       "A symbol indicating the Emacs background brightness.
 134 The symbol should be one of `light' or `dark'.
 135 If Emacs guesses this frame attribute wrongly, either set this variable in
 136 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 137 `~/.Xdefaults'.
 138 See also `gnus-display-type'.
 139
 140 This is a meta-variable that will affect what default values other
 141 variables get.  You would normally not change this variable, but
 142 pounce directly on the real variables themselves."))
 143
 144   (cond
 145    ((string-match "XEmacs\\|Lucid" emacs-version)
 146     (gnus-xmas-define))
 147
 148    ((or (not (boundp 'emacs-minor-version))
 149         (< emacs-minor-version 30))
 150     ;; Remove the `intangible' prop.
 151     (let ((props (and (boundp 'gnus-hidden-properties)
 152                       gnus-hidden-properties)))
 153       (while (and props (not (eq (car (cdr props)) 'intangible)))
 154         (setq props (cdr props)))
 155       (and props (setcdr props (cdr (cdr (cdr props))))))
 156     (or (fboundp 'buffer-substring-no-properties)
 157         (defun buffer-substring-no-properties (beg end)
 158           (format "%s" (buffer-substring beg end)))))
 159
 160    ((boundp 'MULE)
 161     (provide 'gnusutil))))
 162
 163 (eval-and-compile
 164   (cond
 165    ((not window-system)
 166     (defun gnus-dummy-func (&rest args))
 167     (let ((funcs '(mouse-set-point set-face-foreground
 168                                    set-face-background x-popup-menu)))
 169       (while funcs
 170         (or (fboundp (car funcs))
 171             (fset (car funcs) 'gnus-dummy-func))
 172         (setq funcs (cdr funcs))))))
 173   (or (fboundp 'file-regular-p)
 174       (defun file-regular-p (file)
 175         (and (not (file-directory-p file))
 176              (not (file-symlink-p file))
 177              (file-exists-p file))))
 178   (or (fboundp 'face-list)
 179       (defun face-list (&rest args))))
 180
 181 (eval-and-compile
 182   (let ((case-fold-search t))
 183     (cond
 184      ((string-match "windows-nt\\|os/2" (format "%s" system-type))
 185       (setq nnheader-file-name-translation-alist
 186             (append nnheader-file-name-translation-alist
 187                     '((?: . ?_)
 188                       (?+ . ?-))))))))
 189
 190 (defvar gnus-tmp-unread)
 191 (defvar gnus-tmp-replied)
 192 (defvar gnus-tmp-score-char)
 193 (defvar gnus-tmp-indentation)
 194 (defvar gnus-tmp-opening-bracket)
 195 (defvar gnus-tmp-lines)
 196 (defvar gnus-tmp-name)
 197 (defvar gnus-tmp-closing-bracket)
 198 (defvar gnus-tmp-subject-or-nil)
 199
 200 (defun gnus-ems-redefine ()
 201   (cond
 202    ((string-match "XEmacs\\|Lucid" emacs-version)
 203     (gnus-xmas-redefine))
 204
 205    ((boundp 'MULE)
 206     ;; Mule definitions
 207     (defalias 'gnus-truncate-string
 208       (if (fboundp 'truncate-string)
 209           'truncate-string 'gnus-mule-truncate-string))
 210
 211     (fset 'gnus-summary-make-display-table (lambda () nil))
 212     (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
 213     (fset 'gnus-max-width-function 'gnus-mule-max-width-function)
 214
 215     (if (boundp 'gnus-check-before-posting)
 216         (setq gnus-check-before-posting
 217               (delq 'long-lines
 218                     (delq 'control-chars gnus-check-before-posting))))
 219
 220     (defun gnus-summary-line-format-spec ()
 221       (insert gnus-tmp-unread gnus-tmp-replied
 222               gnus-tmp-score-char gnus-tmp-indentation)
 223       (put-text-property
 224        (point)
 225        (progn
 226          (insert
 227           gnus-tmp-opening-bracket
 228           (format "%4d: %-20s"
 229                   gnus-tmp-lines
 230                   (if (> (length gnus-tmp-name) 20)
 231                       (gnus-truncate-string gnus-tmp-name 20)
 232                     gnus-tmp-name))
 233           gnus-tmp-closing-bracket)
 234          (point))
 235        gnus-mouse-face-prop gnus-mouse-face)
 236       (insert " " gnus-tmp-subject-or-nil "\n"))
 237     )))
 238
 239
 240 (provide 'gnus-ems)
 241
 242 ;; Local Variables:
 243 ;; byte-compile-warnings: '(redefine callargs)
 244 ;; End:
 245
 246 ;;; gnus-ems.el ends here