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