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