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