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