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      ((and (not (string-match "28.9" emacs-version))
 220            (not (string-match "29" emacs-version)))
 221       ;; Remove the `intangible' prop.
 222       (let ((props (and (boundp 'gnus-hidden-properties)
 223                         gnus-hidden-properties)))
 224         (while (and props (not (eq (car (cdr props)) 'intangible)))
 225           (setq props (cdr props)))
 226         (and props (setcdr props (cdr (cdr (cdr props))))))
 227       (or (fboundp 'buffer-substring-no-properties)
 228           (defun buffer-substring-no-properties (beg end)
 229             (format "%s" (buffer-substring beg end)))))
 230
 231      ((boundp 'MULE)
 232       (provide 'gnusutil))
 233
 234      )))
 235
 236 (eval-and-compile
 237   (cond
 238    ((not window-system)
 239     (defun gnus-dummy-func (&rest args))
 240     (let ((funcs '(mouse-set-point set-face-foreground
 241                                    set-face-background x-popup-menu)))
 242       (while funcs
 243         (or (fboundp (car funcs))
 244             (fset (car funcs) 'gnus-dummy-func))
 245         (setq funcs (cdr funcs))))))
 246   (or (fboundp 'file-regular-p)
 247       (defun file-regular-p (file)
 248         (and (not (file-directory-p file))
 249              (not (file-symlink-p file))
 250              (file-exists-p file))))
 251   (or (fboundp 'face-list)
 252       (defun face-list (&rest args)))
 253   )
 254
 255 (defun gnus-highlight-selected-summary-xemacs ()
 256   ;; Highlight selected article in summary buffer
 257   (if gnus-summary-selected-face
 258       (progn
 259         (if gnus-newsgroup-selected-overlay
 260             (delete-extent gnus-newsgroup-selected-overlay))
 261         (setq gnus-newsgroup-selected-overlay
 262               (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 263         (set-extent-face gnus-newsgroup-selected-overlay
 264                          gnus-summary-selected-face))))
 265
 266 (defun gnus-summary-recenter-xemacs ()
 267   (let* ((top (cond ((< (window-height) 4) 0)
 268                     ((< (window-height) 7) 1)
 269                     (t 2)))
 270          (height (- (window-height) 2))
 271          (bottom (save-excursion (goto-char (point-max))
 272                                  (forward-line (- height))
 273                                  (point)))
 274          (window (get-buffer-window (current-buffer))))
 275     (and
 276      ;; The user has to want it,
 277      gnus-auto-center-summary
 278      ;; the article buffer must be displayed,
 279      (get-buffer-window gnus-article-buffer)
 280      ;; Set the window start to either `bottom', which is the biggest
 281      ;; possible valid number, or the second line from the top,
 282      ;; whichever is the least.
 283      (set-window-start
 284       window (min bottom (save-excursion (forward-line (- top))
 285                                          (point)))))))
 286
 287 (defun gnus-group-insert-group-line-info-xemacs (group)
 288   (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
 289         (beg (point))
 290         active info)
 291     (if entry
 292         (progn
 293           (setq info (nth 2 entry))
 294           (gnus-group-insert-group-line
 295            nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
 296       (setq active (gnus-gethash group gnus-active-hashtb))
 297
 298       (gnus-group-insert-group-line
 299        nil group (if (member group gnus-zombie-list) gnus-level-zombie
 300                    gnus-level-killed)
 301        nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
 302     (save-excursion
 303       (goto-char beg)
 304       (remove-text-properties
 305        (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 306        '(gnus-group nil)))))
 307
 308 (defun gnus-summary-refer-article-xemacs (message-id)
 309   "Refer article specified by MESSAGE-ID.
 310 NOTE: This command only works with newsgroups that use real or simulated NNTP."
 311   (interactive "sMessage-ID: ")
 312   (if (or (not (stringp message-id))
 313           (zerop (length message-id)))
 314       ()
 315     ;; Construct the correct Message-ID if necessary.
 316     ;; Suggested by tale@pawl.rpi.edu.
 317     (or (string-match "^<" message-id)
 318         (setq message-id (concat "<" message-id)))
 319     (or (string-match ">$" message-id)
 320         (setq message-id (concat message-id ">")))
 321     (let ((header (car (gnus-gethash (downcase message-id)
 322                                      gnus-newsgroup-dependencies))))
 323       (if header
 324           (or (gnus-summary-goto-article (mail-header-number header))
 325               ;; The header has been read, but the article had been
 326               ;; expunged, so we insert it again.
 327               (let ((beg (point)))
 328                 (gnus-summary-insert-line
 329                  nil header 0 nil gnus-read-mark nil nil
 330                  (mail-header-subject header))
 331                 (save-excursion
 332                   (goto-char beg)
 333                   (remove-text-properties
 334                    (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 335                    '(gnus-number nil gnus-mark nil gnus-level nil)))
 336                 (forward-line -1)
 337                 (mail-header-number header)))
 338         (let ((gnus-override-method gnus-refer-article-method)
 339               (gnus-ancient-mark gnus-read-mark)
 340               (tmp-point (window-start
 341                           (get-buffer-window gnus-article-buffer)))
 342               number tmp-buf)
 343           (and gnus-refer-article-method
 344                (gnus-check-server gnus-refer-article-method))
 345           ;; Save the old article buffer.
 346           (save-excursion
 347             (set-buffer gnus-article-buffer)
 348             (gnus-kill-buffer " *temp Article*")
 349             (setq tmp-buf (rename-buffer " *temp Article*")))
 350           (prog1
 351               (if (gnus-article-prepare
 352                    message-id nil (gnus-read-header message-id))
 353                   (progn
 354                     (setq number (mail-header-number gnus-current-headers))
 355                     (gnus-rebuild-thread message-id)
 356                     (gnus-summary-goto-subject number)
 357                     (gnus-summary-recenter)
 358                     (gnus-article-set-window-start
 359                      (cdr (assq number gnus-newsgroup-bookmarks)))
 360                     message-id)
 361                 ;; We restore the old article buffer.
 362                 (save-excursion
 363                   (kill-buffer gnus-article-buffer)
 364                   (set-buffer tmp-buf)
 365                   (rename-buffer gnus-article-buffer)
 366                   (let ((buffer-read-only nil))
 367                     (and tmp-point
 368                          (set-window-start (get-buffer-window (current-buffer))
 369                                            tmp-point)))))))))))
 370
 371 (defun gnus-summary-insert-pseudos-xemacs (pslist &optional not-view)
 372   (let ((buffer-read-only nil)
 373         (article (gnus-summary-article-number))
 374         b)
 375     (or (gnus-summary-goto-subject article)
 376         (error "No such article: %d" article))
 377     (or gnus-newsgroup-headers-hashtb-by-number
 378         (gnus-make-headers-hashtable-by-number))
 379     (gnus-summary-position-cursor)
 380     ;; If all commands are to be bunched up on one line, we collect
 381     ;; them here.
 382     (if gnus-view-pseudos-separately
 383         ()
 384       (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
 385             files action)
 386         (while ps
 387           (setq action (cdr (assq 'action (car ps))))
 388           (setq files (list (cdr (assq 'name (car ps)))))
 389           (while (and ps (cdr ps)
 390                       (string= (or action "1")
 391                                (or (cdr (assq 'action (car (cdr ps)))) "2")))
 392             (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
 393             (setcdr ps (cdr (cdr ps))))
 394           (if (not files)
 395               ()
 396             (if (not (string-match "%s" action))
 397                 (setq files (cons " " files)))
 398             (setq files (cons " " files))
 399             (and (assq 'execute (car ps))
 400                  (setcdr (assq 'execute (car ps))
 401                          (funcall (if (string-match "%s" action)
 402                                       'format 'concat)
 403                                   action
 404                                   (mapconcat (lambda (f) f) files " ")))))
 405           (setq ps (cdr ps)))))
 406     (if (and gnus-view-pseudos (not not-view))
 407         (while pslist
 408           (and (assq 'execute (car pslist))
 409                (gnus-execute-command (cdr (assq 'execute (car pslist)))
 410                                      (eq gnus-view-pseudos 'not-confirm)))
 411           (setq pslist (cdr pslist)))
 412       (save-excursion
 413         (while pslist
 414           (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
 415                                          (gnus-summary-article-number)))
 416           (forward-line 1)
 417           (setq b (point))
 418           (insert "          "
 419                   (file-name-nondirectory (cdr (assq 'name (car pslist))))
 420                   ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
 421           (add-text-properties
 422            b (1+ b) (list 'gnus-number gnus-reffed-article-number
 423                           'gnus-mark gnus-unread-mark
 424                           'gnus-level 0
 425                           'gnus-pseudo (car pslist)))
 426           ;; Fire-trucking XEmacs redisplay bug with truncated lines.
 427           (goto-char b)
 428           (sit-for 0)
 429           ;; Grumble.. fire-trucking XEmacs stickiness of text properties.
 430           (remove-text-properties
 431            (1+ b) (1+ (gnus-point-at-eol))
 432            '(gnus-number nil gnus-mark nil gnus-level nil))
 433           (forward-line -1)
 434           (gnus-sethash (int-to-string gnus-reffed-article-number)
 435                         (car pslist) gnus-newsgroup-headers-hashtb-by-number)
 436           (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
 437           (setq pslist (cdr pslist)))))))
 438
 439
 440 (defun gnus-copy-article-buffer-xemacs (&optional article-buffer)
 441   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 442   (buffer-disable-undo gnus-article-copy)
 443   (or (memq gnus-article-copy gnus-buffer-list)
 444       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 445   (let ((article-buffer (or article-buffer gnus-article-buffer))
 446         buf)
 447     (if (and (get-buffer article-buffer)
 448              (buffer-name (get-buffer article-buffer)))
 449         (save-excursion
 450           (set-buffer article-buffer)
 451           (widen)
 452           (setq buf (buffer-substring (point-min) (point-max)))
 453           (set-buffer gnus-article-copy)
 454           (erase-buffer)
 455           (insert (format "%s" buf))))))
 456
 457 (defun gnus-article-push-button-xemacs (event)
 458   "Check text under the mouse pointer for a callback function.
 459 If the text under the mouse pointer has a `gnus-callback' property,
 460 call it with the value of the `gnus-data' text property."
 461   (interactive "e")
 462   (set-buffer (window-buffer (event-window event)))
 463   (let* ((pos (event-closest-point event))
 464          (data (get-text-property pos 'gnus-data))
 465          (fun (get-text-property pos 'gnus-callback)))
 466     (if fun (funcall fun data))))
 467
 468 ;; Re-build the thread containing ID.
 469 (defun gnus-rebuild-thread-xemacs  (id)
 470   (let ((dep gnus-newsgroup-dependencies)
 471         (buffer-read-only nil)
 472         parent headers refs thread art)
 473     (while (and id (setq headers
 474                          (car (setq art (gnus-gethash (downcase id)
 475                                                       dep)))))
 476       (setq parent art)
 477       (setq id (and (setq refs (mail-header-references headers))
 478                     (string-match "\\(<[^>]+>\\) *$" refs)
 479                     (substring refs (match-beginning 1) (match-end 1)))))
 480     (setq thread (gnus-make-sub-thread (car parent)))
 481     (gnus-rebuild-remove-articles thread)
 482     (let ((beg (point)))
 483       (gnus-summary-prepare-threads (list thread) 0)
 484       (save-excursion
 485         (while (and (>= (point) beg)
 486                     (not (bobp)))
 487           (or (eobp)
 488               (remove-text-properties
 489                (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 490                '(gnus-number nil gnus-mark nil gnus-level nil)))
 491           (forward-line -1)))
 492       (gnus-summary-update-lines beg (point)))))
 493
 494
 495 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 496 (defun gnus-article-add-button-xemacs (from to fun &optional data)
 497   "Create a button between FROM and TO with callback FUN and data DATA."
 498   (and gnus-article-button-face
 499        (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
 500   (add-text-properties from to
 501                        (append
 502                         (and gnus-article-mouse-face
 503                              (list 'mouse-face gnus-article-mouse-face))
 504                         (list 'gnus-callback fun)
 505                         (and data (list 'gnus-data data))
 506                         (list 'highlight t))))
 507
 508 (defun gnus-window-top-edge-xemacs (&optional window)
 509   (nth 1 (window-pixel-edges window)))
 510
 511 ;; Select the lowest window on the frame.
 512 (defun gnus-appt-select-lowest-window-xemacs ()
 513   (let* ((lowest-window (selected-window))
 514          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 515          (last-window (previous-window))
 516          (window-search t))
 517     (while window-search
 518       (let* ((this-window (next-window))
 519              (next-bottom-edge (car (cdr (cdr (cdr
 520                                                (window-pixel-edges
 521                                                 this-window)))))))
 522         (if (< bottom-edge next-bottom-edge)
 523             (progn
 524               (setq bottom-edge next-bottom-edge)
 525               (setq lowest-window this-window)))
 526
 527         (select-window this-window)
 528         (if (eq last-window this-window)
 529             (progn
 530               (select-window lowest-window)
 531               (setq window-search nil)))))))
 532
 533 (defun gnus-ems-redefine ()
 534   (cond
 535    ((string-match "XEmacs\\|Lucid" emacs-version)
 536     ;; XEmacs definitions.
 537     (fset 'gnus-mouse-face-function 'identity)
 538     (fset 'gnus-summary-make-display-table (lambda () nil))
 539     (fset 'gnus-visual-turn-off-edit-menu 'identity)
 540     (fset 'gnus-highlight-selected-summary
 541           'gnus-highlight-selected-summary-xemacs)
 542     (fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
 543     (fset 'gnus-group-insert-group-line-info
 544           'gnus-group-insert-group-line-info-xemacs)
 545     (fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
 546     (fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
 547     (fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
 548     (fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
 549     (fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
 550     (fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
 551     (fset 'gnus-window-top-edge 'gnus-window-top-edge-xemacs)
 552     (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
 553
 554     (or (fboundp 'appt-select-lowest-window)
 555         (fset 'appt-select-lowest-window
 556               'gnus-appt-select-lowest-window-xemacs))
 557
 558     (if (not gnus-visual)
 559         ()
 560       (setq gnus-group-mode-hook
 561             (cons
 562              '(lambda ()
 563                 (easy-menu-add gnus-group-reading-menu)
 564                 (easy-menu-add gnus-group-group-menu)
 565                 (easy-menu-add gnus-group-misc-menu)
 566                 (gnus-install-mouse-tracker))
 567              gnus-group-mode-hook))
 568       (setq gnus-summary-mode-hook
 569             (cons
 570              '(lambda ()
 571                 (easy-menu-add gnus-summary-article-menu)
 572                 (easy-menu-add gnus-summary-thread-menu)
 573                 (easy-menu-add gnus-summary-misc-menu)
 574                 (easy-menu-add gnus-summary-post-menu)
 575                 (easy-menu-add gnus-summary-kill-menu)
 576                 (gnus-install-mouse-tracker))
 577              gnus-summary-mode-hook))
 578       (setq gnus-article-mode-hook
 579             (cons
 580              '(lambda ()
 581                 (easy-menu-add gnus-article-article-menu)
 582                 (easy-menu-add gnus-article-treatment-menu))
 583              gnus-article-mode-hook)))
 584
 585     (defvar gnus-logo (make-glyph (make-specifier 'image)))
 586
 587     (defun gnus-group-startup-xmessage (&optional x y)
 588       "Insert startup message in current buffer."
 589       ;; Insert the message.
 590       (erase-buffer)
 591       (if (featurep 'xpm)
 592           (progn
 593             (set-glyph-property gnus-logo 'image  "~/tmp/gnus.xpm")
 594             (set-glyph-image gnus-logo "~/tmp/gnus.xpm" 'global 'x)
 595
 596             (insert " ")
 597             (set-extent-begin-glyph (make-extent (point) (point)) gnus-logo)
 598             (insert "
 599    Gnus * A newsreader for Emacsen
 600  A Praxis Release * larsi@ifi.uio.no")
 601             (goto-char (point-min))
 602             (while (not (eobp))
 603               (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 604                                    ? ))
 605               (forward-line 1))
 606             (goto-char (point-min))
 607             ;; +4 is fuzzy factor.
 608             (insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
 609
 610         (insert
 611          (format "
 612      %s
 613            A newsreader
 614       for GNU Emacs
 615
 616         Based on GNUS
 617              written by
 618      Masanobu UMEDA
 619
 620        A Praxis Release
 621       larsi@ifi.uio.no
 622 "
 623                  gnus-version))
 624         ;; And then hack it.
 625         ;; 18 is the longest line.
 626         (indent-rigidly (point-min) (point-max)
 627                         (/ (max (- (window-width) (or x 28)) 0) 2))
 628         (goto-char (point-min))
 629         ;; +4 is fuzzy factor.
 630         (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
 631
 632       ;; Fontify some.
 633       (goto-char (point-min))
 634       (search-forward "Praxis")
 635       (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
 636       (goto-char (point-min)))
 637
 638
 639
 640     )
 641
 642    ((boundp 'MULE)
 643     ;; Mule definitions
 644     (if (not (fboundp 'truncate-string))
 645         (defun truncate-string (str width)
 646           (let ((w (string-width str))
 647                 (col 0) (idx 0) (p-idx 0) chr)
 648             (if (<= w width)
 649                 str
 650               (while (< col width)
 651                 (setq chr (aref str idx)
 652                       col (+ col (char-width chr))
 653                       p-idx idx
 654                       idx (+ idx (char-bytes chr))
 655                       ))
 656               (substring str 0 (if (= col width)
 657                                    idx
 658                                  p-idx))
 659               )))
 660       )
 661     (defalias 'gnus-truncate-string 'truncate-string)
 662
 663     (defun gnus-cite-add-face (number prefix face)
 664       ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
 665       (if face
 666           (let ((inhibit-point-motion-hooks t)
 667                 from to)
 668             (goto-line number)
 669             (if (boundp 'MULE)
 670                 (forward-char (chars-in-string prefix))
 671               (forward-char (length prefix)))
 672             (skip-chars-forward " \t")
 673             (setq from (point))
 674             (end-of-line 1)
 675             (skip-chars-backward " \t")
 676             (setq to (point))
 677             (if (< from to)
 678                 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
 679
 680     (defun gnus-max-width-function (el max-width)
 681       (` (let* ((val (eval (, el)))
 682                 (valstr (if (numberp val)
 683                             (int-to-string val) val)))
 684            (if (> (length valstr) (, max-width))
 685                (truncate-string valstr (, max-width))
 686              valstr))))
 687
 688     (fset 'gnus-summary-make-display-table (lambda () nil))
 689
 690     (if (boundp 'gnus-check-before-posting)
 691         (setq gnus-check-before-posting
 692               (delq 'long-lines
 693                     (delq 'control-chars gnus-check-before-posting)))
 694       )
 695     )
 696    ))
 697
 698 (provide 'gnus-ems)
 699
 700 ;; Local Variables:
 701 ;; byte-compile-warnings: '(redefine callargs)
 702 ;; End:
 703
 704 ;;; gnus-ems.el ends here