git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-ems.el

   1 ;;; gnus-ems.el --- functions for making Semi-gnus work under different Emacsen
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;         Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile
  31   (require 'cl)
  32   (require 'ring))
  33
  34 ;;; Function aliases later to be redefined for XEmacs usage.
  35
  36 (defvar gnus-mouse-2 [mouse-2])
  37 (defvar gnus-down-mouse-3 [down-mouse-3])
  38 (defvar gnus-down-mouse-2 [down-mouse-2])
  39 (defvar gnus-widget-button-keymap nil)
  40 (defvar gnus-mode-line-modified
  41   (if (featurep 'xemacs)
  42       '("--**-" . "-----")
  43     '("**" "--")))
  44
  45 (eval-and-compile
  46   (autoload 'gnus-xmas-define "gnus-xmas")
  47   (autoload 'gnus-xmas-redefine "gnus-xmas")
  48   (autoload 'gnus-get-buffer-create "gnus")
  49   (autoload 'nnheader-find-etc-directory "nnheader"))
  50
  51 (autoload 'smiley-region "smiley")
  52
  53 (defun gnus-kill-all-overlays ()
  54   "Delete all overlays in the current buffer."
  55   (let* ((overlayss (overlay-lists))
  56          (buffer-read-only nil)
  57          (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
  58     (while overlays
  59       (delete-overlay (pop overlays)))))
  60
  61 ;;; Mule functions.
  62
  63 (eval-and-compile
  64   (if (featurep 'xemacs)
  65       (gnus-xmas-define)
  66     (defvar gnus-mouse-face-prop 'mouse-face
  67       "Property used for highlighting mouse regions.")))
  68
  69 (eval-when-compile
  70   (defvar gnus-tmp-unread)
  71   (defvar gnus-tmp-replied)
  72   (defvar gnus-tmp-score-char)
  73   (defvar gnus-tmp-indentation)
  74   (defvar gnus-tmp-opening-bracket)
  75   (defvar gnus-tmp-lines)
  76   (defvar gnus-tmp-name)
  77   (defvar gnus-tmp-closing-bracket)
  78   (defvar gnus-tmp-subject-or-nil)
  79   (defvar gnus-check-before-posting)
  80   (defvar gnus-mouse-face)
  81   (defvar gnus-group-buffer))
  82
  83 (defun gnus-ems-redefine ()
  84   (cond
  85    ((featurep 'xemacs)
  86     (gnus-xmas-redefine))
  87
  88    ((featurep 'mule)
  89     ;; Mule and new Emacs definitions
  90
  91     ;; [Note] Now there are two kinds of mule implementations,
  92     ;; XEmacs/mule and Emacs 20+ including Mule features.
  93     ;; Unfortunately these APIs are different.  In particular, Emacs
  94     ;; and XEmacs are quite different.  However, this version of Gnus
  95     ;; doesn't support anything other than XEmacs 21+ and Emacs 21+.
  96
  97     ;; Predicate to check is the following:
  98     ;; (featurep 'mule) is t when other mule variants are running.
  99
 100     ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
 101     ;; (featurep 'xemacs).  In this case, the implementation for
 102     ;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
 103
 104     (defvar gnus-summary-display-table nil
 105       "Display table used in summary mode buffers.")
 106
 107     (defalias 'gnus-summary-set-display-table (lambda ()))
 108
 109     (if (fboundp 'truncate-string-to-width)
 110         (fset 'gnus-truncate-string 'truncate-string-to-width)
 111       (fset 'gnus-truncate-string 'truncate-string))
 112
 113     (when (boundp 'gnus-check-before-posting)
 114       (setq gnus-check-before-posting
 115             (delq 'long-lines
 116                   (delq 'control-chars gnus-check-before-posting))))
 117     ))
 118   (when (featurep 'mule)
 119     (defun gnus-tilde-max-form (el max-width)
 120       "Return a form that limits EL to MAX-WIDTH."
 121       (let ((max (abs max-width)))
 122         (if (symbolp el)
 123             (if (< max-width 0)
 124                 `(let ((width (string-width ,el)))
 125                    (gnus-truncate-string ,el width (- width ,max)))
 126               `(gnus-truncate-string ,el ,max))
 127           (if (< max-width 0)
 128               `(let* ((val (eval ,el))
 129                       (width (string-width val)))
 130                  (gnus-truncate-string val width (- width ,max)))
 131             `(let ((val (eval ,el)))
 132                (gnus-truncate-string val ,max))))))
 133
 134     (defun gnus-tilde-cut-form (el cut-width)
 135       "Return a form that cuts CUT-WIDTH off of EL."
 136       (let ((cut (abs cut-width)))
 137         (if (symbolp el)
 138             (if (< cut-width 0)
 139                 `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
 140               `(gnus-truncate-string ,el (string-width ,el) ,cut))
 141           (if (< cut-width 0)
 142               `(let ((val (eval ,el)))
 143                  (gnus-truncate-string val (- (string-width val) ,cut)))
 144             `(let ((val (eval ,el)))
 145                (gnus-truncate-string val (string-width val) ,cut))))))
 146     ))
 147
 148 ;; Clone of `appt-select-lowest-window' in appt.el.
 149 (defun gnus-select-lowest-window ()
 150 "Select the lowest window on the frame."
 151   (let ((lowest-window (selected-window))
 152         (bottom-edge (nth 3 (window-edges))))
 153     (walk-windows (lambda (w)
 154                     (let ((next-bottom-edge (nth 3 (window-edges w))))
 155                       (when (< bottom-edge next-bottom-edge)
 156                         (setq bottom-edge next-bottom-edge
 157                               lowest-window w)))))
 158     (select-window lowest-window)))
 159
 160 (defun gnus-region-active-p ()
 161   "Say whether the region is active."
 162   (and (boundp 'transient-mark-mode)
 163        transient-mark-mode
 164        (boundp 'mark-active)
 165        mark-active))
 166
 167 (defun gnus-mark-active-p ()
 168   "Non-nil means the mark and region are currently active in this buffer."
 169   mark-active) ; aliased to region-exists-p in XEmacs.
 170
 171 (defun gnus-x-splash ()
 172   "Show a splash screen using a pixmap in the current buffer."
 173   (let ((dir (nnheader-find-etc-directory "gnus"))
 174         pixmap file height beg i)
 175     (save-excursion
 176       (switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
 177       (let ((buffer-read-only nil)
 178             width height)
 179         (erase-buffer)
 180         (when (and dir
 181                    (file-exists-p (setq file
 182                                         (expand-file-name "x-splash" dir))))
 183           (let ((coding-system-for-read 'raw-text)
 184                 default-enable-multibyte-characters)
 185             (with-temp-buffer
 186               (insert-file-contents-as-binary file)
 187               (goto-char (point-min))
 188               (ignore-errors
 189                 (setq pixmap (read (current-buffer)))))))
 190         (when pixmap
 191           (make-face 'gnus-splash)
 192           (setq height (/ (car pixmap) (frame-char-height))
 193                 width (/ (cadr pixmap) (frame-char-width)))
 194           (set-face-foreground 'gnus-splash "Brown")
 195           (set-face-stipple 'gnus-splash pixmap)
 196           (insert-char ?\n (* (/ (window-height) 2 height) height))
 197           (setq i height)
 198           (while (> i 0)
 199             (insert-char ?\  (* (/ (window-width) 2 width) width))
 200             (setq beg (point))
 201             (insert-char ?\  width)
 202             (set-text-properties beg (point) '(face gnus-splash))
 203             (insert ?\n)
 204             (decf i))
 205           (goto-char (point-min))
 206           (sit-for 0))))))
 207
 208 ;;; Image functions.
 209
 210 (defun gnus-image-type-available-p (type)
 211   (and (fboundp 'image-type-available-p)
 212        (image-type-available-p type)))
 213
 214 (defun gnus-create-image (file &optional type data-p &rest props)
 215   (let ((face (plist-get props :face)))
 216     (when face
 217       (setq props (plist-put props :foreground (face-foreground face)))
 218       (setq props (plist-put props :background (face-background face))))
 219     (apply 'create-image file type data-p props)))
 220
 221 (defun gnus-put-image (glyph &optional string category)
 222   (let ((point (point)))
 223     (insert-image glyph (or string " "))
 224     (put-text-property point (point) 'gnus-image-category category)
 225     (unless string
 226       (put-text-property (1- (point)) (point)
 227                          'gnus-image-text-deletable t))
 228     glyph))
 229
 230 (defun gnus-remove-image (image &optional category)
 231   "Remove the image matching IMAGE and CATEGORY found first."
 232   (let ((start (point-min))
 233         val end)
 234     (while (and (not end)
 235                 (or (setq val (get-text-property start 'display))
 236                     (and (setq start
 237                                (next-single-property-change start 'display))
 238                          (setq val (get-text-property start 'display)))))
 239       (setq end (or (next-single-property-change start 'display)
 240                     (point-max)))
 241       (if (and (equal val image)
 242                (equal (get-text-property start 'gnus-image-category)
 243                       category))
 244           (progn
 245             (put-text-property start end 'display nil)
 246             (when (get-text-property start 'gnus-image-text-deletable)
 247               (delete-region start end)))
 248         (unless (= end (point-max))
 249           (setq start end
 250                 end nil))))))
 251
 252 (defun-maybe assoc-ignore-case (key alist)
 253   "Like `assoc', but assumes KEY is a string and ignores case when comparing."
 254   (setq key (downcase key))
 255   (let (element)
 256     (while (and alist (not element))
 257       (if (equal key (downcase (car (car alist))))
 258           (setq element (car alist)))
 259       (setq alist (cdr alist)))
 260     element))
 261
 262 \f
 263 ;;; Language support staffs.
 264
 265 (defvar-maybe current-language-environment "English"
 266   "The language environment.")
 267
 268 (defvar-maybe language-info-alist nil
 269   "Alist of language environment definitions.")
 270
 271 (defun-maybe get-language-info (lang-env key)
 272   "Return information listed under KEY for language environment LANG-ENV."
 273   (if (symbolp lang-env)
 274       (setq lang-env (symbol-name lang-env)))
 275   (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
 276     (if lang-slot
 277         (cdr (assq key (cdr lang-slot))))))
 278
 279 (defun-maybe set-language-info (lang-env key info)
 280   "Modify part of the definition of language environment LANG-ENV."
 281   (if (symbolp lang-env)
 282       (setq lang-env (symbol-name lang-env)))
 283   (let (lang-slot key-slot)
 284     (setq lang-slot (assoc lang-env language-info-alist))
 285     (if (null lang-slot)                ; If no slot for the language, add it.
 286         (setq lang-slot (list lang-env)
 287               language-info-alist (cons lang-slot language-info-alist)))
 288     (setq key-slot (assq key lang-slot))
 289     (if (null key-slot)                 ; If no slot for the key, add it.
 290         (progn
 291           (setq key-slot (list key))
 292           (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
 293     (setcdr key-slot info)))
 294
 295 (provide 'gnus-ems)
 296
 297 ;;; gnus-ems.el ends here