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