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     (defvar gnus-summary-highlight
  42       '(((> score default) . bold)
  43         ((< score default) . italic))
  44       "*Alist of `(FORM . FACE)'.
  45 Summary lines are highlighted with the FACE for the first FORM which
  46 evaluate to a non-nil value.
  47
  48 Point will be at the beginning of the line when FORM is evaluated.
  49 The following can be used for convenience:
  50
  51 score:   (gnus-summary-article-score)
  52 default: gnus-summary-default-score
  53 below:   gnus-summary-mark-below
  54
  55 To check for marks, e.g. to underline replied articles, use
  56 `gnus-summary-article-mark':
  57
  58    ((= (gnus-summary-article-mark) gnus-replied-mark) . underline)")
  59
  60     (setq gnus-mouse-2 [button2])
  61     (setq gnus-easymenu 'auc-menu)
  62
  63     (or (memq 'underline (list-faces))
  64         (funcall (intern "make-face") 'underline))
  65     ;; Must avoid calling set-face-underline-p directly, because it
  66     ;; is a defsubst in emacs19, and will make the .elc files non
  67     ;; portable!
  68     (or (face-differs-from-default-p 'underline)
  69         (funcall 'set-face-underline-p 'underline t))
  70     (or (fboundp 'set-text-properties)
  71         (defun set-text-properties (start end props &optional buffer)
  72           (if (or (null buffer) (bufferp buffer))
  73               (if props
  74                   (put-text-property start end (car props) (cdr props) buffer)
  75                 (remove-text-properties start end ())))))
  76
  77     (defvar gnus-header-face-alist
  78       '(("" bold italic)))
  79
  80     (or (fboundp 'make-overlay) (fset 'make-overlay 'make-extent))
  81     (or (fboundp 'overlay-put) (fset 'overlay-put 'set-extent-property))
  82     (or (fboundp 'move-overlay)
  83         (defun move-overlay (extent start end &optional buffer)
  84           (set-extent-endpoints extent start end)))
  85     (or (boundp 'standard-display-table) (setq standard-display-table nil))
  86     (or (boundp 'read-event) (fset 'read-event 'next-command-event))
  87
  88     (setq gnus-display-type
  89           (let ((display-resource
  90                  (x-get-resource ".displayType" "DisplayType" 'string)))
  91             (cond (display-resource (intern (downcase display-resource)))
  92                   ((x-display-color-p) 'color)
  93                   ((x-display-grayscale-p) 'grayscale)
  94                   (t 'mono))))
  95
  96     (setq gnus-background-mode
  97           (let ((bg-resource
  98                  (x-get-resource ".backgroundMode" "BackgroundMode" 'string))
  99                 (params (frame-parameters)))
 100             (cond (bg-resource (intern (downcase bg-resource)))
 101 ;                 ((< (apply '+ (x-color-values
 102 ;                                (cdr (assq 'background-color params))))
 103 ;                     (/ (apply '+ (x-color-values "white")) 3))
 104 ;                  'dark)
 105                   (t 'light))))
 106
 107     (if (not gnus-visual)
 108         ()
 109       (setq gnus-group-mode-hook
 110             (cons
 111              '(lambda ()
 112                (easy-menu-add gnus-group-reading-menu)
 113                (easy-menu-add gnus-group-group-menu)
 114                (easy-menu-add gnus-group-post-menu)
 115                (easy-menu-add gnus-group-misc-menu)
 116                (gnus-install-mouse-tracker))
 117              gnus-group-mode-hook))
 118       (setq gnus-summary-mode-hook
 119             (cons
 120              '(lambda ()
 121                (easy-menu-add gnus-summary-mark-menu)
 122                (easy-menu-add gnus-summary-move-menu)
 123                (easy-menu-add gnus-summary-article-menu)
 124                (easy-menu-add gnus-summary-thread-menu)
 125                (easy-menu-add gnus-summary-misc-menu)
 126                (easy-menu-add gnus-summary-post-menu)
 127                (easy-menu-add gnus-summary-kill-menu)
 128                (gnus-install-mouse-tracker))
 129              gnus-summary-mode-hook))
 130       (setq gnus-article-mode-hook
 131             (cons
 132              '(lambda ()
 133                (easy-menu-add gnus-article-article-menu)
 134                (easy-menu-add gnus-article-treatment-menu))
 135              gnus-article-mode-hook)))
 136
 137     (defun gnus-install-mouse-tracker ()
 138       (require 'mode-motion)
 139       (setq mode-motion-hook 'mode-motion-highlight-line)))
 140
 141    ((and (not (string-match "28.9" emacs-version))
 142          (not (string-match "29" emacs-version)))
 143     (setq gnus-hidden-properties '(invisible t))
 144     (or (fboundp 'buffer-substring-no-properties)
 145         (defun buffer-substring-no-properties (beg end)
 146           (format "%s" (buffer-substring beg end)))))
 147
 148    ((boundp 'MULE)
 149     (provide 'gnusutil))
 150
 151    ))
 152
 153 (eval-and-compile
 154   (cond
 155    ((not window-system)
 156     (defun gnus-dummy-func (&rest args))
 157     (let ((funcs '(mouse-set-point set-face-foreground
 158                                    set-face-background x-popup-menu)))
 159       (while funcs
 160         (or (fboundp (car funcs))
 161             (fset (car funcs) 'gnus-dummy-func))
 162         (setq funcs (cdr funcs))))))
 163   (or (fboundp 'file-regular-p)
 164       (defun file-regular-p (file)
 165         (and (not (file-directory-p file))
 166              (not (file-symlink-p file))
 167              (file-exists-p file))))
 168   (or (fboundp 'face-list)
 169       (defun face-list (&rest args)))
 170   )
 171
 172 (defun gnus-ems-redefine ()
 173   (cond
 174    ((string-match "XEmacs\\|Lucid" emacs-version)
 175     ;; XEmacs definitions.
 176     (fset 'gnus-set-mouse-face 'identity)
 177     (fset 'gnus-summary-make-display-table (lambda () nil))
 178     (fset 'gnus-visual-turn-off-edit-menu 'identity)
 179
 180     (defun gnus-highlight-selected-summary ()
 181       ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
 182       ;; Highlight selected article in summary buffer
 183       (if gnus-summary-selected-face
 184           (save-excursion
 185             (let* ((beg (progn (beginning-of-line) (point)))
 186                    (end (progn (end-of-line) (point)))
 187                    (to (max 1 (1- (or (previous-single-property-change
 188                                        end 'mouse-face nil beg) end))))
 189                    (from (1+ (or (next-single-property-change
 190                                   beg 'mouse-face nil end) beg))))
 191               (if (< to beg)
 192                   (progn
 193                     (setq from beg)
 194                     (setq to end)))
 195               (if gnus-newsgroup-selected-overlay
 196                   (delete-extent gnus-newsgroup-selected-overlay))
 197               (setq gnus-newsgroup-selected-overlay
 198                     (make-extent from to))
 199               (set-extent-face gnus-newsgroup-selected-overlay
 200                                gnus-summary-selected-face)))))
 201
 202
 203     (defun gnus-summary-recenter ()
 204       (let* ((top (cond ((< (window-height) 4) 0)
 205                         ((< (window-height) 7) 1)
 206                         (t 2)))
 207              (height (- (window-height) 2))
 208              (bottom (save-excursion (goto-char (point-max))
 209                                      (forward-line (- height))
 210                                      (point)))
 211              (window (get-buffer-window (current-buffer))))
 212         (and
 213          ;; The user has to want it,
 214          gnus-auto-center-summary
 215          ;; the article buffer must be displayed,
 216          (get-buffer-window gnus-article-buffer)
 217          ;; Set the window start to either `bottom', which is the biggest
 218          ;; possible valid number, or the second line from the top,
 219          ;; whichever is the least.
 220          (set-window-start
 221           window (min bottom (save-excursion (forward-line (- top))
 222                                              (point)))))))
 223
 224     (defun gnus-group-insert-group-line-info (group)
 225       (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
 226             (beg (point))
 227             active info)
 228         (if entry
 229             (progn
 230               (setq info (nth 2 entry))
 231               (gnus-group-insert-group-line
 232                nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
 233           (setq active (gnus-gethash group gnus-active-hashtb))
 234
 235           (gnus-group-insert-group-line
 236            nil group (if (member group gnus-zombie-list) gnus-level-zombie
 237                        gnus-level-killed)
 238            nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
 239         (save-excursion
 240          (goto-char beg)
 241          (remove-text-properties
 242           (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 243           '(gnus-group nil)))))
 244
 245     (defun gnus-copy-article-buffer (&optional article-buffer)
 246       (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 247       (buffer-disable-undo gnus-article-copy)
 248       (or (memq gnus-article-copy gnus-buffer-list)
 249           (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 250       (let ((article-buffer (or article-buffer gnus-article-buffer))
 251             buf)
 252         (if (and (get-buffer article-buffer)
 253                  (buffer-name (get-buffer article-buffer)))
 254             (save-excursion
 255               (set-buffer article-buffer)
 256               (widen)
 257               (setq buf (buffer-substring (point-min) (point-max)))
 258               (set-buffer gnus-article-copy)
 259               (erase-buffer)
 260               (insert (format "%s" buf))))))
 261
 262     (defun gnus-summary-refer-article (message-id)
 263       "Refer article specified by MESSAGE-ID.
 264 NOTE: This command only works with newsgroups that use real or simulated NNTP."
 265       (interactive "sMessage-ID: ")
 266       (if (or (not (stringp message-id))
 267               (zerop (length message-id)))
 268           ()
 269         ;; Construct the correct Message-ID if necessary.
 270         ;; Suggested by tale@pawl.rpi.edu.
 271         (or (string-match "^<" message-id)
 272             (setq message-id (concat "<" message-id)))
 273         (or (string-match ">$" message-id)
 274             (setq message-id (concat message-id ">")))
 275         (let ((header (car (gnus-gethash (downcase message-id)
 276                                          gnus-newsgroup-dependencies))))
 277           (if header
 278               (or (gnus-summary-goto-article (header-number header))
 279                   ;; The header has been read, but the article had been
 280                   ;; expunged, so we insert it again.
 281                   (let ((beg (point)))
 282                     (gnus-summary-insert-line
 283                      nil header 0 nil gnus-read-mark nil nil
 284                      (header-subject header))
 285                     (save-excursion
 286                       (goto-char beg)
 287                       (remove-text-properties
 288                        (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 289                        '(gnus-number nil gnus-mark nil gnus-level nil)))
 290                     (forward-line -1)
 291                     (header-number header)))
 292             (let ((gnus-override-method gnus-refer-article-method)
 293                   (gnus-ancient-mark gnus-read-mark)
 294                   (tmp-buf (get-buffer-create " *gnus refer"))
 295                   (tmp-point (window-start
 296                               (get-buffer-window gnus-article-buffer)))
 297                   number)
 298               (and gnus-refer-article-method
 299                    (or (gnus-server-opened gnus-refer-article-method)
 300                        (gnus-open-server gnus-refer-article-method)))
 301               ;; Save the old article buffer.
 302               (save-excursion
 303                 (set-buffer tmp-buf)
 304                 (buffer-disable-undo (current-buffer))
 305                 (insert-buffer-substring gnus-article-buffer))
 306               (prog1
 307                   (if (gnus-article-prepare
 308                        message-id nil (gnus-read-header message-id))
 309                       (progn
 310                         (setq number (header-number gnus-current-headers))
 311                         (gnus-rebuild-thread message-id)
 312                         (gnus-summary-goto-subject number)
 313                         (gnus-summary-recenter)
 314                         (gnus-article-set-window-start
 315                          (cdr (assq number gnus-newsgroup-bookmarks)))
 316                         message-id)
 317                     ;; We restore the old article buffer.
 318                     (save-excursion
 319                       (set-buffer gnus-article-buffer)
 320                       (let ((buffer-read-only nil))
 321                         (insert-buffer-substring tmp-buf)
 322                         (and tmp-point
 323                              (set-window-start (get-buffer-window (current-buffer))
 324                                                tmp-point))))
 325                     nil)
 326                 (kill-buffer tmp-buf)))))))
 327
 328     (defun gnus-summary-insert-pseudos (pslist &optional not-view)
 329       (let ((buffer-read-only nil)
 330             (article (gnus-summary-article-number))
 331             b)
 332         (or (gnus-summary-goto-subject article)
 333             (error (format "No such article: %d" article)))
 334         (or gnus-newsgroup-headers-hashtb-by-number
 335             (gnus-make-headers-hashtable-by-number))
 336         (gnus-summary-position-cursor)
 337         ;; If all commands are to be bunched up on one line, we collect
 338         ;; them here.
 339         (if gnus-view-pseudos-separately
 340             ()
 341           (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
 342                 files action)
 343             (while ps
 344               (setq action (cdr (assq 'action (car ps))))
 345               (setq files (list (cdr (assq 'name (car ps)))))
 346               (while (and ps (cdr ps)
 347                           (string= (or action "1")
 348                                    (or (cdr (assq 'action (car (cdr ps)))) "2")))
 349                 (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
 350                 (setcdr ps (cdr (cdr ps))))
 351               (if (not files)
 352                   ()
 353                 (if (not (string-match "%s" action))
 354                     (setq files (cons " " files)))
 355                 (setq files (cons " " files))
 356                 (and (assq 'execute (car ps))
 357                      (setcdr (assq 'execute (car ps))
 358                              (funcall (if (string-match "%s" action)
 359                                           'format 'concat)
 360                                       action
 361                                       (mapconcat (lambda (f) f) files " ")))))
 362               (setq ps (cdr ps)))))
 363         (if (and gnus-view-pseudos (not not-view))
 364             (while pslist
 365               (and (assq 'execute (car pslist))
 366                    (gnus-execute-command (cdr (assq 'execute (car pslist)))
 367                                          (eq gnus-view-pseudos 'not-confirm)))
 368               (setq pslist (cdr pslist)))
 369           (save-excursion
 370             (while pslist
 371               (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
 372                                              (gnus-summary-article-number)))
 373               (forward-line 1)
 374               (setq b (point))
 375               (insert "          " (file-name-nondirectory
 376                                     (cdr (assq 'name (car pslist))))
 377                       ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
 378               (add-text-properties
 379                b (1+ b) (list 'gnus-number gnus-reffed-article-number
 380                               'gnus-mark gnus-unread-mark
 381                               'gnus-level 0
 382                               'gnus-pseudo (car pslist)))
 383               (remove-text-properties (b) (gnus-point-at-eol)
 384                                       '(gnus-number nil gnus-mark nil gnus-level nil))
 385               (forward-line -1)
 386               (gnus-sethash (int-to-string gnus-reffed-article-number)
 387                             (car pslist) gnus-newsgroup-headers-hashtb-by-number)
 388               (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
 389               (setq pslist (cdr pslist)))))))
 390
 391
 392
 393     )
 394
 395    ((boundp 'MULE)
 396     ;; Mule definitions
 397     (if (not (fboundp 'truncate-string))
 398         (defun truncate-string (str width)
 399           (let ((w (string-width str))
 400                 (col 0) (idx 0) (p-idx 0) chr)
 401             (if (<= w width)
 402                 str
 403               (while (< col width)
 404                 (setq chr (aref str idx)
 405                       col (+ col (char-width chr))
 406                       p-idx idx
 407                       idx (+ idx (char-bytes chr))
 408                       ))
 409               (substring str 0 (if (= col width)
 410                                    idx
 411                                  p-idx))
 412               )))
 413       )
 414     (defalias 'gnus-truncate-string 'truncate-string)
 415
 416     (fset
 417      'gnus-format-max-width
 418      (lambda (form length)
 419        (let* ((val (eval form))
 420               (valstr (if (numberp val) (int-to-string val) val)))
 421          (if (> (length valstr) length)
 422              (truncate-string valstr length)
 423            valstr))))
 424
 425     (fset 'gnus-summary-make-display-table (lambda () nil))
 426     )
 427    ))
 428
 429 (provide 'gnus-ems)
 430
 431 ;; Local Variables:
 432 ;; byte-compile-warnings: nil
 433 ;; End:
 434
 435 ;;; gnus-ems.el ends here