[bpt/emacs.git] / lisp / gnus-ems.el

;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
;; Copyright (C) 1995,96 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl))

(defvar gnus-mouse-2 [mouse-2])

(defalias 'gnus-make-overlay 'make-overlay)
(defalias 'gnus-overlay-put 'overlay-put)
(defalias 'gnus-move-overlay 'move-overlay)
(defalias 'gnus-overlay-end 'overlay-end)
(defalias 'gnus-extent-detached-p 'ignore)
(defalias 'gnus-extent-start-open 'ignore)
(defalias 'gnus-set-text-properties 'set-text-properties)
(defalias 'gnus-group-remove-excess-properties 'ignore)
(defalias 'gnus-topic-remove-excess-properties 'ignore)
(defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
(defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
(defalias 'gnus-make-local-hook 'make-local-hook)
(defalias 'gnus-add-hook 'add-hook)
(defalias 'gnus-character-to-event 'identity)
(defalias 'gnus-add-text-properties 'add-text-properties)
(defalias 'gnus-put-text-property 'put-text-property)
(defalias 'gnus-mode-line-buffer-identification 'identity)


(eval-and-compile 
  (autoload 'gnus-xmas-define "gnus-xmas")
  (autoload 'gnus-xmas-redefine "gnus-xmas")
  (autoload 'appt-select-lowest-window "appt.el"))

(or (fboundp 'mail-file-babyl-p)
    (fset 'mail-file-babyl-p 'rmail-file-p))

;;; Mule functions.

(defun gnus-mule-cite-add-face (number prefix face)
  ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
  (if face
      (let ((inhibit-point-motion-hooks t)
	    from to)
	(goto-line number)
	(if (boundp 'MULE)
	    (forward-char (chars-in-string prefix))
	  (forward-char (length prefix)))
	(skip-chars-forward " \t")
	(setq from (point))
	(end-of-line 1)
	(skip-chars-backward " \t")
	(setq to (point))
	(if (< from to)
	    (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))

(defun gnus-mule-max-width-function (el max-width)
  (` (let* ((val (eval (, el)))
	    (valstr (if (numberp val)
			(int-to-string val) val)))
       (if (> (length valstr) (, max-width))
	   (truncate-string valstr (, max-width))
	 valstr))))

(eval-and-compile
  (if (string-match "XEmacs\\|Lucid" emacs-version)
      ()

    (defvar gnus-mouse-face-prop 'mouse-face
      "Property used for highlighting mouse regions.")

    (defvar gnus-article-x-face-command
      "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
      "String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously.	 The compressed face will be piped to this command.")

    ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
    (defvar gnus-display-type 
      (condition-case nil
	  (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
	    (cond (display-resource (intern (downcase display-resource)))
		  ((x-display-color-p) 'color)
		  ((x-display-grayscale-p) 'grayscale)
		  (t 'mono)))
	(error 'mono))
      "A symbol indicating the display Emacs is running under.
The symbol should be one of `color', `grayscale' or `mono'. If Emacs
guesses this display attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.displayType' in your
`~/.Xdefaults'. See also `gnus-background-mode'.

This is a meta-variable that will affect what default values other
variables get.  You would normally not change this variable, but
pounce directly on the real variables themselves.")

    (defvar gnus-background-mode 
      (condition-case nil
	  (let ((bg-resource (x-get-resource ".backgroundMode"
					     "BackgroundMode"))
		(params (frame-parameters)))
	    (cond (bg-resource (intern (downcase bg-resource)))
		  ((and (cdr (assq 'background-color params))
			(< (apply '+ (x-color-values
				      (cdr (assq 'background-color params))))
			   (* (apply '+ (x-color-values "white")) .6)))
		   'dark)
		  (t 'light)))
	(error 'light))
      "A symbol indicating the Emacs background brightness.
The symbol should be one of `light' or `dark'.
If Emacs guesses this frame attribute wrongly, either set this variable in
your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
`~/.Xdefaults'.
See also `gnus-display-type'.

This is a meta-variable that will affect what default values other
variables get.  You would normally not change this variable, but
pounce directly on the real variables themselves."))

  (cond 
   ((string-match "XEmacs\\|Lucid" emacs-version)
    (gnus-xmas-define))

   ((or (not (boundp 'emacs-minor-version))
	(< emacs-minor-version 30))
    ;; Remove the `intangible' prop.
    (let ((props (and (boundp 'gnus-hidden-properties) 
		      gnus-hidden-properties)))
      (while (and props (not (eq (car (cdr props)) 'intangible)))
	(setq props (cdr props)))
      (and props (setcdr props (cdr (cdr (cdr props))))))
    (or (fboundp 'buffer-substring-no-properties)
	(defun buffer-substring-no-properties (beg end)
	  (format "%s" (buffer-substring beg end)))))
   
   ((boundp 'MULE)
    (provide 'gnusutil))))

(eval-and-compile
  (cond
   ((not window-system)
    (defun gnus-dummy-func (&rest args))
    (let ((funcs '(mouse-set-point set-face-foreground
				   set-face-background x-popup-menu)))
      (while funcs
	(or (fboundp (car funcs))
	    (fset (car funcs) 'gnus-dummy-func))
	(setq funcs (cdr funcs))))))
  (or (fboundp 'file-regular-p)
      (defun file-regular-p (file)
	(and (not (file-directory-p file))
	     (not (file-symlink-p file))
	     (file-exists-p file))))
  (or (fboundp 'face-list)
      (defun face-list (&rest args))))

(eval-and-compile
  (let ((case-fold-search t))
    (cond
     ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type))
      (setq nnheader-file-name-translation-alist
	    (append nnheader-file-name-translation-alist
		    '((?: . ?_)
		      (?+ . ?-))))))))

(defvar gnus-tmp-unread)
(defvar gnus-tmp-replied)
(defvar gnus-tmp-score-char)
(defvar gnus-tmp-indentation)
(defvar gnus-tmp-opening-bracket)
(defvar gnus-tmp-lines)
(defvar gnus-tmp-name)
(defvar gnus-tmp-closing-bracket)
(defvar gnus-tmp-subject-or-nil)

(defun gnus-ems-redefine ()
  (cond 
   ((string-match "XEmacs\\|Lucid" emacs-version)
    (gnus-xmas-redefine))

   ((boundp 'MULE)
    ;; Mule definitions
    (defalias 'gnus-truncate-string 'truncate-string)

    (fset 'gnus-summary-make-display-table (lambda () nil))
    (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
    (fset 'gnus-max-width-function 'gnus-mule-max-width-function)
    
    (if (boundp 'gnus-check-before-posting)
	(setq gnus-check-before-posting
	      (delq 'long-lines
		    (delq 'control-chars gnus-check-before-posting))))

    (defun gnus-summary-line-format-spec ()
      (insert gnus-tmp-unread gnus-tmp-replied 
	      gnus-tmp-score-char gnus-tmp-indentation)
      (put-text-property
       (point)
       (progn
	 (insert 
	  gnus-tmp-opening-bracket 
	  (format "%4d: %-20s" 
		  gnus-tmp-lines 
		  (if (> (length gnus-tmp-name) 20) 
		      (truncate-string gnus-tmp-name 20) 
		    gnus-tmp-name))
	  gnus-tmp-closing-bracket)
	 (point))
       gnus-mouse-face-prop gnus-mouse-face)
      (insert " " gnus-tmp-subject-or-nil "\n"))
    )))


(provide 'gnus-ems)

;; Local Variables:
;; byte-compile-warnings: '(redefine callargs)
;; End:

;;; gnus-ems.el ends here
Commit	Line	Data
41487370	1	;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
231f989b	2	;; Copyright (C) 1995,96 Free Software Foundation, Inc.
41487370 LMI	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
b578f267 EN	20	;; along with GNU Emacs; see the file COPYING. If not, write to the
	21	;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	22	;; Boston, MA 02111-1307, USA.
41487370 LMI	23
	24	;;; Commentary:
	25
	26	;;; Code:
	27
231f989b LMI	28	(eval-when-compile (require 'cl))
231f989b LMI	29
41487370	30	(defvar gnus-mouse-2 [mouse-2])
41487370 LMI	31
	32	(defalias 'gnus-make-overlay 'make-overlay)
	33	(defalias 'gnus-overlay-put 'overlay-put)
	34	(defalias 'gnus-move-overlay 'move-overlay)
231f989b LMI	35	(defalias 'gnus-overlay-end 'overlay-end)
	36	(defalias 'gnus-extent-detached-p 'ignore)
	37	(defalias 'gnus-extent-start-open 'ignore)
	38	(defalias 'gnus-set-text-properties 'set-text-properties)
	39	(defalias 'gnus-group-remove-excess-properties 'ignore)
	40	(defalias 'gnus-topic-remove-excess-properties 'ignore)
	41	(defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window)
	42	(defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names)
	43	(defalias 'gnus-make-local-hook 'make-local-hook)
	44	(defalias 'gnus-add-hook 'add-hook)
	45	(defalias 'gnus-character-to-event 'identity)
	46	(defalias 'gnus-add-text-properties 'add-text-properties)
	47	(defalias 'gnus-put-text-property 'put-text-property)
	48	(defalias 'gnus-mode-line-buffer-identification 'identity)
	49
	50
	51	(eval-and-compile
	52	(autoload 'gnus-xmas-define "gnus-xmas")
	53	(autoload 'gnus-xmas-redefine "gnus-xmas")
	54	(autoload 'appt-select-lowest-window "appt.el"))
41487370 LMI	55
	56	(or (fboundp 'mail-file-babyl-p)
	57	(fset 'mail-file-babyl-p 'rmail-file-p))
	58
231f989b LMI	59	;;; Mule functions.
	60
	61	(defun gnus-mule-cite-add-face (number prefix face)
	62	;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
	63	(if face
	64	(let ((inhibit-point-motion-hooks t)
	65	from to)
	66	(goto-line number)
	67	(if (boundp 'MULE)
	68	(forward-char (chars-in-string prefix))
	69	(forward-char (length prefix)))
	70	(skip-chars-forward " \t")
	71	(setq from (point))
	72	(end-of-line 1)
	73	(skip-chars-backward " \t")
	74	(setq to (point))
	75	(if (< from to)
	76	(gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
	77
	78	(defun gnus-mule-max-width-function (el max-width)
	79	(` (let* ((val (eval (, el)))
	80	(valstr (if (numberp val)
	81	(int-to-string val) val)))
	82	(if (> (length valstr) (, max-width))
	83	(truncate-string valstr (, max-width))
	84	valstr))))
41487370	85
231f989b LMI	86	(eval-and-compile
	87	(if (string-match "XEmacs\\\|Lucid" emacs-version)
	88	()
41487370	89
231f989b LMI	90	(defvar gnus-mouse-face-prop 'mouse-face
	91	"Property used for highlighting mouse regions.")
	92
	93	(defvar gnus-article-x-face-command
	94	"{ echo '/* Width=48, Height=48 */'; uncompface; } \| icontopbm \| xv -quit -"
	95	"String or function to be executed to display an X-Face header.
	96	If it is a string, the command will be executed in a sub-shell
	97	asynchronously. The compressed face will be piped to this command.")
	98
	99	;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
	100	(defvar gnus-display-type
	101	(condition-case nil
	102	(let ((display-resource (x-get-resource ".displayType" "DisplayType")))
	103	(cond (display-resource (intern (downcase display-resource)))
	104	((x-display-color-p) 'color)
	105	((x-display-grayscale-p) 'grayscale)
	106	(t 'mono)))
	107	(error 'mono))
	108	"A symbol indicating the display Emacs is running under.
41487370 LMI	109	The symbol should be one of `color', `grayscale' or `mono'. If Emacs
	110	guesses this display attribute wrongly, either set this variable in
	111	your `~/.emacs' or set the resource `Emacs.displayType' in your
	112	`~/.Xdefaults'. See also `gnus-background-mode'.
	113
	114	This is a meta-variable that will affect what default values other
	115	variables get. You would normally not change this variable, but
	116	pounce directly on the real variables themselves.")
	117
231f989b LMI	118	(defvar gnus-background-mode
	119	(condition-case nil
	120	(let ((bg-resource (x-get-resource ".backgroundMode"
	121	"BackgroundMode"))
	122	(params (frame-parameters)))
	123	(cond (bg-resource (intern (downcase bg-resource)))
	124	((and (cdr (assq 'background-color params))
	125	(< (apply '+ (x-color-values
	126	(cdr (assq 'background-color params))))
	127	(* (apply '+ (x-color-values "white")) .6)))
	128	'dark)
	129	(t 'light)))
	130	(error 'light))
	131	"A symbol indicating the Emacs background brightness.
41487370 LMI	132	The symbol should be one of `light' or `dark'.
	133	If Emacs guesses this frame attribute wrongly, either set this variable in
	134	your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
	135	`~/.Xdefaults'.
	136	See also `gnus-display-type'.
	137
	138	This is a meta-variable that will affect what default values other
	139	variables get. You would normally not change this variable, but
231f989b	140	pounce directly on the real variables themselves."))
41487370	141
231f989b LMI	142	(cond
	143	((string-match "XEmacs\\\|Lucid" emacs-version)
	144	(gnus-xmas-define))
	145
	146	((or (not (boundp 'emacs-minor-version))
	147	(< emacs-minor-version 30))
	148	;; Remove the `intangible' prop.
	149	(let ((props (and (boundp 'gnus-hidden-properties)
	150	gnus-hidden-properties)))
	151	(while (and props (not (eq (car (cdr props)) 'intangible)))
	152	(setq props (cdr props)))
	153	(and props (setcdr props (cdr (cdr (cdr props))))))
	154	(or (fboundp 'buffer-substring-no-properties)
	155	(defun buffer-substring-no-properties (beg end)
	156	(format "%s" (buffer-substring beg end)))))
41487370	157
231f989b LMI	158	((boundp 'MULE)
231f989b LMI	159	(provide 'gnusutil))))
41487370 LMI	160
	161	(eval-and-compile
	162	(cond
	163	((not window-system)
	164	(defun gnus-dummy-func (&rest args))
	165	(let ((funcs '(mouse-set-point set-face-foreground
	166	set-face-background x-popup-menu)))
	167	(while funcs
	168	(or (fboundp (car funcs))
	169	(fset (car funcs) 'gnus-dummy-func))
	170	(setq funcs (cdr funcs))))))
	171	(or (fboundp 'file-regular-p)
	172	(defun file-regular-p (file)
	173	(and (not (file-directory-p file))
	174	(not (file-symlink-p file))
	175	(file-exists-p file))))
	176	(or (fboundp 'face-list)
231f989b LMI	177	(defun face-list (&rest args))))
	178
	179	(eval-and-compile
	180	(let ((case-fold-search t))
	181	(cond
	182	((string-match "windows-nt\\\|os/2\\\|emx" (format "%s" system-type))
	183	(setq nnheader-file-name-translation-alist
	184	(append nnheader-file-name-translation-alist
	185	'((?: . ?_)
	186	(?+ . ?-))))))))
	187
	188	(defvar gnus-tmp-unread)
	189	(defvar gnus-tmp-replied)
	190	(defvar gnus-tmp-score-char)
	191	(defvar gnus-tmp-indentation)
	192	(defvar gnus-tmp-opening-bracket)
	193	(defvar gnus-tmp-lines)
	194	(defvar gnus-tmp-name)
	195	(defvar gnus-tmp-closing-bracket)
	196	(defvar gnus-tmp-subject-or-nil)
41487370 LMI	197
	198	(defun gnus-ems-redefine ()
	199	(cond
	200	((string-match "XEmacs\\\|Lucid" emacs-version)
231f989b	201	(gnus-xmas-redefine))
41487370 LMI	202
	203	((boundp 'MULE)
	204	;; Mule definitions
41487370 LMI	205	(defalias 'gnus-truncate-string 'truncate-string)
41487370 LMI	206
41487370	207	(fset 'gnus-summary-make-display-table (lambda () nil))
231f989b LMI	208	(fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
231f989b LMI	209	(fset 'gnus-max-width-function 'gnus-mule-max-width-function)
41487370 LMI	210
	211	(if (boundp 'gnus-check-before-posting)
	212	(setq gnus-check-before-posting
	213	(delq 'long-lines
231f989b LMI	214	(delq 'control-chars gnus-check-before-posting))))
	215
	216	(defun gnus-summary-line-format-spec ()
	217	(insert gnus-tmp-unread gnus-tmp-replied
	218	gnus-tmp-score-char gnus-tmp-indentation)
	219	(put-text-property
	220	(point)
	221	(progn
	222	(insert
	223	gnus-tmp-opening-bracket
	224	(format "%4d: %-20s"
	225	gnus-tmp-lines
	226	(if (> (length gnus-tmp-name) 20)
	227	(truncate-string gnus-tmp-name 20)
	228	gnus-tmp-name))
	229	gnus-tmp-closing-bracket)
	230	(point))
	231	gnus-mouse-face-prop gnus-mouse-face)
	232	(insert " " gnus-tmp-subject-or-nil "\n"))
	233	)))
	234
41487370 LMI	235
	236	(provide 'gnus-ems)
	237
	238	;; Local Variables:
	239	;; byte-compile-warnings: '(redefine callargs)
	240	;; End:
	241
	242	;;; gnus-ems.el ends here