cgit.sxemacs.org Git - gnus/blob - lisp/gnus-ems.el

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