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