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 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
  21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (defvar gnus-mouse-2 [mouse-2])
  28 (defvar gnus-easymenu 'easymenu)
  29 (defvar gnus-group-mode-hook ())
  30 (defvar gnus-summary-mode-hook ())
  31 (defvar gnus-article-mode-hook ())
  32
  33 ;; We do not byte-compile this file, because error messages are such a
  34 ;; bore.
  35
  36 (eval
  37  '(cond
  38    ((string-match "XEmacs\\|Lucid" emacs-version)
  39     ;; XEmacs definitions.
  40
  41     (setq gnus-mouse-2 [button2])
  42     (setq gnus-easymenu 'auc-menu)
  43
  44     (or (memq 'underline (list-faces))
  45         (funcall (intern "make-face") 'underline))
  46     ;; Must avoid calling set-face-underline-p directly, because it
  47     ;; is a defsubst in emacs19, and will make the .elc files non
  48     ;; portable!
  49     (or (face-differs-from-default-p 'underline)
  50         (funcall 'set-face-underline-p 'underline t))
  51     (or (fboundp 'set-text-properties)
  52         (defun set-text-properties (start end props &optional buffer)
  53           (if (or (null buffer) (bufferp buffer))
  54               (if props
  55                   (put-text-property start end (car props) (cdr props) buffer)
  56                 (remove-text-properties start end ())))))
  57
  58     (or (fboundp 'make-overlay) (fset 'make-overlay 'make-extent))
  59     (or (fboundp 'overlay-put) (fset 'overlay-put 'set-extent-property))
  60     (or (fboundp 'move-overlay)
  61         (defun move-overlay (extent start end &optional buffer)
  62           (set-extent-endpoints extent start end)))
  63     (or (boundp 'standard-display-table) (setq standard-display-table nil))
  64     (or (boundp 'read-event) (fset 'read-event 'next-command-event))
  65
  66     (if (not gnus-visual)
  67         ()
  68       (setq gnus-group-mode-hook
  69             (cons
  70              '(lambda ()
  71                (easy-menu-add gnus-group-reading-menu)
  72                (easy-menu-add gnus-group-group-menu)
  73                (easy-menu-add gnus-group-post-menu)
  74                (easy-menu-add gnus-group-misc-menu)
  75                (gnus-install-mouse-tracker))
  76              gnus-group-mode-hook))
  77       (setq gnus-summary-mode-hook
  78             (cons
  79              '(lambda ()
  80                (easy-menu-add gnus-summary-mark-menu)
  81                (easy-menu-add gnus-summary-move-menu)
  82                (easy-menu-add gnus-summary-article-menu)
  83                (easy-menu-add gnus-summary-thread-menu)
  84                (easy-menu-add gnus-summary-misc-menu)
  85                (easy-menu-add gnus-summary-post-menu)
  86                (easy-menu-add gnus-summary-kill-menu)
  87                (gnus-install-mouse-tracker))
  88              gnus-summary-mode-hook))
  89       (setq gnus-article-mode-hook
  90             (cons
  91              '(lambda ()
  92                (easy-menu-add gnus-article-article-menu)
  93                (easy-menu-add gnus-article-treatment-menu))
  94              gnus-article-mode-hook)))
  95
  96     (defun gnus-install-mouse-tracker ()
  97       (require 'mode-motion)
  98       (setq mode-motion-hook 'mode-motion-highlight-line)))
  99
 100    ((and (not (string-match "28.9" emacs-version))
 101          (not (string-match "29" emacs-version)))
 102     (setq gnus-hidden-properties '(invisible t))
 103     (or (fboundp 'buffer-substring-no-properties)
 104         (defun buffer-substring-no-properties (beg end)
 105           (format "%s" (buffer-substring beg end)))))
 106
 107    ((boundp 'MULE)
 108     (provide 'gnusutil))
 109
 110    ))
 111
 112 (eval-and-compile
 113   (cond
 114    ((not window-system)
 115     (defun gnus-dummy-func (&rest args))
 116     (let ((funcs '(mouse-set-point set-face-foreground
 117                                    set-face-background x-popup-menu)))
 118       (while funcs
 119         (or (fboundp (car funcs))
 120             (fset (car funcs) 'gnus-dummy-func))
 121         (setq funcs (cdr funcs))))))
 122   (or (fboundp 'file-regular-p)
 123       (defun file-regular-p (file)
 124         (and (not (file-directory-p file))
 125              (not (file-symlink-p file))
 126              (file-exists-p file))))
 127   (or (fboundp 'face-list)
 128       (defun face-list (&rest args)))
 129   )
 130
 131 (defun gnus-ems-redefine ()
 132   (cond
 133    ((string-match "XEmacs\\|Lucid" emacs-version)
 134     ;; XEmacs definitions.
 135     (fset 'gnus-set-mouse-face (lambda (string) string))
 136
 137     (fset 'gnus-summary-make-display-table (lambda () nil))
 138
 139     (defun gnus-highlight-selected-summary ()
 140       ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 141       ;; Highlight selected article in summary buffer
 142       (if gnus-summary-selected-face
 143           (save-excursion
 144             (let* ((beg (progn (beginning-of-line) (point)))
 145                    (end (progn (end-of-line) (point)))
 146                    (to (max 1 (1- (or (previous-single-property-change
 147                                        end 'mouse-face nil beg) end))))
 148                    (from (1+ (or (next-single-property-change
 149                                   beg 'mouse-face nil end) beg))))
 150               (if (< to beg)
 151                   (progn
 152                     (setq from beg)
 153                     (setq to end)))
 154               (if gnus-newsgroup-selected-overlay
 155                   (delete-extent gnus-newsgroup-selected-overlay))
 156               (setq gnus-newsgroup-selected-overlay
 157                     (make-extent from to))
 158               (set-extent-face gnus-newsgroup-selected-overlay
 159                                gnus-summary-selected-face)))))
 160
 161
 162     (defun gnus-summary-recenter ()
 163       (let* ((top (cond ((< (window-height) 4) 0)
 164                         ((< (window-height) 7) 1)
 165                         (t 2)))
 166              (height (- (window-height) 2))
 167              (bottom (save-excursion (goto-char (point-max))
 168                                      (forward-line (- height))
 169                                      (point)))
 170              (window (get-buffer-window (current-buffer))))
 171         (and
 172          ;; The user has to want it,
 173          gnus-auto-center-summary
 174          ;; the article buffer must be displayed,
 175          (get-buffer-window gnus-article-buffer)
 176          ;; Set the window start to either `bottom', which is the biggest
 177          ;; possible valid number, or the second line from the top,
 178          ;; whichever is the least.
 179          (set-window-start
 180           window (min bottom (save-excursion (forward-line (- top))
 181                                              (point)))))))
 182
 183     (defun gnus-group-insert-group-line-info (group)
 184       (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
 185             (beg (point))
 186             active info)
 187         (if entry
 188             (progn
 189               (setq info (nth 2 entry))
 190               (gnus-group-insert-group-line
 191                nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
 192           (setq active (gnus-gethash group gnus-active-hashtb))
 193
 194           (gnus-group-insert-group-line
 195            nil group (if (member group gnus-zombie-list) gnus-level-zombie
 196                        gnus-level-killed)
 197            nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
 198         (save-excursion
 199          (goto-char beg)
 200          (remove-text-properties
 201           (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 202           '(gnus-group nil)))))
 203
 204     (defun gnus-copy-article-buffer (&optional article-buffer)
 205       (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 206       (buffer-disable-undo gnus-article-copy)
 207       (or (memq gnus-article-copy gnus-buffer-list)
 208           (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 209       (let ((article-buffer (or article-buffer gnus-article-buffer))
 210             buf)
 211         (if (and (get-buffer article-buffer)
 212                  (buffer-name (get-buffer article-buffer)))
 213             (save-excursion
 214               (set-buffer article-buffer)
 215               (widen)
 216               (setq buf (buffer-substring (point-min) (point-max)))
 217               (set-buffer gnus-article-copy)
 218               (erase-buffer)
 219               (insert (format "%s" buf))))))
 220
 221     (defun gnus-summary-refer-article (message-id)
 222       "Refer article specified by MESSAGE-ID.
 223 NOTE: This command only works with newsgroups that use real or simulated NNTP."
 224       (interactive "sMessage-ID: ")
 225       (if (or (not (stringp message-id))
 226               (zerop (length message-id)))
 227           ()
 228         ;; Construct the correct Message-ID if necessary.
 229         ;; Suggested by tale@pawl.rpi.edu.
 230         (or (string-match "^<" message-id)
 231             (setq message-id (concat "<" message-id)))
 232         (or (string-match ">$" message-id)
 233             (setq message-id (concat message-id ">")))
 234         (let ((header (car (gnus-gethash (downcase message-id)
 235                                          gnus-newsgroup-dependencies))))
 236           (if header
 237               (or (gnus-summary-goto-article (header-number header))
 238                   ;; The header has been read, but the article had been
 239                   ;; expunged, so we insert it again.
 240                   (let ((beg (point)))
 241                     (gnus-summary-insert-line
 242                      nil header 0 nil gnus-read-mark nil nil
 243                      (header-subject header))
 244                     (save-excursion
 245                       (goto-char beg)
 246                       (remove-text-properties
 247                        (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 248                        '(gnus-number nil gnus-mark nil gnus-level nil)))
 249                     (forward-line -1)
 250                     (header-number header)))
 251             (let ((gnus-override-method gnus-refer-article-method)
 252                   (gnus-ancient-mark gnus-read-mark)
 253                   (tmp-buf (get-buffer-create " *gnus refer"))
 254                   (tmp-point (window-start
 255                               (get-buffer-window gnus-article-buffer)))
 256                   number)
 257               (and gnus-refer-article-method
 258                    (or (gnus-server-opened gnus-refer-article-method)
 259                        (gnus-open-server gnus-refer-article-method)))
 260               ;; Save the old article buffer.
 261               (save-excursion
 262                 (set-buffer tmp-buf)
 263                 (buffer-disable-undo (current-buffer))
 264                 (insert-buffer-substring gnus-article-buffer))
 265               (prog1
 266                   (if (gnus-article-prepare
 267                        message-id nil (gnus-read-header message-id))
 268                       (progn
 269                         (setq number (header-number gnus-current-headers))
 270                         (gnus-rebuild-thread message-id)
 271                         (gnus-summary-goto-subject number)
 272                         (gnus-summary-recenter)
 273                         (gnus-article-set-window-start
 274                          (cdr (assq number gnus-newsgroup-bookmarks)))
 275                         message-id)
 276                     ;; We restore the old article buffer.
 277                     (save-excursion
 278                       (set-buffer gnus-article-buffer)
 279                       (let ((buffer-read-only nil))
 280                         (insert-buffer-substring tmp-buf)
 281                         (and tmp-point
 282                              (set-window-start (get-buffer-window (current-buffer))
 283                                                tmp-point))))
 284                     nil)
 285                 (kill-buffer tmp-buf)))))))
 286
 287
 288
 289     )
 290
 291    ((boundp 'MULE)
 292     ;; Mule definitions
 293     (if (not (fboundp 'truncate-string))
 294         (defun truncate-string (str width)
 295           (let ((w (string-width str))
 296                 (col 0) (idx 0) (p-idx 0) chr)
 297             (if (<= w width)
 298                 str
 299               (while (< col width)
 300                 (setq chr (aref str idx)
 301                       col (+ col (char-width chr))
 302                       p-idx idx
 303                       idx (+ idx (char-bytes chr))
 304                       ))
 305               (substring str 0 (if (= col width)
 306                                    idx
 307                                  p-idx))
 308               )))
 309       )
 310     (defalias 'gnus-truncate-string 'truncate-string)
 311
 312     (fset
 313      'gnus-format-max-width
 314      (lambda (form length)
 315        (let* ((val (eval form))
 316               (valstr (if (numberp val) (int-to-string val) val)))
 317          (if (> (length valstr) length)
 318              (truncate-string valstr length)
 319            valstr))))
 320
 321     (fset 'gnus-summary-make-display-table (lambda () nil))
 322     )
 323    ))
 324
 325 (provide 'gnus-ems)
 326
 327 ;; Local Variables:
 328 ;; byte-compile-warnings: nil
 329 ;; End:
 330
 331 ;;; gnus-ems.el ends here