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