--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/packages/shell-font.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,141 @@
+;; Decorate a shell buffer with fonts.
+;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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.
+
+;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: Not in FSF.
+
+;; Do this: (add-hook 'shell-mode-hook 'install-shell-fonts) 
+;; and the prompt in your shell-buffers will appear bold-italic, process
+;; output will appear in normal face, and typein will appear in bold.
+;;
+;; The faces shell-prompt, shell-input and shell-output can be modified
+;; as desired, for example, (copy-face 'italic 'shell-prompt).
+
+;; Written by Jamie Zawinski, overhauled by Eric Benson.
+
+;; TODO:
+;; =====
+;; Parse ANSI/VT100 escape sequences to turn on underlining/boldface/etc.
+;; Automatically run nuke-nroff-bs?
+
+
+(require 'text-props)	; for put-nonduplicable-text-property
+
+(make-face 'shell-prompt)
+(if (not (face-differs-from-default-p 'shell-prompt))
+    (copy-face 'bold-italic 'shell-prompt))
+
+(make-face 'shell-input)
+(if (not (face-differs-from-default-p 'shell-input))
+    (copy-face 'bold 'shell-input))
+
+(make-face 'shell-output)
+(if (not (face-differs-from-default-p 'shell-output))
+    (progn (make-face-unbold 'shell-output)
+	   (make-face-unitalic 'shell-output)
+	   (set-face-underline-p 'shell-output nil)))
+
+(defvar shell-font-read-only-prompt nil
+  "*Set all shell prompts to be read-only")
+
+(defvar shell-font-current-face 'shell-input)
+
+(defun shell-font-fontify-region (start end delete-count)
+  ;; for use as an element of after-change-functions; fontifies the inserted text.
+  (if (= start end)
+      nil
+;    ;; This creates lots of extents (one per user-typed character)
+;    ;; which is wasteful of memory.
+;    (let ((e (make-extent start end)))
+;      (set-extent-face e shell-font-current-face)
+;      (set-extent-property e 'shell-font t))
+
+    ;; This efficiently merges extents
+    (put-nonduplicable-text-property start end 'face shell-font-current-face)
+    (and shell-font-read-only-prompt
+	 (eq shell-font-current-face 'shell-prompt)
+	 (put-nonduplicable-text-property start end 'read-only t))
+    ))
+
+(defun shell-font-hack-prompt (limit)
+  "Search backward from point-max for text matching the comint-prompt-regexp,
+and put it in the `shell-prompt' face.  LIMIT is the left bound of the search."
+  (save-excursion
+    (goto-char (point-max))
+    (save-match-data
+     (cond ((re-search-backward comint-prompt-regexp limit t)
+	    (goto-char (match-end 0))
+	    (cond ((= (point) (point-max))
+		   (skip-chars-backward " \t")
+		   (let ((shell-font-current-face 'shell-prompt))
+		     (shell-font-fontify-region
+		      (match-beginning 0) (point) 0)))))))))
+
+
+(defvar shell-font-process-filter nil
+  "In an interaction buffer with shell-font, this is the original proc filter.
+shell-font encapsulates this.")
+
+(defun shell-font-process-filter (proc string)
+  "Invoke the original process filter, then set fonts on the output.
+The original filter is in the buffer-local variable shell-font-process-filter."
+  (let ((cb (current-buffer))
+	(pb (process-buffer proc)))
+    (if (null pb)
+	;; If the proc has no buffer, leave it alone.
+	(funcall shell-font-process-filter proc string)
+      ;; Don't do save excursion because some proc filters want to change
+      ;; the buffer's point.
+      (set-buffer pb)
+      (let ((p (marker-position (process-mark proc))))
+	(prog1
+	    ;; this let must not be around the `set-buffer' call.
+	    (let ((shell-font-current-face 'shell-output))
+	      (funcall shell-font-process-filter proc string))
+	  (shell-font-hack-prompt p)
+	  (set-buffer cb))))))
+
+;;;###autoload
+(defun install-shell-fonts ()
+  "Decorate the current interaction buffer with fonts.
+This uses the faces called `shell-prompt', `shell-input' and `shell-output';
+you can alter the graphical attributes of those with the normal
+face-manipulation functions."
+  (let* ((proc (or (get-buffer-process (current-buffer))
+		   (error "no process in %S" (current-buffer))))
+	 (old (or (process-filter proc)
+		  (error "no process filter on %S" proc))))
+    (make-local-variable 'after-change-functions)
+    (add-hook 'after-change-functions 'shell-font-fontify-region)
+    (make-local-variable 'shell-font-current-face)
+    (setq shell-font-current-face 'shell-input)
+    (make-local-variable 'shell-font-process-filter)
+    (or (eq old 'shell-font-process-filter) ; already set
+	(setq shell-font-process-filter old))
+    (set-process-filter proc 'shell-font-process-filter))
+  nil)
+
+(add-hook 'shell-mode-hook	'install-shell-fonts)
+(add-hook 'telnet-mode-hook	'install-shell-fonts)
+(add-hook 'gdb-mode-hook	'install-shell-fonts)
+
+;; for compatibility with the 19.8 version
+;(fset 'install-shell-font-prompt 'install-shell-fonts)
+(make-obsolete 'install-shell-font-prompt 'install-shell-fonts)
+
+(provide 'shell-font)