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