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