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