lisp/gnus-ems.el

   1 ;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
   2
   3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (defvar gnus-mouse-2 [mouse-2])
  30 (defvar gnus-group-mode-hook ())
  31 (defvar gnus-summary-mode-hook ())
  32 (defvar gnus-article-mode-hook ())
  33
  34 (defalias 'gnus-make-overlay 'make-overlay)
  35 (defalias 'gnus-overlay-put 'overlay-put)
  36 (defalias 'gnus-move-overlay 'move-overlay)
  37
  38 (or (fboundp 'mail-file-babyl-p)
  39     (fset 'mail-file-babyl-p 'rmail-file-p))
  40
  41 ;; Don't warn about these undefined variables.
  42                                         ;defined in gnus.el
  43 (defvar gnus-active-hashtb)
  44 (defvar gnus-article-buffer)
  45 (defvar gnus-auto-center-summary)
  46 (defvar gnus-buffer-list)
  47 (defvar gnus-current-headers)
  48 (defvar gnus-level-killed)
  49 (defvar gnus-level-zombie)
  50 (defvar gnus-newsgroup-bookmarks)
  51 (defvar gnus-newsgroup-dependencies)
  52 (defvar gnus-newsgroup-headers-hashtb-by-number)
  53 (defvar gnus-newsgroup-selected-overlay)
  54 (defvar gnus-newsrc-hashtb)
  55 (defvar gnus-read-mark)
  56 (defvar gnus-refer-article-method)
  57 (defvar gnus-reffed-article-number)
  58 (defvar gnus-unread-mark)
  59 (defvar gnus-version)
  60 (defvar gnus-view-pseudos)
  61 (defvar gnus-view-pseudos-separately)
  62 (defvar gnus-visual)
  63 (defvar gnus-zombie-list)
  64                                         ;defined in gnus-msg.el
  65 (defvar gnus-article-copy)
  66 (defvar gnus-check-before-posting)
  67                                         ;defined in gnus-vis.el
  68 (defvar gnus-article-button-face)
  69 (defvar gnus-article-mouse-face)
  70 (defvar gnus-summary-selected-face)
  71
  72
  73 ;; We do not byte-compile this file, because error messages are such a
  74 ;; bore.
  75
  76 (defun gnus-set-text-properties-xemacs (start end props &optional buffer)
  77   "You should NEVER use this function.  It is ideologically blasphemous.
  78 It is provided only to ease porting of broken FSF Emacs programs."
  79   (if (and (stringp buffer) (not (setq buffer (get-buffer buffer))))
  80       nil
  81     (map-extents (lambda (extent ignored)
  82                    (remove-text-properties
  83                     start end
  84                     (list (extent-property extent 'text-prop) nil)
  85                     buffer))
  86                  buffer start end nil nil 'text-prop)
  87     (add-text-properties start end props buffer)))
  88
  89 (eval
  90  '(progn
  91     (if (string-match "XEmacs\\|Lucid" emacs-version)
  92         ()
  93       ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
  94       (defvar gnus-display-type
  95         (condition-case nil
  96             (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
  97               (cond (display-resource (intern (downcase display-resource)))
  98                     ((x-display-color-p) 'color)
  99                     ((x-display-grayscale-p) 'grayscale)
 100                     (t 'mono)))
 101           (error 'mono))
 102         "A symbol indicating the display Emacs is running under.
 103 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 104 guesses this display attribute wrongly, either set this variable in
 105 your `~/.emacs' or set the resource `Emacs.displayType' in your
 106 `~/.Xdefaults'. See also `gnus-background-mode'.
 107
 108 This is a meta-variable that will affect what default values other
 109 variables get.  You would normally not change this variable, but
 110 pounce directly on the real variables themselves.")
 111
 112       (defvar gnus-background-mode
 113         (condition-case nil
 114             (let ((bg-resource (x-get-resource ".backgroundMode"
 115                                                "BackgroundMode"))
 116                   (params (frame-parameters)))
 117               (cond (bg-resource (intern (downcase bg-resource)))
 118                     ((and (cdr (assq 'background-color params))
 119                           (< (apply '+ (x-color-values
 120                                         (cdr (assq 'background-color params))))
 121                              (/ (apply '+ (x-color-values "white")) 3)))
 122                      'dark)
 123                     (t 'light)))
 124           (error 'light))
 125         "A symbol indicating the Emacs background brightness.
 126 The symbol should be one of `light' or `dark'.
 127 If Emacs guesses this frame attribute wrongly, either set this variable in
 128 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 129 `~/.Xdefaults'.
 130 See also `gnus-display-type'.
 131
 132 This is a meta-variable that will affect what default values other
 133 variables get.  You would normally not change this variable, but
 134 pounce directly on the real variables themselves."))
 135
 136     (cond
 137      ((string-match "XEmacs\\|Lucid" emacs-version)
 138       ;; XEmacs definitions.
 139
 140       (setq gnus-mouse-2 [button2])
 141
 142       (or (memq 'underline (list-faces))
 143           (and (fboundp 'make-face)
 144                (funcall (intern "make-face") 'underline)))
 145       ;; Must avoid calling set-face-underline-p directly, because it
 146       ;; is a defsubst in emacs19, and will make the .elc files non
 147       ;; portable!
 148       (or (face-differs-from-default-p 'underline)
 149           (funcall 'set-face-underline-p 'underline t))
 150
 151       (defalias 'gnus-make-overlay 'make-extent)
 152       (defalias 'gnus-overlay-put 'set-extent-property)
 153       (defun gnus-move-overlay (extent start end &optional buffer)
 154         (set-extent-endpoints extent start end))
 155
 156       (require 'text-props)
 157       (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
 158
 159       (or (boundp 'standard-display-table) (setq standard-display-table nil))
 160       (or (boundp 'read-event) (fset 'read-event 'next-command-event))
 161
 162       ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 163       (defvar gnus-display-type (device-class)
 164         "A symbol indicating the display Emacs is running under.
 165 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 166 guesses this display attribute wrongly, either set this variable in
 167 your `~/.emacs' or set the resource `Emacs.displayType' in your
 168 `~/.Xdefaults'. See also `gnus-background-mode'.
 169
 170 This is a meta-variable that will affect what default values other
 171 variables get.  You would normally not change this variable, but
 172 pounce directly on the real variables themselves.")
 173
 174
 175       (or (fboundp 'x-color-values)
 176           (fset 'x-color-values
 177                 (lambda (color)
 178                   (color-instance-rgb-components
 179                    (make-color-instance color)))))
 180
 181       (defvar gnus-background-mode
 182         (let ((bg-resource
 183                (condition-case ()
 184                    (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 185                  (error nil)))
 186               (params (frame-parameters)))
 187           (cond (bg-resource (intern (downcase bg-resource)))
 188                 ((and (assq 'background-color params)
 189                       (< (apply '+ (x-color-values
 190                                     (cdr (assq 'background-color params))))
 191                          (/ (apply '+ (x-color-values "white")) 3)))
 192                  'dark)
 193                 (t 'light)))
 194         "A symbol indicating the Emacs background brightness.
 195 The symbol should be one of `light' or `dark'.
 196 If Emacs guesses this frame attribute wrongly, either set this variable in
 197 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 198 `~/.Xdefaults'.
 199 See also `gnus-display-type'.
 200
 201 This is a meta-variable that will affect what default values other
 202 variables get.  You would normally not change this variable, but
 203 pounce directly on the real variables themselves.")
 204
 205
 206       (defun gnus-install-mouse-tracker ()
 207         (require 'mode-motion)
 208         (setq mode-motion-hook 'mode-motion-highlight-line)))
 209
 210      ((and (not (string-match "28.9" emacs-version))
 211            (not (string-match "29" emacs-version)))
 212       ;; Remove the `intangible' prop.
 213       (let ((props (and (boundp 'gnus-hidden-properties)
 214                         gnus-hidden-properties)))
 215         (while (and props (not (eq (car (cdr props)) 'intangible)))
 216           (setq props (cdr props)))
 217         (and props (setcdr props (cdr (cdr (cdr props))))))
 218       (or (fboundp 'buffer-substring-no-properties)
 219           (defun buffer-substring-no-properties (beg end)
 220             (format "%s" (buffer-substring beg end)))))
 221
 222      ((boundp 'MULE)
 223       (provide 'gnusutil))
 224
 225      )))
 226
 227 (eval-and-compile
 228   (cond
 229    ((not window-system)
 230     (defun gnus-dummy-func (&rest args))
 231     (let ((funcs '(mouse-set-point set-face-foreground
 232                                    set-face-background x-popup-menu)))
 233       (while funcs
 234         (or (fboundp (car funcs))
 235             (fset (car funcs) 'gnus-dummy-func))
 236         (setq funcs (cdr funcs))))))
 237   (or (fboundp 'file-regular-p)
 238       (defun file-regular-p (file)
 239         (and (not (file-directory-p file))
 240              (not (file-symlink-p file))
 241              (file-exists-p file))))
 242   (or (fboundp 'face-list)
 243       (defun face-list (&rest args)))
 244   )
 245
 246 (defun gnus-highlight-selected-summary-xemacs ()
 247   ;; Highlight selected article in summary buffer
 248   (if gnus-summary-selected-face
 249       (progn
 250         (if gnus-newsgroup-selected-overlay
 251             (delete-extent gnus-newsgroup-selected-overlay))
 252         (setq gnus-newsgroup-selected-overlay
 253               (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 254         (set-extent-face gnus-newsgroup-selected-overlay
 255                          gnus-summary-selected-face))))
 256
 257 (defun gnus-summary-recenter-xemacs ()
 258   (let* ((top (cond ((< (window-height) 4) 0)
 259                     ((< (window-height) 7) 1)
 260                     (t 2)))
 261          (height (- (window-height) 2))
 262          (bottom (save-excursion (goto-char (point-max))
 263                                  (forward-line (- height))
 264                                  (point)))
 265          (window (get-buffer-window (current-buffer))))
 266     (and
 267      ;; The user has to want it,
 268      gnus-auto-center-summary
 269      ;; the article buffer must be displayed,
 270      (get-buffer-window gnus-article-buffer)
 271      ;; Set the window start to either `bottom', which is the biggest
 272      ;; possible valid number, or the second line from the top,
 273      ;; whichever is the least.
 274      (set-window-start
 275       window (min bottom (save-excursion (forward-line (- top))
 276                                          (point)))))))
 277
 278 (defun gnus-group-insert-group-line-info-xemacs (group)
 279   (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
 280         (beg (point))
 281         active info)
 282     (if entry
 283         (progn
 284           (setq info (nth 2 entry))
 285           (gnus-group-insert-group-line
 286            nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
 287       (setq active (gnus-gethash group gnus-active-hashtb))
 288
 289       (gnus-group-insert-group-line
 290        nil group (if (member group gnus-zombie-list) gnus-level-zombie
 291                    gnus-level-killed)
 292        nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
 293     (save-excursion
 294       (goto-char beg)
 295       (remove-text-properties
 296        (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 297        '(gnus-group nil)))))
 298
 299 (defun gnus-summary-refer-article-xemacs (message-id)
 300   "Refer article specified by MESSAGE-ID.
 301 NOTE: This command only works with newsgroups that use real or simulated NNTP."
 302   (interactive "sMessage-ID: ")
 303   (if (or (not (stringp message-id))
 304           (zerop (length message-id)))
 305       ()
 306     ;; Construct the correct Message-ID if necessary.
 307     ;; Suggested by tale@pawl.rpi.edu.
 308     (or (string-match "^<" message-id)
 309         (setq message-id (concat "<" message-id)))
 310     (or (string-match ">$" message-id)
 311         (setq message-id (concat message-id ">")))
 312     (let ((header (car (gnus-gethash (downcase message-id)
 313                                      gnus-newsgroup-dependencies))))
 314       (if header
 315           (or (gnus-summary-goto-article (mail-header-number header))
 316               ;; The header has been read, but the article had been
 317               ;; expunged, so we insert it again.
 318               (let ((beg (point)))
 319                 (gnus-summary-insert-line
 320                  nil header 0 nil gnus-read-mark nil nil
 321                  (mail-header-subject header))
 322                 (save-excursion
 323                   (goto-char beg)
 324                   (remove-text-properties
 325                    (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 326                    '(gnus-number nil gnus-mark nil gnus-level nil)))
 327                 (forward-line -1)
 328                 (mail-header-number header)))
 329         (let ((gnus-override-method gnus-refer-article-method)
 330               (gnus-ancient-mark gnus-read-mark)
 331               (tmp-point (window-start
 332                           (get-buffer-window gnus-article-buffer)))
 333               number tmp-buf)
 334           (and gnus-refer-article-method
 335                (gnus-check-server gnus-refer-article-method))
 336           ;; Save the old article buffer.
 337           (save-excursion
 338             (set-buffer gnus-article-buffer)
 339             (gnus-kill-buffer " *temp Article*")
 340             (setq tmp-buf (rename-buffer " *temp Article*")))
 341           (prog1
 342               (if (gnus-article-prepare
 343                    message-id nil (gnus-read-header message-id))
 344                   (progn
 345                     (setq number (mail-header-number gnus-current-headers))
 346                     (gnus-rebuild-thread message-id)
 347                     (gnus-summary-goto-subject number)
 348                     (gnus-summary-recenter)
 349                     (gnus-article-set-window-start
 350                      (cdr (assq number gnus-newsgroup-bookmarks)))
 351                     message-id)
 352                 ;; We restore the old article buffer.
 353                 (save-excursion
 354                   (kill-buffer gnus-article-buffer)
 355                   (set-buffer tmp-buf)
 356                   (rename-buffer gnus-article-buffer)
 357                   (let ((buffer-read-only nil))
 358                     (and tmp-point
 359                          (set-window-start (get-buffer-window (current-buffer))
 360                                            tmp-point)))))))))))
 361
 362 (defun gnus-summary-insert-pseudos-xemacs (pslist &optional not-view)
 363   (let ((buffer-read-only nil)
 364         (article (gnus-summary-article-number))
 365         b)
 366     (or (gnus-summary-goto-subject article)
 367         (error (format "No such article: %d" article)))
 368     (or gnus-newsgroup-headers-hashtb-by-number
 369         (gnus-make-headers-hashtable-by-number))
 370     (gnus-summary-position-cursor)
 371     ;; If all commands are to be bunched up on one line, we collect
 372     ;; them here.
 373     (if gnus-view-pseudos-separately
 374         ()
 375       (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
 376             files action)
 377         (while ps
 378           (setq action (cdr (assq 'action (car ps))))
 379           (setq files (list (cdr (assq 'name (car ps)))))
 380           (while (and ps (cdr ps)
 381                       (string= (or action "1")
 382                                (or (cdr (assq 'action (car (cdr ps)))) "2")))
 383             (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
 384             (setcdr ps (cdr (cdr ps))))
 385           (if (not files)
 386               ()
 387             (if (not (string-match "%s" action))
 388                 (setq files (cons " " files)))
 389             (setq files (cons " " files))
 390             (and (assq 'execute (car ps))
 391                  (setcdr (assq 'execute (car ps))
 392                          (funcall (if (string-match "%s" action)
 393                                       'format 'concat)
 394                                   action
 395                                   (mapconcat (lambda (f) f) files " ")))))
 396           (setq ps (cdr ps)))))
 397     (if (and gnus-view-pseudos (not not-view))
 398         (while pslist
 399           (and (assq 'execute (car pslist))
 400                (gnus-execute-command (cdr (assq 'execute (car pslist)))
 401                                      (eq gnus-view-pseudos 'not-confirm)))
 402           (setq pslist (cdr pslist)))
 403       (save-excursion
 404         (while pslist
 405           (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
 406                                          (gnus-summary-article-number)))
 407           (forward-line 1)
 408           (setq b (point))
 409           (insert "          "
 410                   (file-name-nondirectory (cdr (assq 'name (car pslist))))
 411                   ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
 412           (add-text-properties
 413            b (1+ b) (list 'gnus-number gnus-reffed-article-number
 414                           'gnus-mark gnus-unread-mark
 415                           'gnus-level 0
 416                           'gnus-pseudo (car pslist)))
 417           ;; Fucking XEmacs redisplay bug with truncated lines.
 418           (goto-char b)
 419           (sit-for 0)
 420           ;; Grumble.. Fucking XEmacs stickiness of text properties.
 421           (remove-text-properties
 422            (1+ b) (1+ (gnus-point-at-eol))
 423            '(gnus-number nil gnus-mark nil gnus-level nil))
 424           (forward-line -1)
 425           (gnus-sethash (int-to-string gnus-reffed-article-number)
 426                         (car pslist) gnus-newsgroup-headers-hashtb-by-number)
 427           (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
 428           (setq pslist (cdr pslist)))))))
 429
 430
 431 (defun gnus-copy-article-buffer-xemacs (&optional article-buffer)
 432   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 433   (buffer-disable-undo gnus-article-copy)
 434   (or (memq gnus-article-copy gnus-buffer-list)
 435       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 436   (let ((article-buffer (or article-buffer gnus-article-buffer))
 437         buf)
 438     (if (and (get-buffer article-buffer)
 439              (buffer-name (get-buffer article-buffer)))
 440         (save-excursion
 441           (set-buffer article-buffer)
 442           (widen)
 443           (setq buf (buffer-substring (point-min) (point-max)))
 444           (set-buffer gnus-article-copy)
 445           (erase-buffer)
 446           (insert (format "%s" buf))))))
 447
 448 (defun gnus-article-push-button-xemacs (event)
 449   "Check text under the mouse pointer for a callback function.
 450 If the text under the mouse pointer has a `gnus-callback' property,
 451 call it with the value of the `gnus-data' text property."
 452   (interactive "e")
 453   (set-buffer (window-buffer (event-window event)))
 454   (let* ((pos (event-closest-point event))
 455          (data (get-text-property pos 'gnus-data))
 456          (fun (get-text-property pos 'gnus-callback)))
 457     (if fun (funcall fun data))))
 458
 459 ;; Re-build the thread containing ID.
 460 (defun gnus-rebuild-thread-xemacs  (id)
 461   (let ((dep gnus-newsgroup-dependencies)
 462         (buffer-read-only nil)
 463         parent headers refs thread art)
 464     (while (and id (setq headers
 465                          (car (setq art (gnus-gethash (downcase id)
 466                                                       dep)))))
 467       (setq parent art)
 468       (setq id (and (setq refs (mail-header-references headers))
 469                     (string-match "\\(<[^>]+>\\) *$" refs)
 470                     (substring refs (match-beginning 1) (match-end 1)))))
 471     (setq thread (gnus-make-sub-thread (car parent)))
 472     (gnus-rebuild-remove-articles thread)
 473     (let ((beg (point)))
 474       (gnus-summary-prepare-threads (list thread) 0)
 475       (save-excursion
 476         (while (and (>= (point) beg)
 477                     (not (bobp)))
 478           (or (eobp)
 479               (remove-text-properties
 480                (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 481                '(gnus-number nil gnus-mark nil gnus-level nil)))
 482           (forward-line -1)))
 483       (gnus-summary-update-lines beg (point)))))
 484
 485
 486 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 487 (defun gnus-article-add-button-xemacs (from to fun &optional data)
 488   "Create a button between FROM and TO with callback FUN and data DATA."
 489   (and gnus-article-button-face
 490        (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
 491   (add-text-properties from to
 492                        (append
 493                         (and gnus-article-mouse-face
 494                              (list 'mouse-face gnus-article-mouse-face))
 495                         (list 'gnus-callback fun)
 496                         (and data (list 'gnus-data data))
 497                         (list 'highlight t))))
 498
 499 (defun gnus-window-top-edge-xemacs (&optional window)
 500   (nth 1 (window-pixel-edges window)))
 501
 502 ;; Select the lowest window on the frame.
 503 (defun gnus-appt-select-lowest-window-xemacs ()
 504   (let* ((lowest-window (selected-window))
 505          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 506          (last-window (previous-window))
 507          (window-search t))
 508     (while window-search
 509       (let* ((this-window (next-window))
 510              (next-bottom-edge (car (cdr (cdr (cdr
 511                                                (window-pixel-edges
 512                                                 this-window)))))))
 513         (if (< bottom-edge next-bottom-edge)
 514             (progn
 515               (setq bottom-edge next-bottom-edge)
 516               (setq lowest-window this-window)))
 517
 518         (select-window this-window)
 519         (if (eq last-window this-window)
 520             (progn
 521               (select-window lowest-window)
 522               (setq window-search nil)))))))
 523
 524 (defun gnus-ems-redefine ()
 525   (cond
 526    ((string-match "XEmacs\\|Lucid" emacs-version)
 527     ;; XEmacs definitions.
 528     (fset 'gnus-mouse-face-function 'identity)
 529     (fset 'gnus-summary-make-display-table (lambda () nil))
 530     (fset 'gnus-visual-turn-off-edit-menu 'identity)
 531     (fset 'gnus-highlight-selected-summary
 532           'gnus-highlight-selected-summary-xemacs)
 533     (fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
 534     (fset 'gnus-group-insert-group-line-info
 535           'gnus-group-insert-group-line-info-xemacs)
 536     (fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
 537     (fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
 538     (fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
 539     (fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
 540     (fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
 541     (fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
 542     (fset 'gnus-window-top-edge 'gnus-window-top-edge-xemacs)
 543     (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
 544
 545     (or (fboundp 'appt-select-lowest-window)
 546         (fset 'appt-select-lowest-window
 547               'gnus-appt-select-lowest-window-xemacs))
 548
 549     (if (not gnus-visual)
 550         ()
 551       (setq gnus-group-mode-hook
 552             (cons
 553              '(lambda ()
 554                 (easy-menu-add gnus-group-reading-menu)
 555                 (easy-menu-add gnus-group-group-menu)
 556                 (easy-menu-add gnus-group-misc-menu)
 557                 (gnus-install-mouse-tracker))
 558              gnus-group-mode-hook))
 559       (setq gnus-summary-mode-hook
 560             (cons
 561              '(lambda ()
 562                 (easy-menu-add gnus-summary-article-menu)
 563                 (easy-menu-add gnus-summary-thread-menu)
 564                 (easy-menu-add gnus-summary-misc-menu)
 565                 (easy-menu-add gnus-summary-post-menu)
 566                 (easy-menu-add gnus-summary-kill-menu)
 567                 (gnus-install-mouse-tracker))
 568              gnus-summary-mode-hook))
 569       (setq gnus-article-mode-hook
 570             (cons
 571              '(lambda ()
 572                 (easy-menu-add gnus-article-article-menu)
 573                 (easy-menu-add gnus-article-treatment-menu))
 574              gnus-article-mode-hook)))
 575
 576     (defvar gnus-logo (make-glyph (make-specifier 'image)))
 577
 578     (defun gnus-group-startup-xmessage (&optional x y)
 579       "Insert startup message in current buffer."
 580       ;; Insert the message.
 581       (erase-buffer)
 582       (if (featurep 'xpm)
 583           (progn
 584             (set-glyph-property gnus-logo 'image  "~/tmp/gnus.xpm")
 585             (set-glyph-image gnus-logo "~/tmp/gnus.xpm" 'global 'x)
 586
 587             (insert " ")
 588             (set-extent-begin-glyph (make-extent (point) (point)) gnus-logo)
 589             (insert "
 590    Gnus * A newsreader for Emacsen
 591  A Praxis Release * larsi@ifi.uio.no")
 592             (goto-char (point-min))
 593             (while (not (eobp))
 594               (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 595                                    ? ))
 596               (forward-line 1))
 597             (goto-char (point-min))
 598             ;; +4 is fuzzy factor.
 599             (insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
 600
 601         (insert
 602          (format "
 603      %s
 604            A newsreader
 605       for GNU Emacs
 606
 607         Based on GNUS
 608              written by
 609      Masanobu UMEDA
 610
 611        A Praxis Release
 612       larsi@ifi.uio.no
 613 "
 614                  gnus-version))
 615         ;; And then hack it.
 616         ;; 18 is the longest line.
 617         (indent-rigidly (point-min) (point-max)
 618                         (/ (max (- (window-width) (or x 28)) 0) 2))
 619         (goto-char (point-min))
 620         ;; +4 is fuzzy factor.
 621         (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
 622
 623       ;; Fontify some.
 624       (goto-char (point-min))
 625       (search-forward "Praxis")
 626       (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
 627       (goto-char (point-min)))
 628
 629
 630
 631     )
 632
 633    ((boundp 'MULE)
 634     ;; Mule definitions
 635     (if (not (fboundp 'truncate-string))
 636         (defun truncate-string (str width)
 637           (let ((w (string-width str))
 638                 (col 0) (idx 0) (p-idx 0) chr)
 639             (if (<= w width)
 640                 str
 641               (while (< col width)
 642                 (setq chr (aref str idx)
 643                       col (+ col (char-width chr))
 644                       p-idx idx
 645                       idx (+ idx (char-bytes chr))
 646                       ))
 647               (substring str 0 (if (= col width)
 648                                    idx
 649                                  p-idx))
 650               )))
 651       )
 652     (defalias 'gnus-truncate-string 'truncate-string)
 653
 654     (defun gnus-cite-add-face (number prefix face)
 655       ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
 656       (if face
 657           (let ((inhibit-point-motion-hooks t)
 658                 from to)
 659             (goto-line number)
 660             (if (boundp 'MULE)
 661                 (forward-char (chars-in-string prefix))
 662               (forward-char (length prefix)))
 663             (skip-chars-forward " \t")
 664             (setq from (point))
 665             (end-of-line 1)
 666             (skip-chars-backward " \t")
 667             (setq to (point))
 668             (if (< from to)
 669                 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
 670
 671     (defun gnus-max-width-function (el max-width)
 672       (` (let* ((val (eval (, el)))
 673                 (valstr (if (numberp val)
 674                             (int-to-string val) val)))
 675            (if (> (length valstr) (, max-width))
 676                (truncate-string valstr (, max-width))
 677              valstr))))
 678
 679     (fset 'gnus-summary-make-display-table (lambda () nil))
 680
 681     (if (boundp 'gnus-check-before-posting)
 682         (setq gnus-check-before-posting
 683               (delq 'long-lines
 684                     (delq 'control-chars gnus-check-before-posting)))
 685       )
 686     )
 687    ))
 688
 689 (provide 'gnus-ems)
 690
 691 ;; Local Variables:
 692 ;; byte-compile-warnings: '(redefine callargs)
 693 ;; End:
 694
 695 ;;; gnus-ems.el ends here