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