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