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