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