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