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