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