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