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-headers-hashtb-by-number)
  49 (defvar gnus-newsgroup-selected-overlay)
  50 (defvar gnus-newsrc-hashtb)
  51 (defvar gnus-read-mark)
  52 (defvar gnus-refer-article-method)
  53 (defvar gnus-reffed-article-number)
  54 (defvar gnus-unread-mark)
  55 (defvar gnus-version)
  56 (defvar gnus-view-pseudos)
  57 (defvar gnus-view-pseudos-separately)
  58 (defvar gnus-visual)
  59 (defvar gnus-zombie-list)
  60                                         ;defined in gnus-msg.el
  61 (defvar gnus-article-copy)
  62 (defvar gnus-check-before-posting)
  63                                         ;defined in gnus-vis.el
  64 (defvar gnus-article-button-face)
  65 (defvar gnus-article-mouse-face)
  66 (defvar gnus-summary-selected-face)
  67
  68
  69 ;; We do not byte-compile this file, because error messages are such a
  70 ;; bore.
  71
  72 (eval
  73  '(progn
  74     (if (string-match "XEmacs\\|Lucid" emacs-version)
  75         ()
  76       ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
  77       (defvar gnus-display-type
  78         (condition-case nil
  79             (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
  80               (cond (display-resource (intern (downcase display-resource)))
  81                     ((x-display-color-p) 'color)
  82                     ((x-display-grayscale-p) 'grayscale)
  83                     (t 'mono)))
  84           (error 'mono))
  85         "A symbol indicating the display Emacs is running under.
  86 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
  87 guesses this display attribute wrongly, either set this variable in
  88 your `~/.emacs' or set the resource `Emacs.displayType' in your
  89 `~/.Xdefaults'. See also `gnus-background-mode'.
  90
  91 This is a meta-variable that will affect what default values other
  92 variables get.  You would normally not change this variable, but
  93 pounce directly on the real variables themselves.")
  94
  95       (defvar gnus-background-mode
  96         (condition-case nil
  97             (let ((bg-resource (x-get-resource ".backgroundMode"
  98                                                "BackgroundMode"))
  99                   (params (frame-parameters)))
 100               (cond (bg-resource (intern (downcase bg-resource)))
 101                     ((and (cdr (assq 'background-color params))
 102                           (< (apply '+ (x-color-values
 103                                         (cdr (assq 'background-color params))))
 104                              (/ (apply '+ (x-color-values "white")) 3)))
 105                      'dark)
 106                     (t 'light)))
 107           (error 'light))
 108         "A symbol indicating the Emacs background brightness.
 109 The symbol should be one of `light' or `dark'.
 110 If Emacs guesses this frame attribute wrongly, either set this variable in
 111 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 112 `~/.Xdefaults'.
 113 See also `gnus-display-type'.
 114
 115 This is a meta-variable that will affect what default values other
 116 variables get.  You would normally not change this variable, but
 117 pounce directly on the real variables themselves."))
 118
 119     (cond
 120      ((string-match "XEmacs\\|Lucid" emacs-version)
 121       ;; XEmacs definitions.
 122
 123       (setq gnus-mouse-2 [button2])
 124       (setq gnus-easymenu 'auc-menu)
 125
 126       (or (memq 'underline (list-faces))
 127           (and (fboundp 'make-face)
 128                (funcall (intern "make-face") 'underline)))
 129       ;; Must avoid calling set-face-underline-p directly, because it
 130       ;; is a defsubst in emacs19, and will make the .elc files non
 131       ;; portable!
 132       (or (face-differs-from-default-p 'underline)
 133           (funcall 'set-face-underline-p 'underline t))
 134
 135       (defun set-text-properties (start end props &optional buffer)
 136         "You should NEVER use this function.  It is ideologically blasphemous.
 137 It is provided only to ease porting of broken FSF Emacs programs."
 138         (if (and (stringp buffer) (not (setq buffer (get-buffer buffer))))
 139             nil
 140           (map-extents (symbol-function
 141                         (lambda (extent ignored)
 142                           (remove-text-properties
 143                            start end
 144                            (list (extent-property extent 'text-prop) nil)
 145                            buffer)))
 146                        buffer start end nil nil 'text-prop)
 147           (add-text-properties start end props buffer)))
 148
 149       (defalias 'gnus-make-overlay 'make-extent)
 150       (defalias 'gnus-overlay-put 'set-extent-property)
 151       (defun gnus-move-overlay (extent start end &optional buffer)
 152         (set-extent-endpoints extent start end))
 153
 154       (or (boundp 'standard-display-table) (setq standard-display-table nil))
 155       (or (boundp 'read-event) (fset 'read-event 'next-command-event))
 156
 157       ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 158       (defvar gnus-display-type (device-class)
 159         "A symbol indicating the display Emacs is running under.
 160 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 161 guesses this display attribute wrongly, either set this variable in
 162 your `~/.emacs' or set the resource `Emacs.displayType' in your
 163 `~/.Xdefaults'. See also `gnus-background-mode'.
 164
 165 This is a meta-variable that will affect what default values other
 166 variables get.  You would normally not change this variable, but
 167 pounce directly on the real variables themselves.")
 168
 169
 170       (or (fboundp 'x-color-values)
 171           (fset 'x-color-values
 172                 (lambda (color)
 173                   (color-instance-rgb-components
 174                    (make-color-instance color)))))
 175
 176       (defvar gnus-background-mode
 177         (let ((bg-resource
 178                (condition-case ()
 179                    (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 180                  (error nil)))
 181               (params (frame-parameters)))
 182           (cond (bg-resource (intern (downcase bg-resource)))
 183                 ((and (assq 'background-color params)
 184                       (< (apply '+ (x-color-values
 185                                     (cdr (assq 'background-color params))))
 186                          (/ (apply '+ (x-color-values "white")) 3)))
 187                  'dark)
 188                 (t 'light)))
 189         "A symbol indicating the Emacs background brightness.
 190 The symbol should be one of `light' or `dark'.
 191 If Emacs guesses this frame attribute wrongly, either set this variable in
 192 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 193 `~/.Xdefaults'.
 194 See also `gnus-display-type'.
 195
 196 This is a meta-variable that will affect what default values other
 197 variables get.  You would normally not change this variable, but
 198 pounce directly on the real variables themselves.")
 199
 200
 201       (defun gnus-install-mouse-tracker ()
 202         (require 'mode-motion)
 203         (setq mode-motion-hook 'mode-motion-highlight-line)))
 204
 205      ((and (not (string-match "28.9" emacs-version))
 206            (not (string-match "29" emacs-version)))
 207       ;; Remove the `intangible' prop.
 208       (let ((props (and (boundp 'gnus-hidden-properties)
 209                         gnus-hidden-properties)))
 210         (while (and props (not (eq (car (cdr props)) 'intangible)))
 211           (setq props (cdr props)))
 212         (and props (setcdr props (cdr (cdr (cdr props))))))
 213       (or (fboundp 'buffer-substring-no-properties)
 214           (defun buffer-substring-no-properties (beg end)
 215             (format "%s" (buffer-substring beg end)))))
 216
 217      ((boundp 'MULE)
 218       (provide 'gnusutil))
 219
 220      )))
 221
 222 (eval-and-compile
 223   (cond
 224    ((not window-system)
 225     (defun gnus-dummy-func (&rest args))
 226     (let ((funcs '(mouse-set-point set-face-foreground
 227                                    set-face-background x-popup-menu)))
 228       (while funcs
 229         (or (fboundp (car funcs))
 230             (fset (car funcs) 'gnus-dummy-func))
 231         (setq funcs (cdr funcs))))))
 232   (or (fboundp 'file-regular-p)
 233       (defun file-regular-p (file)
 234         (and (not (file-directory-p file))
 235              (not (file-symlink-p file))
 236              (file-exists-p file))))
 237   (or (fboundp 'face-list)
 238       (defun face-list (&rest args)))
 239   )
 240
 241 (defun gnus-highlight-selected-summary-xemacs ()
 242   ;; Highlight selected article in summary buffer
 243   (if gnus-summary-selected-face
 244       (progn
 245         (if gnus-newsgroup-selected-overlay
 246             (delete-extent gnus-newsgroup-selected-overlay))
 247         (setq gnus-newsgroup-selected-overlay
 248               (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 249         (set-extent-face gnus-newsgroup-selected-overlay
 250                          gnus-summary-selected-face))))
 251
 252 (defun gnus-summary-recenter-xemacs ()
 253   (let* ((top (cond ((< (window-height) 4) 0)
 254                     ((< (window-height) 7) 1)
 255                     (t 2)))
 256          (height (- (window-height) 2))
 257          (bottom (save-excursion (goto-char (point-max))
 258                                  (forward-line (- height))
 259                                  (point)))
 260          (window (get-buffer-window (current-buffer))))
 261     (and
 262      ;; The user has to want it,
 263      gnus-auto-center-summary
 264      ;; the article buffer must be displayed,
 265      (get-buffer-window gnus-article-buffer)
 266      ;; Set the window start to either `bottom', which is the biggest
 267      ;; possible valid number, or the second line from the top,
 268      ;; whichever is the least.
 269      (set-window-start
 270       window (min bottom (save-excursion (forward-line (- top))
 271                                          (point)))))))
 272
 273 (defun gnus-group-insert-group-line-info-xemacs (group)
 274   (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
 275         (beg (point))
 276         active info)
 277     (if entry
 278         (progn
 279           (setq info (nth 2 entry))
 280           (gnus-group-insert-group-line
 281            nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
 282       (setq active (gnus-gethash group gnus-active-hashtb))
 283
 284       (gnus-group-insert-group-line
 285        nil group (if (member group gnus-zombie-list) gnus-level-zombie
 286                    gnus-level-killed)
 287        nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
 288     (save-excursion
 289       (goto-char beg)
 290       (remove-text-properties
 291        (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 292        '(gnus-group nil)))))
 293
 294 (defun gnus-summary-refer-article-xemacs (message-id)
 295   "Refer article specified by MESSAGE-ID.
 296 NOTE: This command only works with newsgroups that use real or simulated NNTP."
 297   (interactive "sMessage-ID: ")
 298   (if (or (not (stringp message-id))
 299           (zerop (length message-id)))
 300       ()
 301     ;; Construct the correct Message-ID if necessary.
 302     ;; Suggested by tale@pawl.rpi.edu.
 303     (or (string-match "^<" message-id)
 304         (setq message-id (concat "<" message-id)))
 305     (or (string-match ">$" message-id)
 306         (setq message-id (concat message-id ">")))
 307     (let ((header (car (gnus-gethash (downcase message-id)
 308                                      gnus-newsgroup-dependencies))))
 309       (if header
 310           (or (gnus-summary-goto-article (mail-header-number header))
 311               ;; The header has been read, but the article had been
 312               ;; expunged, so we insert it again.
 313               (let ((beg (point)))
 314                 (gnus-summary-insert-line
 315                  nil header 0 nil gnus-read-mark nil nil
 316                  (mail-header-subject header))
 317                 (save-excursion
 318                   (goto-char beg)
 319                   (remove-text-properties
 320                    (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 321                    '(gnus-number nil gnus-mark nil gnus-level nil)))
 322                 (forward-line -1)
 323                 (mail-header-number header)))
 324         (let ((gnus-override-method gnus-refer-article-method)
 325               (gnus-ancient-mark gnus-read-mark)
 326               (tmp-point (window-start
 327                           (get-buffer-window gnus-article-buffer)))
 328               number tmp-buf)
 329           (and gnus-refer-article-method
 330                (gnus-check-server gnus-refer-article-method))
 331           ;; Save the old article buffer.
 332           (save-excursion
 333             (set-buffer gnus-article-buffer)
 334             (gnus-kill-buffer " *temp Article*")
 335             (setq tmp-buf (rename-buffer " *temp Article*")))
 336           (prog1
 337               (if (gnus-article-prepare
 338                    message-id nil (gnus-read-header message-id))
 339                   (progn
 340                     (setq number (mail-header-number gnus-current-headers))
 341                     (gnus-rebuild-thread message-id)
 342                     (gnus-summary-goto-subject number)
 343                     (gnus-summary-recenter)
 344                     (gnus-article-set-window-start
 345                      (cdr (assq number gnus-newsgroup-bookmarks)))
 346                     message-id)
 347                 ;; We restore the old article buffer.
 348                 (save-excursion
 349                   (kill-buffer gnus-article-buffer)
 350                   (set-buffer tmp-buf)
 351                   (rename-buffer gnus-article-buffer)
 352                   (let ((buffer-read-only nil))
 353                     (and tmp-point
 354                          (set-window-start (get-buffer-window (current-buffer))
 355                                            tmp-point)))))))))))
 356
 357 (defun gnus-summary-insert-pseudos-xemacs (pslist &optional not-view)
 358   (let ((buffer-read-only nil)
 359         (article (gnus-summary-article-number))
 360         b)
 361     (or (gnus-summary-goto-subject article)
 362         (error (format "No such article: %d" article)))
 363     (or gnus-newsgroup-headers-hashtb-by-number
 364         (gnus-make-headers-hashtable-by-number))
 365     (gnus-summary-position-cursor)
 366     ;; If all commands are to be bunched up on one line, we collect
 367     ;; them here.
 368     (if gnus-view-pseudos-separately
 369         ()
 370       (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
 371             files action)
 372         (while ps
 373           (setq action (cdr (assq 'action (car ps))))
 374           (setq files (list (cdr (assq 'name (car ps)))))
 375           (while (and ps (cdr ps)
 376                       (string= (or action "1")
 377                                (or (cdr (assq 'action (car (cdr ps)))) "2")))
 378             (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
 379             (setcdr ps (cdr (cdr ps))))
 380           (if (not files)
 381               ()
 382             (if (not (string-match "%s" action))
 383                 (setq files (cons " " files)))
 384             (setq files (cons " " files))
 385             (and (assq 'execute (car ps))
 386                  (setcdr (assq 'execute (car ps))
 387                          (funcall (if (string-match "%s" action)
 388                                       'format 'concat)
 389                                   action
 390                                   (mapconcat (lambda (f) f) files " ")))))
 391           (setq ps (cdr ps)))))
 392     (if (and gnus-view-pseudos (not not-view))
 393         (while pslist
 394           (and (assq 'execute (car pslist))
 395                (gnus-execute-command (cdr (assq 'execute (car pslist)))
 396                                      (eq gnus-view-pseudos 'not-confirm)))
 397           (setq pslist (cdr pslist)))
 398       (save-excursion
 399         (while pslist
 400           (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
 401                                          (gnus-summary-article-number)))
 402           (forward-line 1)
 403           (setq b (point))
 404           (insert "          "
 405                   (file-name-nondirectory (cdr (assq 'name (car pslist))))
 406                   ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
 407           (add-text-properties
 408            b (1+ b) (list 'gnus-number gnus-reffed-article-number
 409                           'gnus-mark gnus-unread-mark
 410                           'gnus-level 0
 411                           'gnus-pseudo (car pslist)))
 412           ;; Fucking XEmacs redisplay bug with truncated lines.
 413           (goto-char b)
 414           (sit-for 0)
 415           ;; Grumble.. Fucking XEmacs stickyness of text properties.
 416           (remove-text-properties
 417            (1+ b) (1+ (gnus-point-at-eol))
 418            '(gnus-number nil gnus-mark nil gnus-level nil))
 419           (forward-line -1)
 420           (gnus-sethash (int-to-string gnus-reffed-article-number)
 421                         (car pslist) gnus-newsgroup-headers-hashtb-by-number)
 422           (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
 423           (setq pslist (cdr pslist)))))))
 424
 425
 426 (defun gnus-copy-article-buffer-xemacs (&optional article-buffer)
 427   (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
 428   (buffer-disable-undo gnus-article-copy)
 429   (or (memq gnus-article-copy gnus-buffer-list)
 430       (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
 431   (let ((article-buffer (or article-buffer gnus-article-buffer))
 432         buf)
 433     (if (and (get-buffer article-buffer)
 434              (buffer-name (get-buffer article-buffer)))
 435         (save-excursion
 436           (set-buffer article-buffer)
 437           (widen)
 438           (setq buf (buffer-substring (point-min) (point-max)))
 439           (set-buffer gnus-article-copy)
 440           (erase-buffer)
 441           (insert (format "%s" buf))))))
 442
 443 (defun gnus-article-push-button-xemacs (event)
 444   "Check text under the mouse pointer for a callback function.
 445 If the text under the mouse pointer has a `gnus-callback' property,
 446 call it with the value of the `gnus-data' text property."
 447   (interactive "e")
 448   (set-buffer (window-buffer (event-window event)))
 449   (let* ((pos (event-closest-point event))
 450          (data (get-text-property pos 'gnus-data))
 451          (fun (get-text-property pos 'gnus-callback)))
 452     (if fun (funcall fun data))))
 453
 454 ;; Re-build the thread containing ID.
 455 (defun gnus-rebuild-thread-xemacs  (id)
 456   (let ((dep gnus-newsgroup-dependencies)
 457         (buffer-read-only nil)
 458         parent headers refs thread art)
 459     (while (and id (setq headers
 460                          (car (setq art (gnus-gethash (downcase id)
 461                                                       dep)))))
 462       (setq parent art)
 463       (setq id (and (setq refs (mail-header-references headers))
 464                     (string-match "\\(<[^>]+>\\) *$" refs)
 465                     (substring refs (match-beginning 1) (match-end 1)))))
 466     (setq thread (gnus-make-sub-thread (car parent)))
 467     (gnus-rebuild-remove-articles thread)
 468     (let ((beg (point)))
 469       (gnus-summary-prepare-threads (list thread) 0)
 470       (save-excursion
 471         (while (and (>= (point) beg)
 472                     (not (bobp)))
 473           (or (eobp)
 474               (remove-text-properties
 475                (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 476                '(gnus-number nil gnus-mark nil gnus-level nil)))
 477           (forward-line -1)))
 478       (gnus-summary-update-lines beg (point)))))
 479
 480
 481 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 482 (defun gnus-article-add-button-xemacs (from to fun &optional data)
 483   "Create a button between FROM and TO with callback FUN and data DATA."
 484   (and gnus-article-button-face
 485        (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
 486   (add-text-properties from to
 487                        (append
 488                         (and gnus-article-mouse-face
 489                              (list 'mouse-face gnus-article-mouse-face))
 490                         (list 'gnus-callback fun)
 491                         (and data (list 'gnus-data data))
 492                         (list 'highlight t))))
 493
 494 (defun gnus-window-top-edge-xemacs (&optional window)
 495   (nth 1 (window-pixel-edges window)))
 496
 497 ;; Select the lowest window on the frame.
 498 (defun gnus-appt-select-lowest-window-xemacs ()
 499   (let* ((lowest-window (selected-window))
 500          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 501          (last-window (previous-window))
 502          (window-search t))
 503     (while window-search
 504       (let* ((this-window (next-window))
 505              (next-bottom-edge (car (cdr (cdr (cdr
 506                                                (window-pixel-edges
 507                                                 this-window)))))))
 508         (if (< bottom-edge next-bottom-edge)
 509             (progn
 510               (setq bottom-edge next-bottom-edge)
 511               (setq lowest-window this-window)))
 512
 513         (select-window this-window)
 514         (if (eq last-window this-window)
 515             (progn
 516               (select-window lowest-window)
 517               (setq window-search nil)))))))
 518
 519
 520 (defun gnus-ems-redefine ()
 521   (cond
 522    ((string-match "XEmacs\\|Lucid" emacs-version)
 523     ;; XEmacs definitions.
 524     (fset 'gnus-mouse-face-function 'identity)
 525     (fset 'gnus-summary-make-display-table (lambda () nil))
 526     (fset 'gnus-visual-turn-off-edit-menu 'identity)
 527     (fset 'gnus-highlight-selected-summary
 528           'gnus-highlight-selected-summary-xemacs)
 529     (fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
 530     (fset 'gnus-group-insert-group-line-info
 531           'gnus-group-insert-group-line-info-xemacs)
 532     (fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
 533     (fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
 534     (fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
 535     (fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
 536     (fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
 537     (fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
 538     (fset 'gnus-window-top-edge 'gnus-window-top-edge-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