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