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