🚀 go-pugleaf

------- Start of forwarded message -------
Status: RO
X-VM-v5-Data: ([nil nil nil nil nil nil nil nil nil]
	["61387" "Fri" "18" "October" "91" "18:54:12" "CST" "Ken Wood" "kwood@angels " nil "1640" "Epoch highlighting packages: tek-epoch-stuff1.0.0 part 3 of 4" "^From:" nil nil "10"])
Received: from angels.adl.austek (angels.austek) by floyd.adl.austek (4.0/4.2 Austek-CAW)
	id AA12148; Fri, 18 Oct 91 18:54:28 CST
Received: by angels.adl.austek (4.1/4.2 Austek-CAW)
	id AA14809; Fri, 18 Oct 91 18:54:12 CST
Message-Id: <9110180924.AA14809@angels.adl.austek>
X-Face: +Ar(nq[|T7zOhkAD\~cQ9U9>LLq'PDT`!bLk99u`nWaw(-_q8iZ;s;6{VkL^Vl6qq`6'q{h
 /AM&IU4cGo,U!l{@V7fp.3nrk.%5hLaD(i%uQxV1*)xZ^CRV)l4%m2;A"T!j=\rqqdCH3<I}V}
From: kwood@angels (Ken Wood)
To: epoch@cs.uiuc.edu
Subject: Epoch highlighting packages: tek-epoch-stuff1.0.0 part 3 of 4
Date: Fri, 18 Oct 91 18:54:12 CST
Organization: Austek Microsystems, Pty Ltd.


#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	tek-man.el
#	tek-style-utils.el
#	syntax-decode.el
# This archive created: Fri Oct 18 18:36:16 1991
export PATH; PATH=/bin:$PATH
echo shar: extracting "'tek-man.el'" '(28005 characters)'
if test -f 'tek-man.el'
then
	echo shar: will not over-write existing file "'tek-man.el'"
else
sed 's/^	X//' << \SHAR_EOF > 'tek-man.el'
	X;*****************************************************************************
	X;
	X; Filename:	tek-man.el
	X;
	X; This file is not part of the GNU Emacs distribution (yet).
	X;
	X; Copyright (C) 1991 Free Software Foundation, Inc.
	X;
	X; GNU Emacs is free software; you can redistribute it and/or modify
	X; it under the terms of the GNU General Public License as published by
	X; the Free Software Foundation; either version 1, or (at your option)
	X; any later version.
	X
	X; GNU Emacs is distributed in the hope that it will be useful,
	X; but WITHOUT ANY WARRANTY; without even the implied warranty of
	X; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	X; GNU General Public License for more details.
	X
	X; You should have received a copy of the GNU General Public License
	X; along with GNU Emacs; see the file COPYING.  If not, write to
	X; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
	X;
	X; Author:		Originally based on code by Eric Rose
	X;			<erose@jessica.stanford.edu>, who started with the
	X;			standard distribution and modified it.
	X;
	X; This version by:	Ken Wood, <kwood@austek.oz.au>
	X; Organisation:		Austek Microsystems Pty Ltd, Australia.
	X;
	X; Description:	Enhanced manual browser. Invoke with "M-x man".
	X;
	X;	Numerous changes from the distribution version:
	X;
	X;	- runs "man" in background mode, so you can keep editing while your
	X;	man page is prepared.
	X;
	X;	- renames man page buffers using the manual topic, thus supports
	X;	multiple man pages open at once.
	X;
	X;	- man buffers have their own major mode with special keybindings.
	X;	Type ? in a man buffer for details.
	X;
	X;	- provides highlighting and mouse support under epoch. Type ? for a
	X;	list of the mouse bindings.
	X;
	X;	Still needs: support for "man -k".
	X;
	X;*****************************************************************************
	X
	X; $Id: tek-man.el,v 1.5 1991/10/16 08:08:54 kwood Exp $
	X
	X(require 'epoch-running)
	X(provide 'tek-man)
	X(provide 'manual)
	X
	X(defconst manual-delete-reformatting-message t
	X  "*t says delete the \"Reformatting entry.  Wait...\" junk at the
	Xbeginning of the manual-entry buffer.")
	X
	X; Manual Variables
	X
	X(defvar manual-non-entry-regexp "[^A-Za-z0-9()_]"
	X  "\
	XRegexp matching characters that are not part of a manual entry names
	Xsuch as 'emacs(1)'.")
	X
	X(defvar manual-entry-name-regexp "[a-zA-Z][a-zA-Z0-9._-]+\([0-9A-Z]+\)"
	X  "\
	XRegexp which matches manual entry names, such as 'emacs(1)'.")
	X
	X(defvar manual-help-buffer-name "*Help*"
	X  "Name of help buffer for manual-mode.")
	X
	X
	X; Put all the epoch stuff inside a test, in order to get it to compile under
	X; emacs.
	X(if running-epoch
	X    (progn
	X
	X      (require 'tek-style-utils)
	X      
	X      ;
	X      ; Following section sets up some attributes for highlighting.
	X      ;
	X      
	X      (defvar tek-manual-seealso-foreground "purple"
	X	"\
	XForeground color used to highlight the 'See Also' section of manual
	Xpages if no value is defined in the X11 resources and the display
	Xdevice supports color.")
	X
	X      (defvar tek-manual-seealso-attribute (reserve-attribute)
	X	"Attribute used for displaying 'See Also' sections in man pages.")
	X
	X      (defvar tek-manual-seealso-style
	X	; If the display supports multiple colors and a default color
	X	; is specified, define the style to use a different color.
	X	(if (and (> (number-of-colors) 2) tek-manual-seealso-foreground)
	X	    (tek-build-style "manual-seealso" nil nil
	X			     tek-manual-seealso-foreground (background)
	X			     (background) (foreground))
	X	  ; Otherwise, define the style to use a different font.
	X	  (tek-build-style "manual-seealso" nil (or tek-bold-fixed-font
	X						    tek-italic-bold-fixed-font
	X						    tek-italic-fixed-font)
	X			   (foreground) (background)
	X			   (background) (foreground)))
	X	"Style used to display characters in See Also section of man pages.")
	X      
	X      ; Bind the see also style to the see also attribute.
	X      (set-attribute-style tek-manual-seealso-attribute
	X			   tek-manual-seealso-style)
	X      
	X      (defvar tek-manual-usersupplied-foreground "red3"
	X	"\
	XForeground color used to highlight the user-supplied sections of
	Xmanual pages if no value is defined in the X11 resources and the
	Xdisplay device supports color.")
	X      
	X      (defvar tek-manual-usersupplied-attribute (reserve-attribute)
	X	"Attribute used for displaying user-supplied sections in man pages.")
	X      
	X      (defvar tek-manual-usersupplied-style
	X	; If the display supports multiple colors and a default color
	X	; is specified, define the style to use a different color.
	X	(if (and (> (number-of-colors) 2) tek-manual-seealso-foreground)
	X	    (if tek-italic-fixed-font
	X		; Define the style to use a non-bold italic font in a different
	X		; color.
	X		(tek-build-style "manual-usersupplied" nil
	X				 tek-italic-fixed-font
	X				 tek-manual-usersupplied-foreground
	X				 (background) (background) (foreground))
	X	      (tek-build-style "manual-usersupplied" nil nil
	X			       tek-manual-usersupplied-foreground
	X			       (background) (background) (foreground)
	X			       tek-manual-usersupplied-foreground))
	X	  (if tek-italic-bold-fixed-font
	X	      (tek-build-style "manual-usersupplied" nil
	X			       tek-italic-bold-fixed-font
	X			       (foreground) (background)
	X			       (background) (foreground))
	X	    (tek-build-style "manual-usersupplied" nil
	X			     (or tek-bold-fixed-font
	X				 tek-italic-fixed-font)
	X			     (foreground) (background)
	X			     (background) (foreground) (foreground))))
	X	  "\
	XStyle used to display characters in user supplied sections of man pages.")
	X	
	X      ; Bind the user supplied style to the user supplied attribute.
	X      (set-attribute-style tek-manual-usersupplied-attribute
	X			   tek-manual-usersupplied-style)
	X      
	X      (defvar tek-manual-heading-attribute (reserve-attribute)
	X	"Attribute used for displaying heading sections in man pages.")
	X
	X      (defvar tek-manual-heading-style
	X	  ; Define the style to use a different font.
	X	(tek-build-style "manual-heading" nil (or tek-bold-fixed-font
	X						  tek-italic-bold-fixed-font
	X						  tek-italic-fixed-font)
	X			 (foreground) (background)
	X			 (background) (foreground))
	X	"\
	XStyle used to display characters in heading sections of man pages.")
	X
	X      ; Bind the heading style to the heading attribute.
	X      (set-attribute-style tek-manual-heading-attribute
	X			   tek-manual-heading-style)
	X      
	X
	X      ; Function to highlight SEE ALSO entries.
	X      (defun manual-highlight-seealso ()
	X	"Highlight all 'SEE ALSO' entries of man pages under epoch"
	X	(save-excursion
	X	  (goto-char (point-min))
	X	  (let ((case-fold-search nil)
	X		(seealso-endpoint (point-max)))
	X	    ; Find each SEE ALSO section
	X	    (while (re-search-forward "^\\s-*SEE ALSO.*\n" nil t)
	X	      ; Assume the SEE ALSO section is terminated by one or more
	X	      ; blank lines - find the end of the section.
	X	      (save-excursion
	X		(if (re-search-forward "\n\n" (point-max) t)
	X		    (setq seealso-endpoint (match-end 0))))
	X	      ; Find & highlight each entry in the SEE ALSO section.
	X	      (while (re-search-forward manual-entry-name-regexp
	X					seealso-endpoint t)
	X		(add-button (match-beginning 0) (match-end 0)
	X			    tek-manual-seealso-attribute nil
	X			    (current-buffer)))))))
	X
	X
	X      ; Mouse map to be used in manual buffers.
	X      (defvar manual-mouse-map (create-mouse-map mouse::global-map)
	X	"Mousemap for manual buffers.")
	X
	X      ; Bind the mouse buttons to useful functions.
	X      
	X      (define-mouse manual-mouse-map mouse-left mouse-down
	X	'manual-mouse-scroll-up)
	X      (define-mouse manual-mouse-map mouse-middle mouse-down
	X	'manual-mouse-select-item)
	X      (define-mouse manual-mouse-map mouse-right mouse-down
	X	'manual-mouse-scroll-down)
	X
	X      ; Functions for mouse bindings.
	X      
	X      (defun manual-mouse-select-item (mouse-data)
	X	"Select the manual entry specified at the mouse cursor."
	X	(let ((orig-window (selected-window)))
	X	  ;(select-window (nth 2 mouse-data))
	X	  (mouse::set-point mouse-data)
	X	  (manual-find-entry-at-point)
	X	  (select-window orig-window)))
	X      
	X      (defun manual-mouse-scroll-up (mouse-data)
	X	(let ((orig-window (selected-window)))
	X	  (select-window (nth 2 mouse-data))
	X	  (scroll-up nil)
	X	  (select-window orig-window)))
	X
	X      (defun manual-mouse-scroll-down (mouse-data)
	X	(let ((orig-window (selected-window)))
	X	  (select-window (nth 2 mouse-data))
	X	  (scroll-down nil)
	X	  (select-window orig-window)))
	X
	X
	X      )) ; end: running-epoch test
	X
	X
	X; Manual doco
	X
	X(defun manual-mode-summary ()
	X  "Display a brief summary of all manual mode commands"
	X  (interactive)
	X  (save-window-excursion
	X    ; Jump into the help buffer and prepare it for display
	X    (switch-to-buffer manual-help-buffer-name)
	X    (erase-buffer)
	X    (insert (documentation 'manual-mode))
	X    (goto-char (point-min))
	X    ; Now, wait until the user has scrolled to the end of the help screen
	X    ; and then pressed space once more.
	X    (let (ch flag)
	X      (while (progn (setq flag (not (pos-visible-in-window-p (point-max))))
	X		    (message (if flag "Type Space to see more"
	X			       "Type Space to return to manual"))
	X		    (if (/= ?\  (setq ch (read-char)))
	X			(progn (setq unread-command-char ch) nil)
	X		      flag))
	X	(scroll-up)))
	X    ; Bury the buffer so the user is unlikely to see it outside of
	X    ; manual mode.
	X    (bury-buffer manual-help-buffer-name)))
	X
	X;
	X;  Manual keymap
	X;
	X(defvar manual-mode-map (make-keymap)
	X  "Keymap used in manual page buffers.")
	X
	X(suppress-keymap manual-mode-map)
	X(define-key manual-mode-map " " 'scroll-up)
	X(define-key manual-mode-map "\177" 'scroll-down)
	X(define-key manual-mode-map "n" 'manual-forward-line)
	X(define-key manual-mode-map "p" 'manual-backward-line)
	X(define-key manual-mode-map "\en" 'manual-next-section)
	X(define-key manual-mode-map "\ep" 'manual-previous-section)
	X(define-key manual-mode-map "\C-n" 'manual-forward-line)
	X(define-key manual-mode-map "\C-p" 'manual-backward-line)
	X(define-key manual-mode-map "m" 'man)
	X(define-key manual-mode-map "a" 'manual-apropos)
	X(define-key manual-mode-map "g" 'manual-find-entry-at-point)
	X(define-key manual-mode-map "s" 'manual-see-also)
	X(define-key manual-mode-map "\C-a" 'beginning-of-line)
	X(define-key manual-mode-map "\C-e" 'end-of-line)
	X(define-key manual-mode-map "\ea" 'backward-sentence)
	X(define-key manual-mode-map "\ee" 'forward-sentence)
	X(define-key manual-mode-map "\C-b" 'backward-char)
	X(define-key manual-mode-map "\C-f" 'forward-char)
	X(define-key manual-mode-map "b" 'manual-backward-word)
	X(define-key manual-mode-map "f" 'manual-forward-word)
	X(define-key manual-mode-map "\eb" 'backward-word)
	X(define-key manual-mode-map "\ef" 'forward-word)
	X(define-key manual-mode-map "<" 'beginning-of-buffer)
	X(define-key manual-mode-map "." 'beginning-of-buffer)
	X(define-key manual-mode-map ">" 'end-of-buffer)
	X(define-key manual-mode-map "\e<" 'beginning-of-buffer)
	X(define-key manual-mode-map "\e>" 'end-of-buffer)
	X(define-key manual-mode-map "?" 'manual-mode-summary)
	X(define-key manual-mode-map "t" 'toggle-truncate-lines)
	X(define-key manual-mode-map "q" 'manual-quit)
	X
	X
	X; Stub for typing "man"
	X(defun man (word)
	X  (interactive "sTopic: ")
	X  (manual-get-entry word))
	X
	X; Create an alias for the man function to maintain backward compatibility.
	X(fset 'manual-entry (symbol-function 'man))
	X
	X
	X; Tries to find the man page for the entry near point.
	X(defun manual-find-entry-at-point ()
	X  (interactive)
	X  (let ((lookup-entry (manual-find-entry-name)))
	X    (if lookup-entry
	X	(manual-get-entry lookup-entry))))
	X
	X; Find another manual entry, either from the text at point or by prompting
	X; the user
	X(defun manual-find-new-entry ()
	X  (interactive)
	X  (let ((lookup-entry (manual-find-entry-name)))
	X    (if lookup-entry
	X	(manual-get-entry lookup-entry)
	X      (call-interactively 'man))))
	X
	X
	X; Manual mode
	X(defun manual-mode ()
	X  "\
	XManual Mode is used to browse through manual pages.  Normal editing
	Xcommands are turned off, and these can be used instead:
	X
	X.	Move to the top of the current man page.
	XSPC	Scroll down one page.
	XDEL	Scroll up one page.
	Xn,C-n	Move down one line.
	Xp,C-p	Move up one line.
	XM-n	Move to next section of the current page.
	XM-p	Move to previous section of the current page.
	X>	Move to end of man page.
	X<	Move to beginning of man page.
	Xm	Prompt for and look up a manual entry. Format is TOPIC(SECTION)
	X	or TOPIC.
	Xg       Gets the man page on the topic entered at the prompt.  Same format
	X	as above: TOPIC(SECTION).
	Xs	Jump to the 'SEE ALSO' section.
	XC-a	Beginning of line.
	XC-e	End of line.
	XM-a	Previous sentence.
	XM-e	Next sentence.
	Xf,M-f	Move forward one word.
	Xb,M-b   Move backwards one word.
	Xt       Toggle the line truncation.
	Xmouse-left     scroll-up
	Xmouse-middle   man-select-button
	Xmouse-right    scroll-down
	X?	This help screen.
	Xq	Quit."
	X  (interactive)
	X  (setq major-mode 'manual-mode)
	X  (setq mode-name "Manual")
	X  (setq buffer-auto-save-file-name nil)
	X  (setq truncate-lines t)
	X  ; Use the appropriate local key & mouse bindings in this buffer.
	X  (use-local-map manual-mode-map)
	X  (if running-epoch
	X      (use-local-mouse-map manual-mouse-map))
	X  (message "Type ? for a list of commands"))
	X
	X
	X; Does the work
	X(defun manual-get-entry (entry)
	X  "Display the Unix manual entry for ENTRY.
	XENTRY is either the title of the entry, or has the form TITLE(SECTION)
	Xwhere SECTION is the desired section of the manual, as in `tty(4)'."
	X  (string-match "\\`[ \t]*\\([^( \t]+\\)[ \t]*\\((.+)\\)?[ \t]*\\'" entry)
	X  ; Calculate the section and topic from the arg.
	X  (let* (
	X	 (manual-topic (if (match-beginning 1)
	X			   (substring entry
	X				      (match-beginning 1) (match-end 1))))
	X	 (temp-match-string (if (match-beginning 2)
	X				(substring entry
	X					   (match-beginning 2) (match-end 2))))
	X	 (manual-section (if temp-match-string
	X			     (and (string-match "(\\(.+\\))"
	X						temp-match-string)
	X				  (substring temp-match-string
	X					     (match-beginning 1)
	X					     (match-end 1)))))
	X	)
	X    ; First, must be sure we have a valid topic to look up.
	X    (if (not manual-topic)
	X	; Do nothing
	X	nil
	X      (let* ((manual-buffer-name (concat "*Manual-" manual-topic "*"))
	X	     (manual-buffer (get-buffer manual-buffer-name)))
	X	(if manual-buffer
	X	    ; Buffer for specified manual entry already exists - just
	X	    ; need to display it.
	X	    (display-buffer manual-buffer)
	X	  ; Otherwise, need to look it up
	X	  (progn
	X	    ; First, create the buffer
	X	    (setq manual-buffer (get-buffer-create manual-buffer-name))
	X	    ; Do all following edits in manual buffer
	X	    (set-buffer manual-buffer)
	X	    ; Turn off undo log.
	X	    (buffer-flush-undo manual-buffer)
	X	    ; Let the user know what we're up to
	X	    (message "Looking for formatted entry for %s%s..."
	X		     manual-topic
	X		     (if manual-section (concat "(" manual-section ")") ""))
	X	    ; Next section inserts the raw "man" output into the
	X	    ; buffer. First, look for an already formatted file.
	X	    (let ((dirlist manual-formatted-dirlist)
	X		  (currentdir nil)
	X		  (completions nil)
	X		  (case-fold-search nil)
	X		  (return-value nil)
	X		  formatted-name)
	X	      ; Try the dir-prefix to start with
	X	      (setq return-value
	X		    (and manual-section
	X			 ; First, with the section appended to the
	X			 ; formatted directory.
	X			 (or (file-exists-p
	X			      (setq formatted-name
	X				    (concat manual-formatted-dir-prefix
	X					    (substring manual-section 0 1)
	X					    "/" manual-topic "."
	X					    manual-section)))
	X			     ; Next, without the section appended
	X			     (file-exists-p
	X			      (setq formatted-name
	X				    (concat manual-formatted-dir-prefix
	X					    manual-section "/"
	X					    manual-topic "."
	X					    manual-section))))))
	X	      ; If that fails, then try looking through the formatted
	X	      ; dirlist for the file of interest.
	X	      (while (and (not return-value) dirlist)
	X		(progn
	X		  ; Try the current formatted directory, with a good
	X		  ; guess at the formatted file name.
	X		  (setq currentdir (car dirlist))
	X		  (setq formatted-name
	X			(concat currentdir "/" manual-topic "."
	X				(or manual-section
	X				    (substring currentdir
	X					       (1+ (or (string-match
	X							"\\.[^./]*$"
	X							currentdir)
	X						       -2))))))
	X		  (setq return-value (file-exists-p formatted-name))
	X		  (setq dirlist (cdr dirlist))))
	X	      ; Otherwise, try looking for the completions in each
	X	      ; formatted directory.
	X	      (setq dirlist manual-formatted-dirlist)
	X	      (while (and (not return-value) dirlist)
	X		(progn
	X		  (setq currentdir (car dirlist))
	X		  ; Set up an error handler for file-name-all-completions
	X		  (condition-case ()
	X		      (progn
	X			; Get the list of completions
	X			(setq completions (file-name-all-completions
	X					   (concat manual-topic "."
	X						   (or manual-section ""))
	X					   currentdir))
	X			; Loop through the completions until we find a file
	X			; that exists.
	X			(while (and completions
	X				    (setq formatted-name
	X					  (concat currentdir "/"
	X						  (car completions)))
	X				    (not (setq return-value
	X					       (file-exists-p
	X						formatted-name))))
	X			  (setq completions (cdr completions))))
	X		    ; Error handler quietly does nothing.
	X		    (file-error nil))
	X		  (setq dirlist (cdr dirlist))))
	X	      ; Now, check that we can read the formatted file. If not,
	X	      ; need to delete it and run man anyway.
	X	      (if (and return-value
	X		       (not (file-readable-p formatted-name)))
	X		  (progn
	X		    (delete-file formatted-name)
	X		    (setq return-value nil)))
	X	      ; If the formatted file exists and is readable, then insert it.
	X	      (if return-value
	X		  (progn
	X		    (manual-insert-file formatted-name)
	X		    (manual-clean-and-show-buffer manual-topic))
	X		; Else, invoke man
	X		(let ((manual-process nil))
	X		  (message "No formatted entry, invoking man %s%s in background..."
	X			   (if manual-section
	X			       (concat manual-section " ")
	X			     "")
	X			   manual-topic)
	X		  (if manual-section
	X		      (setq manual-process
	X			    (start-process (concat "manbg-" manual-topic
	X						   manual-section)
	X					   manual-buffer
	X					   "sh" "-c"
	X					   (format "%s - %s %s"
	X						   manual-program
	X						   manual-section
	X						   manual-topic)))
	X		    (setq manual-process
	X			  (start-process (concat "manbg-" manual-topic)
	X					 manual-buffer
	X					 "sh" "-c"
	X					 (format "%s - %s"
	X						 manual-program
	X						 manual-topic))))
	X		  ; Set up a sentinel to watch for "man" exiting.
	X		  (set-process-sentinel manual-process 'manual-sentinel)
	X		  ; Bury the buffer to try & prevent the user
	X		  ; stumbling across it.
	X		  (bury-buffer manual-buffer))
	X		))))))))
	X
	X	
	X(defun manual-sentinel (process msg)
	X  "\
	XWaits for the asynchronous man process to exit & cleans up the
	Xresulting output."
	X  (let* ((manual-buffer (process-buffer process))
	X	 (manual-buffer-name  (buffer-name manual-buffer))
	X	 (delete-buff nil)
	X	 (err-mess nil)
	X	 (initial-match-data (match-data)))
	X    (if (null manual-buffer)
	X	; man output buffer has been deleted - flag an error and set the
	X	; processes buffer to nil
	X	(progn
	X	  (error "Manual output buffer deleted")
	X	  (set-process-buffer process nil))
	X      (progn
	X	(set-buffer manual-buffer)
	X	(goto-char (point-min))
	X	(cond
	X	 ; Check to see if the man page wasn't found.
	X	 ((or (looking-at "No \\(manual \\)*entry for")
	X	      (looking-at "[^\n]*: nothing appropriate$"))
	X	  ; Print an error message and delete the buffer.
	X	  (setq err-mess
	X		(buffer-substring (point) (progn (end-of-line) (point))))
	X	  (setq delete-buff t))
	X	 ; Check to see if the process haven't exited yet, or exited with
	X	 ; a non-zero exit status.
	X	 ((not (and (eq (process-status process) 'exit)
	X		    (= (process-exit-status process) 0)))
	X	  ; Flag an error
	X	  (setq err-mess (format "%s: process %s" manual-buffer-name
	X				 (manual-delete-trailing-newline msg)))
	X	  ; An insert some debug info into the buffer.
	X	  (goto-char (point-max))
	X	  (insert (format "\nprocess %s" msg)))
	X	 ; Otherwise, must have exited normally - just delete the reformatting
	X	 ; message if appropriate
	X	 (t (and manual-delete-reformatting-message
	X		 (looking-at "Reformatting ")
	X		 (delete-region (point)
	X				(progn (forward-line 1) (point))))))
	X	; Remove the buffer if appropriate
	X	(if delete-buff
	X	    (kill-buffer manual-buffer)
	X	  ; Otherwise, clean it up & display it.
	X	  (let ((manual-topic nil))
	X	    (if (string-match "\\*Manual-\\(.+\\)\\*" manual-buffer-name)
	X		(setq manual-topic
	X		      (substring manual-buffer-name
	X				 (match-beginning 1) (match-end 1)))
	X	      (setq manual-topic ""))
	X	    (manual-clean-and-show-buffer manual-topic)))
	X	; Print any accumulated message
	X	(if err-mess
	X	    (error err-mess)
	X	  (message ""))))
	X    ; Restore any previous match data on exit.
	X    (store-match-data initial-match-data)))
	X       
	X
	X
	X(defun manual-delete-trailing-newline (str)
	X  (if (string= (substring str (1- (length str))) "\n")
	X      (substring str 0 (1- (length str)))
	X    str))
	X
	X
	X
	X; Hint: BS stands for more things than "back space"
	X(defun manual-clean-and-show-buffer (manual-topic)
	X  "\
	XWorks on the current buffer. First turns underlining & overstriking by
	Xmeans of backspace characters into something sensible: highlighting if
	Xwe are running epoch, plain text otherwise.
	X
	XNext, remove cruddy headers & whitespace.
	X
	XFinally, set the buffer mode & display it."
	X  (message "Cleaning manual entry for %s..." manual-topic)
	X  (if buffer-read-only
	X      (toggle-read-only))
	X  (if running-epoch
	X      ;
	X      ; Do highlighting
	X      ;
	X      (progn
	X	;
	X	; First, change _ chars to be "underlined" - helps simplify
	X	; button placement algorithm later.
	X	;
	X	(goto-char (point-min))
	X	(replace-regexp "\\(_\b.\\)\\([_ -]\\)\\(_\b.\\)" "\\1_\b\\2\\3")
	X	;
	X	; First nuke overstriking by same character.
	X	;
	X	(goto-char (point-min))
	X	; Find the start of a section of overstriking - ignore
	X	; underlined underscores for now.
	X	(while (re-search-forward "\\([^_\n]\\)\\(\b\\1\\)+" nil t)
	X	  ; Kill backspace character & overstrike characters
	X	  (replace-match "\\1")
	X	  (let ((button-begin (1- (point)))
	X		(button-end (point))
	X		(bolded-char nil))
	X	    ; Search through the rest of the overstrike characters.
	X	    (while (and (= (char-after (1+ (point))) ?\b)
	X			(= (char-after (point)) (char-after (+ 2 (point)))))
	X	      (progn
	X		; Record the character which is being overstruck
	X		(setq bolded-char (char-after (point)))
	X		; Extend the button to include the new character
	X		(forward-char 1)
	X		(setq button-end (point))
	X		; Delete the first overstriking
	X		(delete-char 2)
	X		; Delete all the later overstrikings by the same character
	X		(while (= (char-after (point)) ?\b)
	X		  (delete-char 2))))
	X	    ; Add the button around the specified region
	X	    (add-button button-begin button-end
	X			tek-manual-heading-attribute nil)))
	X	;
	X	; Now, nuke underlining.
	X	;
	X	(goto-char (point-min))
	X	; Find the start of a section of underlining
	X	(while (search-forward "_\b" nil t)
	X	  (let ((button-begin nil)
	X		(button-end nil))
	X	    ; Kill underlining characters
	X	    (delete-char -2)
	X	    ; Start a button around just this one character.
	X	    (setq button-begin (point))
	X	    (setq button-end (1+ button-begin))
	X	    ; Remove the rest of the backspaces in this section & extend the
	X	    ; button to just after the last one.
	X	    (while (and (= (char-after (1+ (point))) ?_)
	X			(not (forward-char 3))
	X			(= (preceding-char) ?\b))
	X	      (progn
	X		(delete-char -2)
	X		(setq button-end (1+ (point)))))
	X	    ; Insert the button
	X	    (add-button button-begin button-end
	X			tek-manual-usersupplied-attribute nil)))
	X	; Finally, highlight any SEE ALSO sections
	X	(manual-highlight-seealso)
	X	))
	X  ; Now, purge any overstruck characters. If we're running epoch,
	X  ; most of them will already have been taken care of. Otherwise,
	X  ; nuke the lot of them.
	X  ;
	X  ; Underlining first
	X  (goto-char (point-min))
	X  (replace-regexp "_\b\\(.\\)" "\\1")
	X  ; Overstriking next
	X  (goto-char (point-min))
	X  (replace-regexp "\\(.\\)\\(\b\\1\\)+" "\\1")
	X  ; General overstriking last
	X  (replace-regexp ".\b\\(.\\)" "\\1")
	X  ;
	X  ; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
	X  (goto-char (point-min))
	X  (replace-regexp "^\\s-*\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Z]+)\\).*\\1$" "")
	X  ; Nuke headers: "MORE(1)"
	X  (goto-char (point-min))
	X  (replace-regexp "^\\s-*[A-Za-z][-_A-Za-z0-9]*([0-9A-Z]+)\\s-*$" "")
	X  ; Nuke footers: "Printed 12/3/85	27 April 1981	1"
	X  ;    Sun appear to be on drugz:
	X  ;     "Sun Release 3.0B  Last change: 1 February 1985     1"
	X  ;    HP are even worse!
	X  ;     "     Hewlett-Packard   -1- (printed 12/31/99)"  FMHWA12ID!!
	X  ;    System V (well WICATs anyway):
	X  ;     "Page 1			  (printed 7/24/85)"
	X  ;    Who is administering PCP to these corporate bozos?
	X  (goto-char (point-min))
	X  (replace-regexp
	X   (cond ((eq system-type 'hpux)
	X	  "^[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*$")
	X	 ((eq system-type 'usg-unix-v)
	X	  "^ *Page [0-9]*.*(printed [0-9/]*)$")
	X	 (t
	X	  "^\\(Printed\\|Sun Release\\) [0-9].*[0-9]$"))
	X   "")
	X  ; Crunch blank lines
	X  (goto-char (point-min))
	X  (replace-regexp "\n\n\n+" "\n\n")
	X  ; Kill first few blank lines in the buffer
	X  (goto-char (point-min))
	X  (if (re-search-forward "\\`\n+" nil t)
	X      (replace-match ""))
	X  ; Finally, make the buffer read only & unmodified.
	X  (toggle-read-only)
	X  (set-buffer-modified-p nil)
	X  ; Set the buffer mode & key bindings
	X  (manual-mode)
	X  ; Show the buffer in some window
	X  (display-buffer (current-buffer))
	X  )
	X
	X
	X(defun manual-insert-file (name)
	X  ; Insert manual file (unpacked as necessary) into buffer
	X  (if (equal (substring name -2) ".Z")
	X      (call-process "zcat" nil t nil name)
	X    (if (equal (substring name -2) ".z")
	X	(call-process "pcat" nil t nil name)
	X      (insert-file-contents name))))
	X
	X
	X; Added by erose
	X;
	X(defun manual-forward-line (n)
	X  (interactive "p")
	X  (forward-line n))
	X
	X(defun manual-backward-line (n)
	X  (interactive "p")
	X  (forward-line (- n)))
	X
	X(defun manual-forward-word (n)
	X  (interactive "p")
	X  (forward-char 1)
	X  (forward-word n)
	X  (forward-char -1))
	X
	X(defun manual-backward-word (n)
	X  (interactive "p")
	X  (backward-word n))
	X
	X;  Searches for next "Section"
	X(defun manual-next-section ()
	X  (interactive)
	X  (beginning-of-line)
	X  (forward-line)
	X  (while (not (or (looking-at "[A-Z]")
	X		  (eobp)))
	X    (forward-line 1)))
	X
	X(defun manual-previous-section ()
	X  (interactive)
	X  (beginning-of-line)
	X  (forward-line -1)
	X  (while (not (or (looking-at "[A-Z]")
	X		  (bobp)))
	X    (forward-line -1)))
	X
	X
	X; Finds a word near point that can be a manual reference.  Returns nil
	X; if it can't figure it out.
	X(defun manual-find-entry-name ()
	X  "\
	XReturns the word near point that should correspond to a manual
	Xreference. The variable 'manual-non-entry-regexp' controls what is not
	Xpart of a manual reference."
	X  (let ((entry-beginning-bound nil)
	X	(entry-end-bound nil)
	X	(entry-beginning nil)
	X	(entry-end nil))
	X    (save-excursion
	X      ; Now, do a bit of searching to see if there is really a manual entry
	X      ; near point.
	X      ; Don't really care if we are at the beginning or end of the buffer,
	X      ; just let these points limit the search.
	X      (if (and (if (re-search-forward manual-non-entry-regexp nil t)
	X		   (setq entry-end-bound (match-beginning 0))
	X		 (setq entry-end-bound (point-max)))
	X	       (or (backward-char 1) t)
	X	       (or (re-search-backward manual-non-entry-regexp nil t) t)
	X	       (re-search-forward manual-entry-name-regexp
	X				  entry-end-bound t))
	X	  ; If we made it to here, then we have found a manual entry -
	X	  ; so return it.
	X	  (buffer-substring (match-beginning 0) (match-end 0))
	X	; Otherwise, no entry name here so return nil.
	X	nil))))
	X
	X
	X(defun manual-see-also ()
	X  (interactive)
	X  (let ((opoint (point))
	X	(case-fold-search nil))
	X    (goto-char (point-min))
	X    (if (not (re-search-forward "^\\s-*SEE ALSO" nil t))
	X	(progn
	X	  (goto-char opoint)
	X	  (message "No 'SEE ALSO' section on this manpage.")))))
	X	
	X(defun toggle-truncate-lines ()
	X  (interactive)
	X  (setq truncate-lines (not truncate-lines))
	X  (recenter))
	X
	X(defvar manual-keep-all-buffers nil
	X  "If t keep the manual buffer even though the user has typed q")
	X
	X(defun manual-quit ()
	X  (interactive)
	X  (if manual-keep-all-buffers
	X      (bury-buffer (current-buffer))
	X    (kill-buffer (current-buffer))))
	X
	X(defun manual-apropos ()
	X  "\
	XNot yet implemented.
	X
	Xman -k %s | pr -h Apropos")
SHAR_EOF
if test 28005 -ne "`wc -c < 'tek-man.el'`"
then
	echo shar: error transmitting "'tek-man.el'" '(should have been 28005 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'tek-style-utils.el'" '(18204 characters)'
if test -f 'tek-style-utils.el'
then
	echo shar: will not over-write existing file "'tek-style-utils.el'"
else
sed 's/^	X//' << \SHAR_EOF > 'tek-style-utils.el'
	X;*****************************************************************************
	X;
	X; Filename:	tek-style-utils.el
	X;
	X; Copyright (C) 1991  Ken Wood
	X;
	X; This program is free software; you can redistribute it and/or modify
	X; it under the terms of the GNU General Public License as published by
	X; the Free Software Foundation; either version 1, or (at your option)
	X; any later version.
	X;
	X; This program is distributed in the hope that it will be useful,
	X; but WITHOUT ANY WARRANTY; without even the implied warranty of
	X; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	X; GNU General Public License for more details.
	X;
	X; You should have received a copy of the GNU General Public License
	X; along with this program; if not, write to the Free Software
	X; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	X;
	X; Author:		Ken Wood, <kwood@austek.oz.au>
	X; Organisation:		Austek Microsystems Pty Ltd, Australia.
	X; Released with permission from Austek Microsystems.
	X;
	X; Description:	Set up some default fonts for highlighting etc, and
	X;		define a function for building styles from default
	X;		option values and X11 resource defaults.
	X;
	X; When loaded, this package attempts to define 3 non-proportional fonts
	X; which match the default minibuffer font in with and height: a non-bold
	X; italic font, a bold italic font and a bold upright font.
	X; 
	X; A function for defining and modifying attribute styles based on X
	X; resources is also provided for use by the other packages. You may
	X; modify the these styles by setting X11 resources (usually in your
	X; .Xdefaults file). Up to 9 options may be specified for each style.
	X; Sensible defaults are used for any options that you do not specify.
	X; The options are represented by the following X11 resources:
	X; 
	X; 	Emacs.STYLE-NAME.style-font: Font.
	X; 
	X; 	Emacs.STYLE-NAME.style-foreground: Foreground color.
	X; 
	X; 	Emacs.STYLE-NAME.style-background: Background color.
	X; 
	X; 	Emacs.STYLE-NAME.style-cursor-foreground: Cursor foreground color.
	X; 
	X; 	Emacs.STYLE-NAME.style-cursor-background: Cursor background color.
	X; 
	X; 	Emacs.STYLE-NAME.style-underline: Underline color.
	X; 
	X; 	Emacs.STYLE-NAME.style-stipple: Stipple pattern.
	X; 
	X; 	Emacs.STYLE-NAME.style-cursor-stipple: Stipple pattern.
	X; 
	X; 	Emacs.STYLE-NAME.style-background-stipple: Stipple pattern.
	X; 
	X; The values of STYLE-NAME currently used are:
	X; 
	X; 	motion: Mouse drag regions.
	X; 
	X; 	src-comment: Comments in source code.
	X; 
	X; 	info: Info browser buttons.
	X; 
	X; 	VM-from: From: lines in VM.
	X; 
	X; 	VM-subject: Subject: lines in VM.
	X; 
	X; 	gnus-from: From: lines in GNUS.
	X; 
	X; 	gnus-subject: Subject: lines in GNUS.
	X; 
	X; 	manual-seealso: "See Also" sections in man pages.
	X; 
	X; 	manual-usersupplied: User supplied options in man pages.
	X; 
	X; 	manual-heading: Fixed options in man pages. These may be shown
	X; 	in the default font depending on your implementation of the
	X; 	"man" program.
	X; 
	X; The above X11 resources must be loaded before you start up epoch, in
	X; order for them to take effect.
	X;
	X; Note: the stipple options have not been tested and I don't really understand
	X; stipple patterns, so there may be some problems here.
	X; 
	X;*****************************************************************************
	X
	X; $Id: tek-style-utils.el,v 1.3 1991/10/18 07:37:34 kwood Exp $
	X
	X(provide 'tek-style-utils)
	X
	X(defvar tek-default-font nil
	X  "\
	XDefault font used in the minibuffer. This font is the basis for a
	Xnumber of special fonts used for highlighting in various places.")
	X
	X(defvar tek-italic-fixed-font nil
	X  "\
	XA non-bold italic or oblique fixed-width font, as similar as possible
	Xto the default minibuffer font, or nil if there are no such fonts.")
	X
	X(defvar tek-italic-bold-fixed-font nil
	X  "\
	XA bold italic or oblique fixed-width font, as similar as possible to
	Xthe default minibuffer font, or nil if there is no such font.")
	X
	X(defvar tek-bold-fixed-font nil
	X  "\
	XA bold roman (upright) fixed-width font, as similar as possible to the
	Xdefault minibuffer font, or nil if there is no such font.")
	X
	X;
	X; Now, search for & load some commonly needed fonts.
	X;
	X(let (
	X      ; Variables to hold default font information
	X      default-font-info
	X      default-font-name
	X      default-font-height
	X      default-font-width
	X      ; String specifying the required font width.
	X      font-width
	X      ;
	X      ; Variables to hold the possible values of style attributes to try
	X      ;
	X      height-try-list
	X      ; List of font weights to try for bold fonts.
	X      (bold-weight-try-list (list "-bold" "-demibold"))
	X      ; List of slant options to try for italic fonts.
	X      (slant-try-list (list "-i" "-o"))
	X      ; List of spacing options to try.
	X      (spacing-try-list (list "-m" "-c"))
	X      )
	X  ; Get details of current default font for the minibuffer
	X  (setq default-font-info (font nil (minibuf-screen)))
	X  (setq default-font-name (car default-font-info))
	X  (setq default-font-width (cadr default-font-info))
	X  (setq default-font-height (cadr (cdr default-font-info)))
	X  ; Convert the font-width to a string, since it will be used
	X  ; directly. Width must be multiplied by 10 first.
	X  (setq font-width
	X	(concat "-" (int-to-string (* default-font-width 10))))
	X  ; Generate a list of font height strings to try for fixed-width fonts
	X  ; from the default font height.
	X  (setq height-try-list
	X	(list (concat "-" (int-to-string default-font-height))
	X	      (concat "-" (int-to-string (1+ default-font-height)))
	X	      (concat "-" (int-to-string (1- default-font-height)))))
	X  ;
	X  ; First of all, record the default font.
	X  (setq tek-default-font default-font-name)
	X  ;
	X  ;
	X  ; Now, try to find an italic font similar to the minibuffer font.
	X  ; From most preferred to least preferred, we'd like the
	X  ; following options:
	X  ;	1) monospaced (m), then character spacing (c).
	X  ; 	2) italic (i), then oblique (o).
	X  ;	3) same height, then 1 pixel taller, then 1 pixel shorter.
	X  (setq tek-italic-fixed-font
	X	(let (
	X	      ; Variable to hold the font name currently being tried
	X	      font-try-name
	X	      ; Font finally selected, nil if none
	X	      (font-try-val nil)
	X	      ; Loop variables
	X	      (current-height-list height-try-list)
	X	      current-slant-list
	X	      current-spacing-list
	X	      )
	X	  ; Loop through the height options
	X	  (while (and (not font-try-val) current-height-list)
	X	    ; Set up the list of slant options
	X	    (setq current-slant-list slant-try-list)
	X	    ; Loop through the slant options
	X	    (while (and (not font-try-val) current-slant-list)
	X	      ; Set up the list of spacing options
	X	      (setq current-spacing-list spacing-try-list)
	X	      ; Loop through the spacing options
	X	      (while (and (not font-try-val) current-spacing-list)
	X		(setq font-try-name
	X		      (concat "-*-*-medium"
	X			      (car current-slant-list)
	X			      "-*-*"
	X			      (car current-height-list)
	X			      "-*-*-*"
	X			      (car current-spacing-list)
	X			      font-width
	X			      "-*-*"))
	X		(setq font-try-val (get-font font-try-name))
	X		; Remove the first element from the spacing list
	X		(setq current-spacing-list (cdr current-spacing-list))
	X		) ; end spacing loop
	X	      ; Remove the first element from the slant list
	X	      (setq current-slant-list (cdr current-slant-list))
	X	      ) ; end slant loop
	X	    ; Remove the first element from the height list
	X	    (setq current-height-list (cdr current-height-list))
	X	    ) ; end height try list
	X	  ; Check to see if we found a suitable font and return it or nil.
	X	  (if font-try-val
	X	      font-try-name
	X	    nil)))
	X  ;
	X  ; Now, try to find a bold italic font similar to the minibuffer font.
	X  ; From most preferred to least preferred, we'd like the following
	X  ; options:
	X  ;	1) monospaced (m), then character spacing (c).
	X  ;	2) italic (i), then oblique (o).
	X  ;	3) bold, then demibold.
	X  ;	4) same height, then 1 pixel taller, then 1 pixel shorter.
	X  (setq tek-italic-bold-fixed-font
	X	(let (
	X	      ; Variable to hold the font name currently being tried
	X	      font-try-name
	X	      ; Font finally selected, nil if none
	X	      (font-try-val nil)
	X	      ; Loop variables
	X	      (current-height-list height-try-list)
	X	      current-weight-list
	X	      current-slant-list
	X	      current-spacing-list
	X	      )
	X	  ; Loop through the height options
	X	  (while (and (not font-try-val) current-height-list)
	X	    ; Set up the list of weight options
	X	    (setq current-weight-list bold-weight-try-list)
	X	    ; Loop through the weight options
	X	    (while (and (not font-try-val) current-weight-list)
	X	      ; Set up the list of slant options
	X	      (setq current-slant-list slant-try-list)
	X	      ; Loop through the slant options
	X	      (while (and (not font-try-val) current-slant-list)
	X		; Set up the list of spacing options
	X		(setq current-spacing-list spacing-try-list)
	X		; Loop through the spacing options
	X		(while (and (not font-try-val) current-spacing-list)
	X		  (setq font-try-name
	X			(concat "-*-*"
	X				(car current-weight-list)
	X				(car current-slant-list)
	X				"-*-*"
	X				(car current-height-list)
	X				"-*-*-*"
	X				(car current-spacing-list)
	X				font-width
	X				"-*-*"))
	X		  (setq font-try-val (get-font font-try-name))
	X		  ; Remove the first element from the spacing list
	X		  (setq current-spacing-list (cdr current-spacing-list))
	X		  ) ; end spacing loop
	X		(setq font-try-val (get-font font-try-name))
	X		; Remove the first element from the slant list
	X		(setq current-slant-list (cdr current-slant-list))
	X		) ; end slant loop
	X	      ; Remove the first element from the weight list
	X	      (setq current-weight-list (cdr current-weight-list))
	X	      ) ; end weight loop
	X	    ; Remove the first element from the height list
	X	    (setq current-height-list (cdr current-height-list))
	X	    ) ; end height try list
	X	  ; Check to see if we found a suitable font and return it or nil.
	X	  (if font-try-val
	X	      font-try-name
	X	    nil)))
	X  ; Now, try to find a bold fixed font similar to the minibuffer font.
	X  ; From most preferred to least preferred, we'd like the following
	X  ; options:
	X  ;	1) monospaced (m), then character spacing (c).
	X  ;	2) bold, then demibold.
	X  ;	3) same height, then 1 pixel taller, then 1 pixel shorter.
	X  (setq tek-bold-fixed-font
	X	(let (
	X	      ; Variable to hold the font name currently being tried
	X	      font-try-name
	X	      ; Font finally selected, nil if none
	X	      (font-try-val nil)
	X	      ; Loop variables
	X	      (current-height-list height-try-list)
	X	      current-weight-list
	X	      current-spacing-list
	X	      )
	X	  ; First of all, just try appending "bold" to the current font
	X	  ; name. This will work with some aliases, such as "6x13".
	X	  (setq font-try-name (concat default-font-name "bold"))
	X	  (setq font-try-val (get-font font-try-name))
	X	  ; If the above fails, loop through the normal options as usual.
	X	  ; Loop through the height options
	X	  (while (and (not font-try-val) current-height-list)
	X	    ; Set up the list of weight options
	X	    (setq current-weight-list bold-weight-try-list)
	X	    ; Loop through the weight options
	X	    (while (and (not font-try-val) current-weight-list)
	X	      ; Set up the list of spacing options
	X	      (setq current-spacing-list spacing-try-list)
	X	      ; Loop through the spacing options
	X	      (while (and (not font-try-val) current-spacing-list)
	X		(setq font-try-name
	X		      (concat "-*-*"
	X			      (car current-weight-list)
	X			      "-r-*-*"
	X			      (car current-height-list)
	X			      "-*-*-*"
	X			      (car current-spacing-list)
	X			      font-width
	X			      "-*-*"))
	X		(setq font-try-val (get-font font-try-name))
	X		; Remove the first element from the spacing list
	X		(setq current-spacing-list (cdr current-spacing-list))
	X		) ; end spacing loop
	X	      ; Remove the first element from the weight list
	X	      (setq current-weight-list (cdr current-weight-list))
	X	      ) ; end weight loop
	X	    ; Remove the first element from the height list
	X	    (setq current-height-list (cdr current-height-list))
	X	    ) ; end height try list
	X	  ; Check to see if we found a suitable font and return it or nil.
	X	  (if font-try-val
	X	      font-try-name
	X	    nil)))
	X  )
	X
	X
	X; Define the prefix to be use when looking for X resources
	X(defvar tek-resource-prefix "Emacs"
	X  "\
	XString to be prepended to resource names prior to looking up their
	Xvalue.")
	X
	X
	X; Define a function to initialise a style
	X(defun tek-build-style (style-name
	X			&optional package-style
	X			&optional default-style-font
	X			&optional default-style-foreground
	X			&optional default-style-background
	X			&optional default-style-cursor-foreground
	X			&optional default-style-cursor-background
	X			&optional default-style-underline
	X			&optional default-style-stipple
	X			&optional default-style-cursor-stipple
	X			&optional default-style-background-stipple)
	X  "\
	XReturn a style object, with values set as specified by the X11
	Xresources for STYLE-NAME, a string. If optional PACKAGE-STYLE is not
	Xgiven or nil, then create a new style.
	X
	XThere are 9 style fields which may be specified for the package: font,
	Xforeground, background, cursor-foreground, cursor-background,
	Xunderline, stipple, cursor-stipple and background-stipple. The value
	Xof `tek-resource-prefix' is prepended to the package name,
	Xbefore looking up the value of the resource. Thus, the possible
	Xresources that may be specified are:
	X
	XRESOURCE.STYLE-NAME.style-font
	XRESOURCE.STYLE-NAME.style-foreground
	XRESOURCE.STYLE-NAME.style-background
	XRESOURCE.STYLE-NAME.style-cursor-foreground
	XRESOURCE.STYLE-NAME.style-cursor-background
	XRESOURCE.STYLE-NAME.style-underline
	XRESOURCE.STYLE-NAME.style-stipple
	XRESOURCE.STYLE-NAME.style-cursor-stipple
	XRESOURCE.STYLE-NAME.style-background-stipple
	X
	XSee make-style and the style-* and set-style-* functions for details
	Xof style options.
	X
	XThis function also takes 9 optional arguments: FONT, FOREGROUND,
	XBACKGROUND, CURSOR-FOREGROUND, CURSOR-BACKGROUND, UNDERLINE, STIPPLE,
	XCURSOR-STIPPLE and BACKGROUND-STIPPLE. These are the default values to
	Xuse no X11 resources for the package are defined. If any X11 resources
	Xare not defined, the default value will be used to specify that style
	Xoption.
	X
	XIf any style option is not specified by either X11 resource and the
	Xcorresponding default value is not specified or is nil, then that
	Xstyle field will not be set."
	X  (let (
	X	; Use a local variable for the package style.
	X	(new-package-style package-style)
	X	; Names of the specified X11 resources.
	X	(font-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-font"))
	X	(foreground-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-foreground"))
	X	(background-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-background"))
	X	(cursor-foreground-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-cursor-foreground"))
	X	(cursor-background-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-cursor-background"))
	X	(underline-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-underline"))
	X	(stipple-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-stipple"))
	X	(cursor-stipple-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-cursor-stipple"))
	X	(background-stipple-resource-name
	X	 (concat tek-resource-prefix "."
	X		 style-name ".style-backgound-stipple"))
	X	; Calculated style field values.
	X	(package-font nil)
	X	(package-foreground nil)
	X	(package-background nil)
	X	(package-cursor-foreground nil)
	X	(package-cursor-background nil)
	X	(package-underline nil)
	X	(package-stipple nil)
	X	(package-cursor-stipple nil)
	X	(package-background-stipple nil)
	X	)
	X    ; Attempt to find the required settings in the X11 resources.
	X    (setq package-font
	X	  (get-default font-resource-name))
	X    (setq package-foreground
	X	  (get-default foreground-resource-name))
	X    (setq package-background
	X	  (get-default background-resource-name))
	X    (setq package-cursor-foreground
	X	  (get-default cursor-foreground-resource-name))
	X    (setq package-cursor-background
	X	  (get-default cursor-background-resource-name))
	X    (setq package-underline
	X	  (get-default underline-resource-name))
	X    (setq package-stipple
	X	  (get-default stipple-resource-name))
	X    (setq package-cursor-stipple
	X	  (get-default cursor-stipple-resource-name))
	X    (setq package-background-stipple
	X	  (get-default background-stipple-resource-name))
	X    ; If any of the X11 resources were not defined, use the defaults.
	X    (if (not package-font)
	X	(setq package-font default-style-font))
	X    (if (not package-foreground)
	X	(setq package-foreground default-style-foreground))
	X    (if (not package-background)
	X	(setq package-background default-style-background))
	X    (if (not package-cursor-foreground)
	X	(setq package-cursor-foreground default-style-cursor-foreground))
	X    (if (not package-cursor-background)
	X	(setq package-cursor-background default-style-cursor-background))
	X    (if (not package-underline)
	X	(setq package-underline default-style-underline))
	X    (if (not package-stipple)
	X	(setq package-stipple default-style-stipple))
	X    (if (not package-cursor-stipple)
	X	(setq package-cursor-stipple default-style-cursor-stipple))
	X    (if (not package-background-stipple)
	X	(setq package-background-stipple default-style-background-stipple))
	X    ; Create a new style if necessary.
	X    (if (not new-package-style)
	X	(setq new-package-style (make-style)))
	X    ; Set each of the style fields if a value is defined for it.
	X    (if package-font
	X	(set-style-font new-package-style
	X			package-font))
	X    (if package-foreground
	X	(set-style-foreground new-package-style
	X			      package-foreground))
	X    (if package-background
	X	(set-style-background new-package-style
	X			      package-background))
	X    (if package-cursor-foreground
	X	(set-style-cursor-foreground new-package-style
	X				     package-cursor-foreground))
	X    (if package-background
	X	(set-style-background new-package-style
	X			      package-background))
	X    (if package-underline
	X	(set-style-underline new-package-style
	X			     package-underline))
	X    (if package-stipple
	X	(set-style-stipple new-package-style
	X			   package-stipple))
	X    (if package-cursor-stipple
	X	(set-style-cursor-stipple new-package-style
	X				  package-cursor-stipple))
	X    (if package-background-stipple
	X	(set-style-background-stipple new-package-style
	X				      package-background-stipple))
	X    ; return the style
	X    new-package-style
	X    ))
SHAR_EOF
if test 18204 -ne "`wc -c < 'tek-style-utils.el'`"
then
	echo shar: error transmitting "'tek-style-utils.el'" '(should have been 18204 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'syntax-decode.el'" '(10292 characters)'
if test -f 'syntax-decode.el'
then
	echo shar: will not over-write existing file "'syntax-decode.el'"
else
sed 's/^	X//' << \SHAR_EOF > 'syntax-decode.el'
	X;*****************************************************************************
	X;
	X; Filename:	syntax-decode.el
	X;
	X; Copyright (C) 1991  Ken Wood
	X;
	X; This program is free software; you can redistribute it and/or modify
	X; it under the terms of the GNU General Public License as published by
	X; the Free Software Foundation; either version 1, or (at your option)
	X; any later version.
	X;
	X; This program is distributed in the hope that it will be useful,
	X; but WITHOUT ANY WARRANTY; without even the implied warranty of
	X; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	X; GNU General Public License for more details.
	X;
	X; You should have received a copy of the GNU General Public License
	X; along with this program; if not, write to the Free Software
	X; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	X;
	X; Author:		Ken Wood, <kwood@austek.oz.au>
	X; Organisation:		Austek Microsystems Pty Ltd, Australia.
	X; Released with permission from Austek Microsystems.
	X;
	X; Description:	Calculate regular expressions used to match comments in the
	X;		current major mode. Also calculates strings that may be used
	X;		to begin & end comments in the major mode.
	X;
	X;		The values calculated are assigned to the buffer-local
	X;		variables syndecode-comment-start-regexp,
	X;		syndecode-comment-end-regexp, syndecode-comment-start-string,
	X;		and syndecode-comment-end-string.
	X;
	X;		If the function decode-syntax-table is run more than once in
	X;		the same buffer, later invocations do nothing. Each time a new
	X;		syntax table is decoded, its data is "cached" for use next
	X;		time that mode is encountered.
	X;
	X;		It should prove fairly simple to extract extra features from
	X;		the syntax table - drop me a line if you need something else
	X;		and we can work something out.
	X;
	X;		To install this package so that other packages can use it,
	X;		add this line to your .emacs:
	X;
	X;    (autoload 'decode-syntax-table "syntax-decode" "autoloadable function" t)
	X;
	X;*****************************************************************************
	X
	X; $Id: syntax-decode.el,v 1.6 1991/10/18 07:48:43 kwood Exp $
	X
	X(provide 'syntax-decode)
	X
	X(defvar syndecode-comment-start-regexp nil
	X  "\
	XRegexp to match the start of comments in the current mode. This value
	Xis more reliable than the comment-start variable, since it is
	Xdetermined directly from the syntax table. Will be nil if comments are
	Xnot defined in the current syntax table.")
	X
	X(defvar syndecode-comment-end-regexp nil
	X  "\
	XRegexp to match the end of comments in the current mode. This value is
	Xmore reliable than the comment-end variable, since it is determined
	Xdirectly from the syntax table. Will be nil if comments are not
	Xdefined in the current syntax table.")
	X
	X(defvar syndecode-comment-start-string nil
	X  "\
	XPreferred string to be used to begin comments in the current mode.
	XWill be nil if comments are not defined in the current syntax table.")
	X
	X(defvar syndecode-comment-end-string nil
	X  "\
	XPreferred string to be used to terminate comments in the current mode.
	XWill be nil if comments are not defined in the current syntax table or if
	Xcomments can be terminated by a newline.")
	X
	X(defvar syndecode-done-this-buffer nil
	X  "\
	XBuffer-local variable indicating whether the syntax table for this buffer
	Xhas been decoded or not.")
	X
	X(make-variable-buffer-local 'syndecode-comment-start-regexp)
	X(make-variable-buffer-local 'syndecode-comment-end-regexp)
	X(make-variable-buffer-local 'syndecode-comment-start-string)
	X(make-variable-buffer-local 'syndecode-comment-end-string)
	X(make-variable-buffer-local 'syndecode-done-this-buffer)
	X
	X(defvar syndecode-mode-feature-alist nil
	X  "\
	XAlist of major modes and their associated comment data as extracted
	Xfrom the syntax table. Acts as a cache when syntax-decode is run
	Xunder the same major mode more than once.")
	X
	X
	X; ***** decode-syntax-table *****
	X(defun decode-syntax-table ()
	X  "\
	XParse the syntax table for the current mode and figure set the variables
	X`syndecode-comment-start-regexp', `syndecode-comment-end-regexp',
	X`syndecode-comment-start-string' and `syndecode-comment-end-string'."
	X  ; Check to make sure this buffer hasn't already been done first.
	X  (if (not syndecode-done-this-buffer)
	X      ; First check to see if the syntax table for this mode has been
	X      ; decoded at some time in the past, by checking in the "cache"
	X      ; for the previously extracted values.
	X      (let* ((cached-syntax-list (assq major-mode
	X				       syndecode-mode-feature-alist)))
	X	(if cached-syntax-list
	X	    (progn
	X	      (setq cached-syntax-list (cadr cached-syntax-list))
	X	      (setq syndecode-comment-start-regexp (nth 0 cached-syntax-list))
	X	      (setq syndecode-comment-end-regexp (nth 1 cached-syntax-list))
	X	      (setq syndecode-comment-start-string (nth 2 cached-syntax-list))
	X	      (setq syndecode-comment-end-string (nth 3 cached-syntax-list))
	X	      )
	X	  ; If not cached, then must calculate the value from the current
	X	  ; syntax table.
	X	  (progn
	X	    ; Iterate over the syntax table & decode each character.
	X	    (let (
	X		  (debug-on-error t)
	X		  (tmp-syntax-table (append (syntax-table) nil))
	X		  (table-index 0)
	X		  (code nil)
	X		  (stripped-code nil)
	X		  (char nil)
	X		  (comm-start-string nil)
	X		  (comm-end-string nil)
	X		  (char1-long-comm-start nil)
	X		  (char2-long-comm-start nil)
	X		  (char1-long-comm-end nil)
	X		  (char2-long-comm-end nil)
	X		  (long-comm-start-string nil)
	X		  (long-comm-end-string nil)
	X		  temp-alist-cell
	X		  )
	X	      (while (and (< table-index 255) tmp-syntax-table)
	X		(progn
	X		  ; Extract the current code & character
	X		  (setq code (car tmp-syntax-table))
	X		  (setq char (char-to-string table-index))
	X		  (setq stripped-code (logand code 255))
	X
	X		  ; First, check if the flags for two-character comments are set
	X		  (if (/= 0 (logand (lsh code -16) 1))
	X		      (setq char1-long-comm-start char))
	X		  (if (/= 0 (logand (lsh code -17) 1))
	X		      (setq char2-long-comm-start char))
	X		  (if (/= 0 (logand (lsh code -18) 1))
	X		      (setq char1-long-comm-end char))
	X		  (if (/= 0 (logand (lsh code -19) 1))
	X		      (setq char2-long-comm-end char))
	X
	X		  ; Now check for single-character comments
	X		  (if (= stripped-code 11)
	X		      (setq comm-start-string (concat comm-start-string char)))
	X		  ; else
	X		  (if (= stripped-code 12)
	X		      (setq comm-end-string (concat comm-end-string char)))
	X
	X		  ; Move to the next element of the syntax table.
	X		  (setq table-index (+ table-index 1))
	X		  (setq tmp-syntax-table (cdr tmp-syntax-table))
	X		  ))
	X
	X	      ; Now, build the long (two character) comment strings, if their
	X	      ; component variables are defined.
	X	      (if (and char1-long-comm-start char2-long-comm-start)
	X		  (progn
	X		    (setq long-comm-start-string (concat char1-long-comm-start
	X							 char2-long-comm-start))
	X		    (setq syndecode-comment-start-regexp
	X			  (concat (regexp-quote char1-long-comm-start)
	X				  (regexp-quote char2-long-comm-start)))))
	X	      (if (and char1-long-comm-end char2-long-comm-end)
	X		  (progn
	X		    (setq long-comm-end-string (concat char1-long-comm-end
	X						       char2-long-comm-end))
	X		    (setq syndecode-comment-end-regexp
	X			  (concat (regexp-quote char1-long-comm-end)
	X				  (regexp-quote char2-long-comm-end)))))
	X
	X	      ; Now create the comment start & end regexps from the comment start &
	X	      ; end strings.
	X
	X	      ; Extract each character from comm-start-string and add it
	X	      ; verbatim to comment-start-regexp, a list of alternatives.
	X	      (let ((comm-start-index 0)
	X		    (comm-start-length (length comm-start-string)))
	X		(while (< comm-start-index comm-start-length)
	X		  (progn
	X		    (if syndecode-comment-start-regexp
	X			(setq syndecode-comment-start-regexp
	X			      (concat syndecode-comment-start-regexp "\\|"
	X				      (regexp-quote (substring comm-start-string
	X							       comm-start-index
	X							       (1+ comm-start-index)))))
	X		      (setq syndecode-comment-start-regexp
	X			    (regexp-quote (substring comm-start-string
	X						     comm-start-index
	X						     (1+ comm-start-index)))))
	X		    (setq comm-start-index (1+ comm-start-index)))))
	X
	X	      ; Extract each character from comm-end-string and add it
	X	      ; verbatim to comment-end-regexp, a list of alternatives.
	X	      (let ((comm-end-index 0)
	X		    (comm-end-length (length comm-end-string)))
	X		(while (< comm-end-index comm-end-length)
	X		  (progn
	X		    (if syndecode-comment-end-regexp
	X			(setq syndecode-comment-end-regexp
	X			      (concat syndecode-comment-end-regexp "\\|"
	X				      (regexp-quote (substring comm-end-string
	X							       comm-end-index
	X							       (1+ comm-end-index)))))
	X		      (setq syndecode-comment-end-regexp
	X			    (regexp-quote (substring comm-end-string
	X						     comm-end-index
	X						     (1+ comm-end-index)))))
	X		    (setq comm-end-index (1+ comm-end-index)))))
	X
	X	      ; Set up the comment start string.
	X	      (setq syndecode-comment-start-string
	X		    ; Prefer the two-character comment sequence
	X		    (or long-comm-start-string
	X			; Failing that, use one of the single character comment starting
	X			; sequences.
	X			(if comm-start-string
	X			    (substring comm-start-string -1))))
	X
	X	      ; Now, set up the comment end string.
	X	      (setq syndecode-comment-end-string
	X		    ; Set it to nil if newlines can terminate comments
	X		    (and (not (and comm-end-string
	X				   (string-match "\n" comm-end-string)))
	X			 ; Otherwise, prefer the two character comment sequence
	X			 (or long-comm-end-string
	X			     ; Failing that, one of the single character comment
	X			     ; terminators.
	X			     (if comm-end-string
	X				 (substring comm-end-string -1)))))
	X
	X	      ; Store the newly determined syntax features into the syntax
	X	      ; "cache" for lookup if this mode is encountered again later.
	X	      (setq temp-alist-cell
	X		    (list (list major-mode
	X				(list syndecode-comment-start-regexp
	X				      syndecode-comment-end-regexp
	X				      syndecode-comment-start-string
	X				      syndecode-comment-end-string))))
	X	      ; Add the current syntax features to the cache.
	X	      (if syndecode-mode-feature-alist
	X		  (setq syndecode-mode-feature-alist
	X			(append temp-alist-cell syndecode-mode-feature-alist))
	X		(setq syndecode-mode-feature-alist temp-alist-cell))
	X	      ))))
	X    ; Set a flag to indicate the syntax table in this buffer has been
	X    ; decoded.
	X    (setq syndecode-done-this-buffer t)
	X    )) ; end of defun
SHAR_EOF
if test 10292 -ne "`wc -c < 'syntax-decode.el'`"
then
	echo shar: error transmitting "'syntax-decode.el'" '(should have been 10292 characters)'
fi
fi # end of overwriting check
#	End of shell archive
exit 0


Ken Wood, Austek Microsystems, Technology Park, Adelaide, SA 5095, Australia
INTERNET:  kwood@austek.oz.au  UUCP: uunet.uu.net!munnari!austek.oz.au!kwood
------- End of forwarded message -------