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           (and (fboundp 'make-face)
 128                (funcall (intern "make-face") 'underline)))
 129       ;; Must avoid calling set-face-underline-p directly, because it
 130       ;; is a defsubst in emacs19, and will make the .elc files non
 131       ;; portable!
 132       (or (face-differs-from-default-p 'underline)
 133           (funcall 'set-face-underline-p 'underline t))
 134       (or (fboundp 'set-text-properties)
 135           (defun set-text-properties (start end props &optional buffer)
 136             (if (or (null buffer) (bufferp buffer))
 137                 (if props
 138                     (while props
 139                       (put-text-property
 140                        start end (car props) (nth 1 props) buffer)
 141                       (setq props (nthcdr 2 props)))
 142                   (remove-text-properties start end ())))))
 143
 144       (defalias 'gnus-make-overlay 'make-extent)
 145       (defalias 'gnus-overlay-put 'set-extent-property)
 146       (defun gnus-move-overlay (extent start end &optional buffer)
 147         (set-extent-endpoints extent start end))
 148
 149       (or (boundp 'standard-display-table) (setq standard-display-table nil))
 150       (or (boundp 'read-event) (fset 'read-event 'next-command-event))
 151
 152       ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
 153       (defvar gnus-display-type (device-class)
 154         "A symbol indicating the display Emacs is running under.
 155 The symbol should be one of `color', `grayscale' or `mono'. If Emacs
 156 guesses this display attribute wrongly, either set this variable in
 157 your `~/.emacs' or set the resource `Emacs.displayType' in your
 158 `~/.Xdefaults'. See also `gnus-background-mode'.
 159
 160 This is a meta-variable that will affect what default values other
 161 variables get.  You would normally not change this variable, but
 162 pounce directly on the real variables themselves.")
 163
 164
 165       (or (fboundp 'x-color-values)
 166           (fset 'x-color-values
 167                 (lambda (color)
 168                   (color-instance-rgb-components
 169                    (make-color-instance color)))))
 170
 171       (defvar gnus-background-mode
 172         (let ((bg-resource
 173                (condition-case ()
 174                    (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
 175                  (error nil)))
 176               (params (frame-parameters)))
 177           (cond (bg-resource (intern (downcase bg-resource)))
 178                 ((and (assq 'background-color params)
 179                       (< (apply '+ (x-color-values
 180                                     (cdr (assq 'background-color params))))
 181                          (/ (apply '+ (x-color-values "white")) 3)))
 182                  'dark)
 183                 (t 'light)))
 184         "A symbol indicating the Emacs background brightness.
 185 The symbol should be one of `light' or `dark'.
 186 If Emacs guesses this frame attribute wrongly, either set this variable in
 187 your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
 188 `~/.Xdefaults'.
 189 See also `gnus-display-type'.
 190
 191 This is a meta-variable that will affect what default values other
 192 variables get.  You would normally not change this variable, but
 193 pounce directly on the real variables themselves.")
 194
 195
 196       (defun gnus-install-mouse-tracker ()
 197         (require 'mode-motion)
 198         (setq mode-motion-hook 'mode-motion-highlight-line)))
 199
 200      ((and (not (string-match "28.9" emacs-version))
 201            (not (string-match "29" emacs-version)))
 202       ;; Remove the `intangible' prop.
 203       (let ((props (and (boundp 'gnus-hidden-properties)
 204                         gnus-hidden-properties)))
 205         (while (and props (not (eq (car (cdr props)) 'intangible)))
 206           (setq props (cdr props)))
 207         (and props (setcdr props (cdr (cdr (cdr props))))))
 208       (or (fboundp 'buffer-substring-no-properties)
 209           (defun buffer-substring-no-properties (beg end)
 210             (format "%s" (buffer-substring beg end)))))
 211
 212      ((boundp 'MULE)
 213       (provide 'gnusutil))
 214
 215      )))
 216
 217 (eval-and-compile
 218   (cond
 219    ((not window-system)
 220     (defun gnus-dummy-func (&rest args))
 221     (let ((funcs '(mouse-set-point set-face-foreground
 222                                    set-face-background x-popup-menu)))
 223       (while funcs
 224         (or (fboundp (car funcs))
 225             (fset (car funcs) 'gnus-dummy-func))
 226         (setq funcs (cdr funcs))))))
 227   (or (fboundp 'file-regular-p)
 228       (defun file-regular-p (file)
 229         (and (not (file-directory-p file))
 230              (not (file-symlink-p file))
 231              (file-exists-p file))))
 232   (or (fboundp 'face-list)
 233       (defun face-list (&rest args)))
 234   )
 235
 236 (defun gnus-highlight-selected-summary-xemacs ()
 237   ;; Highlight selected article in summary buffer
 238   (if gnus-summary-selected-face
 239       (progn
 240         (if gnus-newsgroup-selected-overlay
 241             (delete-extent gnus-newsgroup-selected-overlay))
 242         (setq gnus-newsgroup-selected-overlay
 243               (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
 244         (set-extent-face gnus-newsgroup-selected-overlay
 245                          gnus-summary-selected-face))))
 246
 247 (defun gnus-summary-recenter-xemacs ()
 248   (let* ((top (cond ((< (window-height) 4) 0)
 249                     ((< (window-height) 7) 1)
 250                     (t 2)))
 251          (height (- (window-height) 2))
 252          (bottom (save-excursion (goto-char (point-max))
 253                                  (forward-line (- height))
 254                                  (point)))
 255          (window (get-buffer-window (current-buffer))))
 256     (and
 257      ;; The user has to want it,
 258      gnus-auto-center-summary
 259      ;; the article buffer must be displayed,
 260      (get-buffer-window gnus-article-buffer)
 261      ;; Set the window start to either `bottom', which is the biggest
 262      ;; possible valid number, or the second line from the top,
 263      ;; whichever is the least.
 264      (set-window-start
 265       window (min bottom (save-excursion (forward-line (- top))
 266                                          (point)))))))
 267
 268 (defun gnus-group-insert-group-line-info-xemacs (group)
 269   (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
 270         (beg (point))
 271         active info)
 272     (if entry
 273         (progn
 274           (setq info (nth 2 entry))
 275           (gnus-group-insert-group-line
 276            nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
 277       (setq active (gnus-gethash group gnus-active-hashtb))
 278
 279       (gnus-group-insert-group-line
 280        nil group (if (member group gnus-zombie-list) gnus-level-zombie
 281                    gnus-level-killed)
 282        nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
 283     (save-excursion
 284       (goto-char beg)
 285       (remove-text-properties
 286        (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 287        '(gnus-group nil)))))
 288
 289 (defun gnus-summary-refer-article-xemacs (message-id)
 290   "Refer article specified by MESSAGE-ID.
 291 NOTE: This command only works with newsgroups that use real or simulated NNTP."
 292   (interactive "sMessage-ID: ")
 293   (if (or (not (stringp message-id))
 294           (zerop (length message-id)))
 295       ()
 296     ;; Construct the correct Message-ID if necessary.
 297     ;; Suggested by tale@pawl.rpi.edu.
 298     (or (string-match "^<" message-id)
 299         (setq message-id (concat "<" message-id)))
 300     (or (string-match ">$" message-id)
 301         (setq message-id (concat message-id ">")))
 302     (let ((header (car (gnus-gethash (downcase message-id)
 303                                      gnus-newsgroup-dependencies))))
 304       (if header
 305           (or (gnus-summary-goto-article (mail-header-number header))
 306               ;; The header has been read, but the article had been
 307               ;; expunged, so we insert it again.
 308               (let ((beg (point)))
 309                 (gnus-summary-insert-line
 310                  nil header 0 nil gnus-read-mark nil nil
 311                  (mail-header-subject header))
 312                 (save-excursion
 313                   (goto-char beg)
 314                   (remove-text-properties
 315                    (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 316                    '(gnus-number nil gnus-mark nil gnus-level nil)))
 317                 (forward-line -1)
 318                 (mail-header-number header)))
 319         (let ((gnus-override-method gnus-refer-article-method)
 320               (gnus-ancient-mark gnus-read-mark)
 321               (tmp-point (window-start
 322                           (get-buffer-window gnus-article-buffer)))
 323               number tmp-buf)
 324           (and gnus-refer-article-method
 325                (gnus-check-server gnus-refer-article-method))
 326           ;; Save the old article buffer.
 327           (save-excursion
 328             (set-buffer gnus-article-buffer)
 329             (gnus-kill-buffer " *temp Article*")
 330             (setq tmp-buf (rename-buffer " *temp Article*")))
 331           (prog1
 332               (if (gnus-article-prepare
 333                    message-id nil (gnus-read-header message-id))
 334                   (progn
 335                     (setq number (mail-header-number gnus-current-headers))
 336                     (gnus-rebuild-thread message-id)
 337                     (gnus-summary-goto-subject number)
 338                     (gnus-summary-recenter)
 339                     (gnus-article-set-window-start
 340                      (cdr (assq number gnus-newsgroup-bookmarks)))
 341                     message-id)
 342                 ;; We restore the old article buffer.
 343                 (save-excursion
 344                   (kill-buffer gnus-article-buffer)
 345                   (set-buffer tmp-buf)
 346                   (rename-buffer gnus-article-buffer)
 347                   (let ((buffer-read-only nil))
 348                     (and tmp-point
 349                          (set-window-start (get-buffer-window (current-buffer))
 350                                            tmp-point)))))))))))
 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 (mail-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           (or (eobp)
 469               (remove-text-properties
 470                (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
 471                '(gnus-number nil gnus-mark nil gnus-level nil)))
 472           (forward-line -1)))
 473       (gnus-summary-update-lines beg (point)))))
 474
 475
 476 ;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
 477 (defun gnus-article-add-button-xemacs (from to fun &optional data)
 478   "Create a button between FROM and TO with callback FUN and data DATA."
 479   (and gnus-article-button-face
 480        (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
 481   (add-text-properties from to
 482                        (append
 483                         (and gnus-article-mouse-face
 484                              (list 'mouse-face gnus-article-mouse-face))
 485                         (list 'gnus-callback fun)
 486                         (and data (list 'gnus-data data))
 487                         (list 'highlight t))))
 488
 489 (defun gnus-window-top-edge-xemacs (&optional window)
 490   (nth 1 (window-pixel-edges window)))
 491
 492 ;; Select the lowest window on the frame.
 493 (defun gnus-appt-select-lowest-window-xemacs ()
 494   (let* ((lowest-window (selected-window))
 495          (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
 496          (last-window (previous-window))
 497          (window-search t))
 498     (while window-search
 499       (let* ((this-window (next-window))
 500              (next-bottom-edge (car (cdr (cdr (cdr
 501                                                (window-pixel-edges
 502                                                 this-window)))))))
 503         (if (< bottom-edge next-bottom-edge)
 504             (progn
 505               (setq bottom-edge next-bottom-edge)
 506               (setq lowest-window this-window)))
 507
 508         (select-window this-window)
 509         (if (eq last-window this-window)
 510             (progn
 511               (select-window lowest-window)
 512               (setq window-search nil)))))))
 513
 514
 515 (defun gnus-ems-redefine ()
 516   (cond
 517    ((string-match "XEmacs\\|Lucid" emacs-version)
 518     ;; XEmacs definitions.
 519     (fset 'gnus-mouse-face-function 'identity)
 520     (fset 'gnus-summary-make-display-table (lambda () nil))
 521     (fset 'gnus-visual-turn-off-edit-menu 'identity)
 522     (fset 'gnus-highlight-selected-summary
 523           'gnus-highlight-selected-summary-xemacs)
 524     (fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
 525     (fset 'gnus-group-insert-group-line-info
 526           'gnus-group-insert-group-line-info-xemacs)
 527     (fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
 528     (fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
 529     (fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
 530     (fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
 531     (fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
 532     (fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
 533     (fset 'gnus-window-top-edge 'gnus-window-top-edge-xemacs)
 534
 535     (or (fboundp 'appt-select-lowest-window)
 536         (fset 'appt-select-lowest-window
 537               'gnus-appt-select-lowest-window-xemacs))
 538
 539     (if (not gnus-visual)
 540         ()
 541       (setq gnus-group-mode-hook
 542             (cons
 543              '(lambda ()
 544                 (easy-menu-add gnus-group-reading-menu)
 545                 (easy-menu-add gnus-group-group-menu)
 546                 (easy-menu-add gnus-group-misc-menu)
 547                 (gnus-install-mouse-tracker))
 548              gnus-group-mode-hook))
 549       (setq gnus-summary-mode-hook
 550             (cons
 551              '(lambda ()
 552                 (easy-menu-add gnus-summary-article-menu)
 553                 (easy-menu-add gnus-summary-thread-menu)
 554                 (easy-menu-add gnus-summary-misc-menu)
 555                 (easy-menu-add gnus-summary-post-menu)
 556                 (easy-menu-add gnus-summary-kill-menu)
 557                 (gnus-install-mouse-tracker))
 558              gnus-summary-mode-hook))
 559       (setq gnus-article-mode-hook
 560             (cons
 561              '(lambda ()
 562                 (easy-menu-add gnus-article-article-menu)
 563                 (easy-menu-add gnus-article-treatment-menu))
 564              gnus-article-mode-hook)))
 565
 566     (defvar gnus-logo (make-glyph (make-specifier 'image)))
 567
 568     (defun gnus-group-startup-xmessage (&optional x y)
 569       "Insert startup message in current buffer."
 570       ;; Insert the message.
 571       (erase-buffer)
 572       (if (featurep 'xpm)
 573           (progn
 574             (set-glyph-property gnus-logo 'image  "~/tmp/gnus.xpm")
 575             (set-glyph-image gnus-logo "~/tmp/gnus.xpm" 'global 'x)
 576
 577             (insert " ")
 578             (set-extent-begin-glyph (make-extent (point) (point)) gnus-logo)
 579             (insert "
 580    Gnus * A newsreader for Emacsen
 581  A Praxis Release * larsi@ifi.uio.no")
 582             (goto-char (point-min))
 583             (while (not (eobp))
 584               (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
 585                                    ? ))
 586               (forward-line 1))
 587             (goto-char (point-min))
 588             ;; +4 is fuzzy factor.
 589             (insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
 590
 591         (insert
 592          (format "
 593      %s
 594            A newsreader
 595       for GNU Emacs
 596
 597         Based on GNUS
 598              written by
 599      Masanobu UMEDA
 600
 601        A Praxis Release
 602       larsi@ifi.uio.no
 603 "
 604                  gnus-version))
 605         ;; And then hack it.
 606         ;; 18 is the longest line.
 607         (indent-rigidly (point-min) (point-max)
 608                         (/ (max (- (window-width) (or x 28)) 0) 2))
 609         (goto-char (point-min))
 610         ;; +4 is fuzzy factor.
 611         (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
 612
 613       ;; Fontify some.
 614       (goto-char (point-min))
 615       (search-forward "Praxis")
 616       (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
 617       (goto-char (point-min)))
 618
 619
 620
 621     )
 622
 623    ((boundp 'MULE)
 624     ;; Mule definitions
 625     (if (not (fboundp 'truncate-string))
 626         (defun truncate-string (str width)
 627           (let ((w (string-width str))
 628                 (col 0) (idx 0) (p-idx 0) chr)
 629             (if (<= w width)
 630                 str
 631               (while (< col width)
 632                 (setq chr (aref str idx)
 633                       col (+ col (char-width chr))
 634                       p-idx idx
 635                       idx (+ idx (char-bytes chr))
 636                       ))
 637               (substring str 0 (if (= col width)
 638                                    idx
 639                                  p-idx))
 640               )))
 641       )
 642     (defalias 'gnus-truncate-string 'truncate-string)
 643
 644     (defun gnus-cite-add-face (number prefix face)
 645       ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
 646       (if face
 647           (let ((inhibit-point-motion-hooks t)
 648                 from to)
 649             (goto-line number)
 650             (if (boundp 'MULE)
 651                 (forward-char (chars-in-string prefix))
 652               (forward-char (length prefix)))
 653             (skip-chars-forward " \t")
 654             (setq from (point))
 655             (end-of-line 1)
 656             (skip-chars-backward " \t")
 657             (setq to (point))
 658             (if (< from to)
 659                 (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
 660
 661     (defun gnus-max-width-function (el max-width)
 662       (` (let* ((val (eval (, el)))
 663                 (valstr (if (numberp val)
 664                             (int-to-string val) val)))
 665            (if (> (length valstr) (, max-width))
 666                (truncate-string valstr (, max-width))
 667              valstr))))
 668
 669     (fset 'gnus-summary-make-display-table (lambda () nil))
 670
 671     (if (boundp 'gnus-check-before-posting)
 672         (setq gnus-check-before-posting
 673               (delq 'long-lines
 674                     (delq 'control-chars gnus-check-before-posting)))
 675       )
 676     )
 677    ))
 678
 679 (provide 'gnus-ems)
 680
 681 ;; Local Variables:
 682 ;; byte-compile-warnings: '(redefine callargs)
 683 ;; End:
 684
 685 ;;; gnus-ems.el ends here