comparison lisp/woman.el @ 88155:d7ddb3e565de

sync with trunk

88154:8ce476d3ba36

;;; woman.el --- browse UN*X manual pages `wo (without) man'

;; Copyright (C) 2000, 2002 Free Software Foundation, Inc.

;; Author: Francis J. Wright <[e-mail]>
;; Maintainer: Francis J. Wright <[e-mail]>
;; Keywords: help, unix
;; Adapted-By: Eli Zaretskii <[e-mail]>
;; Version: see `woman-version'
;; URL: http://centaur.maths.qmul.ac.uk/Emacs/WoMan/

;; This file is part of GNU Emacs.

;; 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:

;; WoMan implements a subset of the formatting performed by the Emacs
;; `man' (or `manual-entry') command to format a UN*X manual `page'

;; Start menu) just execute

;;   man man_page_name


;; Using the `word at point' as a topic suggestion
;; ===============================================

;; By default, the `woman' command uses the word nearest to point in
;; the current buffer as a suggestion for the topic to look up.  The
;; topic must be confirmed or edited in the minibuffer.  This
;; suggestion can be turned off, or `woman' can use the suggested
;; topic without confirmation* if possible, by setting the user-option
;; `woman-topic-at-point' to nil or t respectively.  (Its default
;; value is neither nil nor t, meaning ask for confirmation.)

;; [* Thanks to Benjamin Riefenstahl for suggesting this
;; functionality.]

;; The variable `woman-topic-at-point' can be rebound locally, which
;; may be useful to provide special private key bindings, e.g.

;;  (global-set-key "\C-cw"
;;  		  (lambda ()
;;  		    (interactive)
;;  		    (let ((woman-topic-at-point t))
;;  		      (woman)))))


;; Customization, Hooks and Imenu
;; ==============================

;;   Nicolai Henriksen <[e-mail]>
;;   Thomas Herchenroeder <[e-mail]>
;;   Alexander Hinds <[e-mail]>
;;   Stefan Hornburg <[e-mail]>
;;   Theodore Jump <[e-mail]>
;;   Paul Kinnucan <[e-mail]>
;;   Jonas Linde <[e-mail]>
;;   Andrew McRae <[e-mail]>
;;   Howard Melman <[e-mail]>
;;   Dennis Pixton <[e-mail]>

;;   Karel Sprenger <[e-mail]>
;;   Chris Szurgot <[e-mail]>
;;   Paul A. Thompson <[e-mail]>
;;   Arrigo Triulzi <[e-mail]>
;;   Geoff Voelker <[e-mail]>
;;   Eli Zaretskii <[e-mail]>

;;; History:
;;  For recent change log see end of file.


;;; Code:

(defvar woman-version "0.551 (beta)" "WoMan version information.")

(require 'man)
(eval-when-compile			; to avoid compiler warnings
  (require 'dired)
  (require 'apropos))

(defun woman-mapcan (fn x)
  "Return concatenated list of FN applied to successive `car' elements of X.
FN must return a list, cons or nil.  Useful for splicing into a list."
  ;; Based on the Standard Lisp function MAPCAN but with args swapped!
  (and x (nconc (funcall fn (car x)) (woman-mapcan fn (cdr x)))))

(defun woman-parse-colon-path (paths)
  "Explode search path string PATHS into a list of directory names.
Allow Cygwin colon-separated search paths on Microsoft platforms.
Replace null components by calling `woman-parse-man.conf'.

  (let ((path '("/usr/lib" "/etc")))
    (if (eq system-type 'windows-nt)
	(mapcar 'woman-Cyg-to-Win path)
      path))
  "*List of dirs to search and/or files to try for man config file.
A trailing separator (`/' for UNIX etc.) on directories is optional
and the filename used if a directory is specified is the first to
match the regexp \"man.*\\.conf\".
If MANPATH is not set but a config file is found then it is parsed
instead to provide a default value for `woman-manpath'."
  :type '(repeat string)
  :group 'woman-interface)

Used only if MANPATH is not set or contains null components.
Look in `woman-man.conf-path' and return a value for `woman-manpath'.
Concatenate data from all lines in the config file of the form
  MANPATH  /usr/man
or
  MANDATORY_MANPATH  /usr/man"
  ;; Functionality suggested by Charles Curley.
  (let ((path woman-man.conf-path)
	file manpath)
    (while (and
	    path

		  (with-temp-buffer
		    (insert-file-contents file)
		    (while (re-search-forward
			    ;; `\(?: ... \)' is a "shy group"
			    "\
^[ \t]*\\(?:MANDATORY_\\)?MANPATH[ \t]+\\(\\S-+\\)" nil t)
		      (setq manpath (cons (match-string 1) manpath)))
		    manpath))
		 ))
      (setq path (cdr path)))
    (nreverse manpath)))

  "*The title to use if WoMan adds a Contents menu to the menubar.
Default is \"CONTENTS\"."
  :type 'string
  :group 'woman-interface)

(defcustom woman-topic-at-point-default 'confirm
  ;; `woman-topic-at-point' may be let-bound when woman is loaded, in
  ;; which case its global value does not get defined.
  ;; `woman-file-name' sets it to this value if it is unbound.
  "*Default value for `woman-topic-at-point'."
  :type '(choice (const :tag "Yes" t)
		 (const :tag "No" nil)
		 (other :tag "Confirm" confirm))
  :group 'woman-interface)

(defcustom woman-topic-at-point woman-topic-at-point-default
  "*Controls use by `woman' of `word at point' as a topic suggestion.
If non-nil then the `woman' command uses the word at point as an
initial topic suggestion when it reads a topic from the minibuffer; if
t then the `woman' command uses the word at point WITHOUT
INTERACTIVE CONFIRMATION if it exists as a topic.  The default value
is `confirm', meaning suggest a topic and ask for confirmation."
  :type '(choice (const :tag "Yes" t)
		 (const :tag "No" nil)
		 (other :tag "Confirm" confirm))
  :group 'woman-interface)

(defvar woman-file-regexp nil
  "Regexp used to select (possibly compressed) man source files, e.g.
\"\\.\\([0-9lmnt]\\w*\\)\\(\\.\\(g?z\\|bz2\\)\\)?\\'\".

  :type 'integer
  :group 'woman-formatting)

(defcustom woman-fill-frame nil
  ;; Based loosely on a suggestion by Theodore Jump:
  "*If non-nil then most of the frame width is used."
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-default-indent 5
  "*Default prevailing indent set by -man macros -- default is 5.

  :type 'integer
  :group 'woman-formatting)

(defcustom woman-bold-headings t
  "*If non-nil then embolden section and subsection headings.  Default is t.
Heading emboldening is NOT standard `man' behaviour."
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-ignore t
  "*If non-nil then unrecognised requests etc. are ignored.  Default is t.
This gives the standard ?roff behaviour.  If nil then they are left in
the buffer, which may aid debugging."
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-preserve-ascii nil
  "*If non-nil then preserve ASCII characters in the WoMan buffer.
Otherwise, non-ASCII characters (that display as ASCII) may remain.
This is irrelevant unless the buffer is to be saved to a file."
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-emulation 'nroff
  "*WoMan emulation, currently either nroff or troff.  Default is nroff.

  :group 'woman-faces)

;; This is overkill!  Troff uses just italic; Nroff uses just underline.
;; You should probably select either italic or underline as you prefer, but
;; not both, although italic and underline work together perfectly well!
(defface woman-italic-face
  `((((background light)) (:slant italic :underline t :foreground "red"))
    (((background dark)) (:slant italic :underline t)))
  "Face for italic font in man pages."
  :group 'woman-faces)

(defface woman-bold-face
  '((((background light)) (:weight bold :foreground "blue"))
    (((background dark)) (:weight bold :foreground "green2")))
  "Face for bold font in man pages."
  :group 'woman-faces)

;; Brown is a good compromise: it is distinguishable from the default
;; but not enough so to make font errors look terrible.  (Files that use
;; non-standard fonts seem to do so badly or in idiosyncratic ways!)
(defface woman-unknown-face
  '((((background light)) (:foreground "brown"))
    (((background dark)) (:foreground "cyan")))
  "Face for all unknown fonts in man pages."
  :group 'woman-faces)

(defface woman-addition-face
  '((t (:foreground "orange")))
  "Face for all WoMan additions to man pages."
  :group 'woman-faces)

(defun woman-default-faces ()
  "Set foreground colours of italic and bold faces to their default values."
  (interactive)
  (face-spec-set 'woman-italic-face
		 (face-user-default-spec 'woman-italic-face))
  (face-spec-set 'woman-bold-face (face-user-default-spec 'woman-bold-face)))

(defun woman-monochrome-faces ()
  "Set foreground colours of italic and bold faces to that of the default face.
This is usually either black or white."
  (interactive)
  (set-face-foreground 'woman-italic-face 'unspecified)
  (set-face-foreground 'woman-bold-face 'unspecified))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Experimental font support, initially only for MS-Windows.
(defconst woman-font-support
  (eq window-system 'w32)		; Support X later!

	   (setq symbol-fonts (cons (car fonts) symbol-fonts)))
      (setq fonts (cdr fonts)))
    symbol-fonts))

(when woman-font-support
  (make-face 'woman-symbol-face)

  ;; Set the symbol font only if `woman-use-symbol-font' is true, to
  ;; avoid unnecessarily upsetting the line spacing in NTEmacs 20.5!

  (defcustom woman-use-extended-font t
    "*If non-nil then may use non-ASCII characters from the default font."
    :type 'boolean
    :group 'woman-faces)

  (defcustom woman-use-symbol-font nil
    "*If non-nil then may use the symbol font.  It is off by default,
mainly because it may change the line spacing (in NTEmacs 20.5)."
    :type 'boolean
    :group 'woman-faces)

  (defconst woman-symbol-font-list
    (or (woman-select-symbol-fonts (x-list-fonts "*" 'default))

(defsubst woman-reset-nospace ()
  "Set `woman-nospace' to nil."
  (setq woman-nospace nil))

(defconst woman-mode-line-format
  ;; This is essentially the Man-mode format with page numbers removed
  ;; and line numbers added.  (Online documents do not have pages, but
  ;; they do have lines!)
  '("-" mode-line-mule-info mode-line-modified
    mode-line-frame-identification mode-line-buffer-identification
    "  " global-mode-string
    "  %[(WoMan" mode-line-process minor-mode-alist ")%]--"
    (line-number-mode "L%l--")
    (-3 . "%p") "-%-")
  "Mode line format for WoMan buffer.")

(defconst woman-request-regexp "^[.'][ \t]*\\(\\S +\\) *"
  ;; Was "^\\.[ \t]*\\([a-z0-9]+\\) *" but cvs.1 uses a macro named
  ;; "`" and CGI.man uses a macro named "''"!
  ;; CGI.man uses ' as control character in places -- it *should*
  ;; suppress breaks!

(defvar woman-if-conditions-true '(?n ?e ?o)
  "List of one-character built-in condition names that are true.
Should include ?e, ?o (page even/odd) and either ?n (nroff) or ?t (troff).
Default is '(?n ?e ?o).  Set via `woman-emulation'.")


;;; Button types:

(define-button-type 'woman-xref
  'action (lambda (button) (woman (button-label button)))
  'help-echo "RET, mouse-2: display this man page")


;;; Specialized utility functions:

;;; Fast deletion without saving on the kill ring (cf. simple.el):

Used non-interactively, arguments are optional: if given then TOPIC
should be a topic string and non-nil RE-CACHE forces re-caching."
  (interactive (list nil current-prefix-arg))
  ;; The following test is for non-interactive calls via gnudoit etc.
  (if (or (interactive-p) (not (stringp topic)) (string-match "\\S " topic))
      (let ((file-name (woman-file-name topic re-cache)))
	(if file-name
	    (woman-find-file file-name)
	  (message
	   "WoMan Error: No matching manual files found in search path")

(defvar woman-topic-history nil "Topic read history.")
(defvar woman-file-history nil "File-name read history.")

(defun woman-file-name (topic &optional re-cache)
  "Get the name of the UN*X man-page file describing a chosen TOPIC.
When `woman' is called interactively, the word at point may be used as
the topic or initial topic suggestion, subject to the value of the
user option `woman-topic-at-point'.  Return nil if no file can be found.
Optional argument RE-CACHE, if non-nil, forces the cache to be re-read."
  ;; Handle the caching of the directory and topic lists:
  (if (and (not re-cache)
	   (or
	    (and woman-expanded-directory-path woman-topic-all-completions)
	    (woman-read-directory-cache)))

    (woman-write-directory-cache))
  ;; There is a problem in that I want to offer case-insensitive
  ;; completions, but to return only a case-sensitive match.  This
  ;; does not seem to work properly by default, so I re-do the
  ;; completion if necessary.
  (let (files)
    (or (stringp topic)
	(and (eq t
		 (if (boundp 'woman-topic-at-point)
		     woman-topic-at-point
		   ;; Was let-bound when file loaded, so ...
		   (setq woman-topic-at-point woman-topic-at-point-default)))
	     (setq topic
		   (current-word t))	; only within or adjacent to word
	     (assoc topic woman-topic-all-completions))
	(setq topic
	      (completing-read
	       "Manual entry: "
	       woman-topic-all-completions nil 1
	       ;; Initial input suggestion (was nil), with
	       ;; cursor at left ready to kill suggestion!:
	       (and woman-topic-at-point
		    (cons (current-word) 0)) ; nearest word
	       'woman-topic-history)))
    ;; Note that completing-read always returns a string.
    (if (= (length topic) 0)
	nil				; no topic, so no file!
      (cond
       ((setq files (woman-file-name-all-completions topic)))

       (t
	;; Multiple files for topic, so must select 1.
	;; Unread the command event (TAB = ?\t = 9) that runs the command
	;; `minibuffer-complete' in order to automatically complete the
	;; minibuffer contents as far as possible.
	(setq unread-command-events '(9))	; and delete any type-ahead!
	(completing-read "Manual file: " files nil 1
			 (try-completion "" files) 'woman-file-history)))
      )))

(defun woman-select (predicate list)
  "Select unique elements for which PREDICATE is true in LIST.
\(Note that this function changes the value of LIST.)"
  ;; Intended to be fast by avoiding recursion and list copying.

  ;; will be a list of the first `woman-cache-level' elements of the
  ;; following list: (topic path-index filename).  This alist `files'
  ;; is re-processed by `woman-topic-all-completions-merge'.
  (let (dir files (path-index 0))	; indexing starts at zero
    (while path
      (setq dir (car path)
	    path (cdr path))
      (if (woman-not-member dir path)	; use each directory only once!
	  (setq files
		(nconc files
		       (woman-topic-all-completions-1 dir path-index))))
      (setq path-index (1+ path-index)))
    ;; Uniquefy topics:
    (woman-topic-all-completions-merge files)))

(defun woman-topic-all-completions-1 (dir path-index)
  "Return an alist of the man topics in directory DIR with index PATH-INDEX.
A topic is a filename sans type-related extensions.
Support 3 levels of caching: each element of the alist will be a list

  ;; This function used to check that each file in the directory was
  ;; not itself a directory, but this is very slow and should be
  ;; unnecessary.  So let us assume that `woman-file-regexp' will
  ;; filter out any directories, which probably should not be there
  ;; anyway, i.e. it is a user error!
  (mapcar
   (lambda (file)
     (cons
      (file-name-sans-extension
       (if (string-match woman-file-compression-regexp file)
	   (file-name-sans-extension file)
	 file))
      (if (> woman-cache-level 1)
	  (cons
	   path-index
	   (if (> woman-cache-level 2)
	       (cons file nil))))))
   (directory-files dir nil woman-file-regexp)))

(defun woman-topic-all-completions-merge (alist)
  "Merge the alist ALIST so that the keys are unique.
Also make each path-info component into a list.
\(Note that this function changes the value of ALIST.)"
  ;; Intended to be fast by avoiding recursion and list copying.
  (if (> woman-cache-level 1)
      (let ((newalist alist))
	(while newalist
	  (let ((tail newalist) (topic (car (car newalist))))
	    ;; Make the path-info into a list:
	    (setcdr (car newalist) (list (cdr (car newalist))))
	    (while tail
	      (while (and tail (not (string= topic (car (car (cdr tail))))))
		(setq tail (cdr tail)))
	      (if tail			; merge path-info into (car newalist)
		  (let ((path-info (cdr (car (cdr tail)))))
		    (if (member path-info (cdr (car newalist)))
			()
		      ;; Make the path-info into a list:
		      (nconc (car newalist) (list path-info)))
		    (setcdr tail (cdr (cdr tail))))
		))
	    (setq newalist (cdr newalist))))
	alist)
    ;; woman-cache-level = 1 => elements are single-element lists ...
    (while (and alist (member (car alist) (cdr alist)))
      (setq alist (cdr alist)))
    (if alist
	(let ((newalist alist) cdr_alist)
	  (while (setq cdr_alist (cdr alist))
	    (if (not (member (car cdr_alist) (cdr cdr_alist)))
		(setq alist cdr_alist)
	      (setcdr alist (cdr cdr_alist)))
	    )
	  newalist))))

(defun woman-file-name-all-completions (topic)
  "Return an alist of the files in all man directories that match TOPIC."
  ;; Support 3 levels of caching: each element of
  ;; woman-topic-all-completions is a list of one of the forms:

  "Bind the argument KEY to the command `woman-dired-find-file'."
  (define-key dired-mode-map key 'woman-dired-find-file))

(defsubst woman-dired-define-key-maybe (key)
  "If KEY is undefined in Dired, bind it to command `woman-dired-find-file'."
  (if (eq (lookup-key dired-mode-map key) 'undefined)
      (woman-dired-define-key key)))

(defun woman-dired-define-keys ()
  "Define dired keys to run WoMan according to `woman-dired-keys'."
  (if woman-dired-keys

      ;; Multibyte characters exist.
      (progn
	(goto-char (point-min))
	(while (search-forward "__\b\b" nil t)
	  (backward-delete-char 4)
	  (woman-set-face (point) (1+ (point)) 'woman-italic-face))
	(goto-char (point-min))
	(while (search-forward "\b\b__" nil t)
	  (backward-delete-char 4)
	  (woman-set-face (1- (point)) (point) 'woman-italic-face))))

  ;; Interpret overprinting to indicate bold face:
  (goto-char (point-min))
  (while (re-search-forward "\\(.\\)\\(\\(+\\1\\)+\\)" nil t)
    (woman-delete-match 2)
    (woman-set-face (1- (point)) (point) 'woman-bold-face))

  ;; Interpret underlining to indicate italic face:
  ;; (Must be AFTER emboldening to interpret bold _ correctly!)
  (goto-char (point-min))
  (while (search-forward "_" nil t)
    (delete-char -2)
    (woman-set-face (point) (1+ (point)) 'woman-italic-face))

  ;; Leave any other uninterpreted ^H's in the buffer for now!  (They
  ;; might indicate composite special characters, which could be
  ;; interpreted if I knew what to expect.)

  (cond
   (woman-bold-headings
    (goto-char (point-min))
    (forward-line)
    (while (re-search-forward "^\\(   \\)?\\([A-Z].*\\)" nil t)
      (woman-set-face (match-beginning 2) (match-end 2) 'woman-bold-face))))
  )

(defun woman-insert-file-contents (filename compressed)
  "Insert file FILENAME into the current buffer.
If COMPRESSED is t, or is non-nil and the filename implies compression,


;;; Major mode (Man) interface:

(defvar woman-mode-map nil "Keymap for woman mode.")

(if woman-mode-map
    ()
  ;; Set up the keymap, mostly inherited from Man-mode-map.  Normally
  ;; button-buffer-map is used as a parent keymap, but we can't have two
  ;; parents, so we just copy it.
  (setq woman-mode-map (copy-keymap button-buffer-map))
  (set-keymap-parent woman-mode-map Man-mode-map)
  ;; Above two lines were
  ;; (setq woman-mode-map (cons 'keymap Man-mode-map))
  (define-key woman-mode-map "R" 'woman-reformat-last-file)
  (define-key woman-mode-map "w" 'woman)
  (define-key woman-mode-map "\en" 'WoMan-next-manpage)
  (define-key woman-mode-map "\ep" 'WoMan-previous-manpage)
  (define-key woman-mode-map [M-mouse-2] 'woman-follow-word))

(defun woman-follow-word (event)
  "Run WoMan with word under mouse as topic.
Argument EVENT is the invoking mouse event."
  (interactive "e")			; mouse event
  (goto-char (posn-point (event-start event)))
  (woman (current-word t)))

;; WoMan menu bar and pop-up menu:
(easy-menu-define
  woman-menu				; (SYMBOL MAPS DOC MENU)
  ;; That comment was moved after the symbol `woman-menu' to make

  "Reset `woman-emulation' to VALUE and reformat, for menu use."
  (interactive)
  (setq woman-emulation value)
  (woman-reformat-last-file))

(defun woman-mode ()
  "Turn on (most of) Man mode to browse a buffer formatted by WoMan.
WoMan is an ELisp emulation of much of the functionality of the Emacs
`man' command running the standard UN*X man and ?roff programs.
WoMan author: [e-mail]

    (fset 'Man-build-page-list 'ignore)
    (fset 'Man-strip-page-headers 'ignore)
    (fset 'Man-unindent 'ignore)
    (fset 'Man-goto-page 'ignore)
    (unwind-protect
	(progn
	  (set (make-local-variable 'Man-mode-map) woman-mode-map)
	  ;; Install Man mode:
	  (Man-mode)
	  ;; Reset inappropriate definitions:
	  (setq mode-line-format woman-mode-line-format)
          (put 'Man-mode 'mode-class 'special))
      ;; Restore the status quo:
      (fset 'Man-build-page-list Man-build-page-list)
      (fset 'Man-strip-page-headers Man-strip-page-headers)
      (fset 'Man-unindent Man-unindent)
      (fset 'Man-goto-page Man-goto-page)
      )
    ;; Imenu support:
    (set (make-local-variable 'imenu-generic-expression)
	 ;; `make-local-variable' in case imenu not yet loaded!
	 woman-imenu-generic-expression)
    (set (make-local-variable 'imenu-space-replacement) " ")
    ;; For reformat ...
    ;; necessary when reformatting a file in its old buffer:
    (setq imenu--last-menubar-index-alist nil)
    ;; necessary to avoid re-installing the same imenu:
    (setq woman-imenu-done nil)
    (if woman-imenu (woman-imenu))
    (setq buffer-read-only nil)
    (WoMan-highlight-references)
    (setq buffer-read-only t)
    (set-buffer-modified-p nil)))

(defun woman-imenu (&optional redraw)
  "Add a \"Contents\" menu to the menubar.
Optional argument REDRAW, if non-nil, forces mode line to be updated."
  (interactive)

			   (substring doc 0 (string-match "\n" doc))))))
	(setq p (cdr p))))
    ;; Output the result:
    (and (apropos-print t nil)
	 message
	 (message message))))


(defun WoMan-getpage-in-background (topic)
  "Use TOPIC to start WoMan from `Man-follow-manual-reference'."
  ;; topic is a string, generally of the form "section topic"

    (woman topic)))

(defvar WoMan-Man-start-time nil
  "Used to record formatting time used by the `man' command.")

(defadvice Man-getpage-in-background
  (around Man-getpage-in-background-advice (topic) activate)
  "Use WoMan unless invoked outside a WoMan buffer or invoked explicitly.
Otherwise use Man and record start of formatting time."
  (if (and (eq mode-line-format woman-mode-line-format)
	   (not (eq (caar command-history) 'man)))
      (WoMan-getpage-in-background topic)
    ;; Initiates man processing
    (setq WoMan-Man-start-time (current-time))
    ad-do-it))

(defadvice Man-bgproc-sentinel
  (after Man-bgproc-sentinel-advice activate)
  ;; Terminates man processing
  "Report formatting time."
  (let* ((time (current-time))
	 (time (+ (* (- (car time) (car WoMan-Man-start-time)) 65536)
		  (- (cadr time) (cadr WoMan-Man-start-time)))))
    (message "Man formatting done in %d seconds" time)))

(defun WoMan-highlight-references ()
  "Highlight the references (in the SEE ALSO section) on mouse-over."
  ;; Based on `Man-build-references-alist' in `man'.
  (when (Man-find-section Man-see-also-regexp)
    (forward-line 1)
    (let ((end (save-excursion
		 (Man-next-section 1)
		 (point))))
      (back-to-indentation)
      (while (re-search-forward Man-reference-regexp end t)
	;; Highlight reference when mouse is over it.
	;; (NB: WoMan does not hyphenate!)
	(make-text-button (match-beginning 1) (match-end 1)
			  'type 'woman-xref)))))


;;; Buffer handling:

(defun WoMan-previous-manpage ()

    (setq woman-if-conditions-true
	  (cons (string-to-char (symbol-name woman-emulation)) '(?e ?o)))

    ;; Prepare non-underlined versions of underlined faces:
    (woman-non-underline-faces)
    ;; Set font of `woman-symbol-face' to `woman-symbol-font' if
    ;; `woman-symbol-font' is well defined.
    (and woman-use-symbol-font
	 (stringp woman-symbol-font)
	 (set-face-font 'woman-symbol-face woman-symbol-font
			(and (frame-live-p woman-frame) woman-frame)))

    ;; Set syntax and display tables:
    (set-syntax-table woman-syntax-table)
    (woman-set-buffer-display-table)

    ;; Based loosely on a suggestion by Theodore Jump:
    (if (or woman-fill-frame
	    (not (and (integerp woman-fill-column) (> woman-fill-column 0))))
	(setq woman-fill-column (- (frame-width) woman-default-indent)))

    ;; Check for preprocessor requests:
    (goto-char from)
    (if (looking-at "'\\\\\"[ \t]*\\([a-z]+\\)")
	(let ((letters (append (match-string 1) nil)))

	       (repl (if (or (= (aref esc 0) ?u)
			     (and (>= (length esc) 2) (= (aref esc 2) ?-)))
			 "^" "_")))
	  (cond (first
		 (replace-match repl nil t)
		 (put-text-property (1- (point)) (point)
				    'face 'woman-addition-face)
		 (WoMan-warn
		  "Initial vertical motion escape \\%s simulated" esc)
		 (WoMan-log
		  "      by TeX `%s' in woman-addition-face!" repl))
		(t

     ;; ((looking-at "[te]") (setq c nil))   ; reject t(roff) and e(ven page)
     ((looking-at "[ntoe]")
      (setq c (memq (following-char) woman-if-conditions-true)))
     ;; Unrecognised letter so reject:
     ((looking-at "[A-Za-z]") (setq c nil)
      (WoMan-warn "%s %s -- unrecognised condition name rejected!"
		  request (match-string 0)))
     ;; Accept strings if identical:
     ((save-restriction
	(narrow-to-region from woman0-if-to)
	;; String delimiter can be any non-numeric character,

(defsubst woman-replace-match (newtext &optional face)
  "Replace text matched by last search with NEWTEXT and return t.
Set NEWTEXT in face FACE if specified."
  (woman-delete-match 0)
  (insert-before-markers newtext)
  (if face (put-text-property (1- (point)) (point)
			      'face 'woman-symbol-face))
  t)

(defun woman-special-characters (to)
  "Process special character escapes \\(xx, \\[xxx] up to buffer position TO.
\(This must be done AFTER translation, which may use special characters.)"

	   (cond ((and (cddr replacement)
		       (if (nthcdr 3 replacement)
			   ;; Need symbol font:
			   (if woman-use-symbol-font
			       (woman-replace-match (nth 2 replacement)
						    'woman-symbol-face))
			 ;; Need extended font:
			 (if woman-use-extended-font
			     (woman-replace-match (nth 2 replacement))))))
		 ((cadr replacement)	; Use ASCII simulation
		  (woman-replace-match (cadr replacement)))))

      (set-buffer standard-output)
      (let ((i 32))
	(while (< i 256)
	  (insert (format "\\%03o " i) (string i) " " (string i))
	  (put-text-property (1- (point)) (point)
			     'face 'woman-symbol-face)
	  (insert "   ")
	  (setq i (1+ i))
	  (when (= i 128) (setq i 160) (insert "\n"))
	  (if (zerop (% i 8)) (insert "\n")))
	))


;;; Direct font selection:

(defconst woman-font-alist
  '(("R" . default)
    ("I" . woman-italic-face)
    ("B" . woman-bold-face)
    ("P" . previous)
    ("1" . default)
    ("2" . woman-italic-face)
    ("3" . woman-bold-face)		; used in bash.1
    )
  "Alist of ?roff font indicators and woman font variables and names.")

(defun woman-change-fonts ()
  "Process font changes."
  ;; ***** NEEDS REVISING IF IT WORKS OK *****
  ;; Paragraph .LP/PP/HP/IP/TP and font .B/.BI etc. macros reset font.
  ;; Should .SH/.SS reset font?
  ;; Font size setting macros (?) should reset font.
  (let ((woman-font-alist woman-font-alist) ; for local updating
	(previous-pos (point))
	(previous-font 'default)
	(current-font 'default))
    (while
	;; Find font requests, paragraph macros and font escapes:

	(if notfont
	    ()
	  ;; Get font name:
	  (or font
	      (let ((fontstring (match-string 0)))
		(setq font (assoc fontstring woman-font-alist)
		      ;; NB: woman-font-alist contains VARIABLE NAMES.
		      font (if font
			       (cdr font)
			     (WoMan-warn "Unknown font %s." fontstring)
			     ;; Output this message once only per call ...
			     (setq woman-font-alist
				   (cons (cons fontstring 'woman-unknown-face)
					 woman-font-alist))
			     'woman-unknown-face)
		      )))
	  ;; Delete font control line or escape sequence:
	  (cond (beg (delete-region beg (point))
		     (if (eq font 'previous) (setq font previous-font))))
	  (woman-set-face previous-pos (point) current-font)

			(buffer-substring start here))
	  (delete-region here (point)))
      ))
  ;; Embolden heading (point is at end of heading):
  (woman-set-face
   (save-excursion (beginning-of-line) (point)) (point) 'woman-bold-face)
  (forward-line)
  (delete-blank-lines)
  (setq woman-left-margin woman-default-indent)
  (setq woman-prevailing-indent woman-default-indent)
  (woman2-format-paragraphs to woman-left-margin))

  (woman-leave-blank-lines woman-interparagraph-distance)
  (setq woman-leave-blank-lines nil)
  ;; Optionally embolden heading (point is at beginning of heading):
  (if woman-bold-headings
      (woman-set-face
       (point) (save-excursion (end-of-line) (point)) 'woman-bold-face))
  (forward-line)
  (setq woman-left-margin woman-default-indent
	woman-nofill nil)		; fill output lines
  (setq woman-prevailing-indent woman-default-indent)
  (woman2-format-paragraphs to woman-left-margin))

	     )))))
  nil)					; for woman-file-readable-p etc.

(provide 'woman)

;;; woman.el ends here

88155:d7ddb3e565de

;;; woman.el --- browse UN*X manual pages `wo (without) man'

;; Copyright (C) 2000, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.

;; Author: Francis J. Wright <[e-mail]>
;; Maintainer: FSF
;; Keywords: help, unix
;; Adapted-By: Eli Zaretskii <[e-mail]>
;; Version: see `woman-version'
;; URL: http://centaur.maths.qmul.ac.uk/Emacs/WoMan/

;; This file is part of GNU Emacs.

;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; WoMan implements a subset of the formatting performed by the Emacs
;; `man' (or `manual-entry') command to format a UN*X manual `page'

;; Start menu) just execute

;;   man man_page_name


;; Using the word at point as the default topic
;; ============================================

;; The `woman' command uses the word nearest to point in the current
;; buffer as the default topic to look up if it matches the name of a
;; manual page installed on the system.  The default topic can also be
;; used without confirmation by setting the user-option
;; `woman-use-topic-at-point' to t; thanks to Benjamin Riefenstahl for
;; suggesting this functionality.

;; The variable `woman-use-topic-at-point' can be rebound locally,
;; which may be useful to provide special private key bindings, e.g.

;;  (global-set-key "\C-cw"
;;  		  (lambda ()
;;  		    (interactive)
;;  		    (let ((woman-use-topic-at-point t))
;;  		      (woman)))))


;; Customization, Hooks and Imenu
;; ==============================

;;   Nicolai Henriksen <[e-mail]>
;;   Thomas Herchenroeder <[e-mail]>
;;   Alexander Hinds <[e-mail]>
;;   Stefan Hornburg <[e-mail]>
;;   Theodore Jump <[e-mail]>
;;   David Kastrup <[e-mail]>
;;   Paul Kinnucan <[e-mail]>
;;   Jonas Linde <[e-mail]>
;;   Andrew McRae <[e-mail]>
;;   Howard Melman <[e-mail]>
;;   Dennis Pixton <[e-mail]>

;;   Karel Sprenger <[e-mail]>
;;   Chris Szurgot <[e-mail]>
;;   Paul A. Thompson <[e-mail]>
;;   Arrigo Triulzi <[e-mail]>
;;   Geoff Voelker <[e-mail]>
;;   Eli Zaretskii <[e-mail]>


;;; Code:

(defvar woman-version "0.551 (beta)" "WoMan version information.")

(require 'man)
(require 'button)
(define-button-type 'WoMan-xref-man-page 
  :supertype 'Man-abstract-xref-man-page
  'func 'woman)

(eval-when-compile			; to avoid compiler warnings
  (require 'dired)
  (require 'apropos))

(defun woman-mapcan (fn x)
  "Return concatenated list of FN applied to successive `car' elements of X.
FN must return a list, cons or nil.  Useful for splicing into a list."
  ;; Based on the Standard Lisp function MAPCAN but with args swapped!
  ;; More concise implementation than the recursive one.  -- dak
  (apply #'nconc (mapcar fn x)))

(defun woman-parse-colon-path (paths)
  "Explode search path string PATHS into a list of directory names.
Allow Cygwin colon-separated search paths on Microsoft platforms.
Replace null components by calling `woman-parse-man.conf'.

  (let ((path '("/usr/lib" "/etc")))
    (if (eq system-type 'windows-nt)
	(mapcar 'woman-Cyg-to-Win path)
      path))
  "*List of dirs to search and/or files to try for man config file.
A trailing separator (`/' for UNIX etc.) on directories is optional,
and the filename is used if a directory specified is the first to
contain the strings \"man\" and \".conf\" (in that order).
If MANPATH is not set but a config file is found then it is parsed
instead to provide a default value for `woman-manpath'."
  :type '(repeat string)
  :group 'woman-interface)

Used only if MANPATH is not set or contains null components.
Look in `woman-man.conf-path' and return a value for `woman-manpath'.
Concatenate data from all lines in the config file of the form
  MANPATH  /usr/man
or
  MANDATORY_MANPATH  /usr/man
or
  OPTIONAL_MANPATH  /usr/man"
  ;; Functionality suggested by Charles Curley.
  (let ((path woman-man.conf-path)
	file manpath)
    (while (and
	    path

		  (with-temp-buffer
		    (insert-file-contents file)
		    (while (re-search-forward
			    ;; `\(?: ... \)' is a "shy group"
			    "\
^[ \t]*\\(?:MANDATORY_\\|OPTIONAL_\\)?MANPATH[ \t]+\\(\\S-+\\)" nil t)
		      (setq manpath (cons (match-string 1) manpath)))
		    manpath))
		 ))
      (setq path (cdr path)))
    (nreverse manpath)))

  "*The title to use if WoMan adds a Contents menu to the menubar.
Default is \"CONTENTS\"."
  :type 'string
  :group 'woman-interface)

(defcustom woman-use-topic-at-point-default nil
  ;; `woman-use-topic-at-point' may be let-bound when woman is loaded,
  ;; in which case its global value does not get defined.
  ;; `woman-file-name' sets it to this value if it is unbound.
  "*Default value for `woman-use-topic-at-point'."
  :type '(choice (const :tag "Yes" t)
		 (const :tag "No" nil))
  :group 'woman-interface)

(defcustom woman-use-topic-at-point woman-use-topic-at-point-default
  "*Control use of the word at point as the default topic.
If non-nil the `woman' command uses the word at point automatically,
without interactive confirmation, if it exists as a topic."
  :type '(choice (const :tag "Yes" t)
		 (const :tag "No" nil))
  :group 'woman-interface)

(defvar woman-file-regexp nil
  "Regexp used to select (possibly compressed) man source files, e.g.
\"\\.\\([0-9lmnt]\\w*\\)\\(\\.\\(g?z\\|bz2\\)\\)?\\'\".

  :type 'integer
  :group 'woman-formatting)

(defcustom woman-fill-frame nil
  ;; Based loosely on a suggestion by Theodore Jump:
  "*If non-nil then most of the window width is used."
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-default-indent 5
  "*Default prevailing indent set by -man macros -- default is 5.

  :type 'integer
  :group 'woman-formatting)

(defcustom woman-bold-headings t
  "*If non-nil then embolden section and subsection headings.  Default is t.
Heading emboldening is NOT standard `man' behavior."
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-ignore t
  "*If non-nil then unrecognized requests etc. are ignored.  Default is t.
This gives the standard ?roff behavior.  If nil then they are left in
the buffer, which may aid debugging."
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-preserve-ascii t
  "*If non-nil, preserve ASCII characters in the WoMan buffer.
Otherwise, to save time, some backslashes and spaces may be
represented differently (as the values of the variables
`woman-escaped-escape-char' and `woman-unpadded-space-char'
respectively) so that the buffer content is strictly wrong even though
it should display correctly.  This should be irrelevant unless the
buffer text is searched, copied or saved to a file."
  ;; This option should probably be removed!
  :type 'boolean
  :group 'woman-formatting)

(defcustom woman-emulation 'nroff
  "*WoMan emulation, currently either nroff or troff.  Default is nroff.

  :group 'woman-faces)

;; This is overkill!  Troff uses just italic; Nroff uses just underline.
;; You should probably select either italic or underline as you prefer, but
;; not both, although italic and underline work together perfectly well!
(defface woman-italic
  `((((min-colors 88) (background light))
     (:slant italic :underline t :foreground "red1"))
    (((background light)) (:slant italic :underline t :foreground "red"))
    (((background dark)) (:slant italic :underline t)))
  "Face for italic font in man pages."
  :group 'woman-faces)
;; backward-compatibility alias
(put 'woman-italic-face 'face-alias 'woman-italic)

(defface woman-bold
  '((((min-colors 88) (background light)) (:weight bold :foreground "blue1"))
    (((background light)) (:weight bold :foreground "blue"))
    (((background dark)) (:weight bold :foreground "green2")))
  "Face for bold font in man pages."
  :group 'woman-faces)
;; backward-compatibility alias
(put 'woman-bold-face 'face-alias 'woman-bold)

;; Brown is a good compromise: it is distinguishable from the default
;; but not enough so to make font errors look terrible.  (Files that use
;; non-standard fonts seem to do so badly or in idiosyncratic ways!)
(defface woman-unknown
  '((((background light)) (:foreground "brown"))
    (((min-colors 88) (background dark)) (:foreground "cyan1"))
    (((background dark)) (:foreground "cyan")))
  "Face for all unknown fonts in man pages."
  :group 'woman-faces)
;; backward-compatibility alias
(put 'woman-unknown-face 'face-alias 'woman-unknown)

(defface woman-addition
  '((t (:foreground "orange")))
  "Face for all WoMan additions to man pages."
  :group 'woman-faces)
;; backward-compatibility alias
(put 'woman-addition-face 'face-alias 'woman-addition)

(defun woman-default-faces ()
  "Set foreground colors of italic and bold faces to their default values."
  (interactive)
  (face-spec-set 'woman-italic (face-user-default-spec 'woman-italic))
  (face-spec-set 'woman-bold (face-user-default-spec 'woman-bold)))

(defun woman-monochrome-faces ()
  "Set foreground colors of italic and bold faces to that of the default face.
This is usually either black or white."
  (interactive)
  (set-face-foreground 'woman-italic 'unspecified)
  (set-face-foreground 'woman-bold 'unspecified))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Experimental font support, initially only for MS-Windows.
(defconst woman-font-support
  (eq window-system 'w32)		; Support X later!

	   (setq symbol-fonts (cons (car fonts) symbol-fonts)))
      (setq fonts (cdr fonts)))
    symbol-fonts))

(when woman-font-support
  (make-face 'woman-symbol)

  ;; Set the symbol font only if `woman-use-symbol-font' is true, to
  ;; avoid unnecessarily upsetting the line spacing in NTEmacs 20.5!

  (defcustom woman-use-extended-font t
    "*If non-nil then may use non-ASCII characters from the default font."
    :type 'boolean
    :group 'woman-faces)

  (defcustom woman-use-symbol-font nil
    "*If non-nil then may use the symbol font.
It is off by default, mainly because it may change the line spacing
\(in NTEmacs 20.5)."
    :type 'boolean
    :group 'woman-faces)

  (defconst woman-symbol-font-list
    (or (woman-select-symbol-fonts (x-list-fonts "*" 'default))

(defsubst woman-reset-nospace ()
  "Set `woman-nospace' to nil."
  (setq woman-nospace nil))

(defconst woman-request-regexp "^[.'][ \t]*\\(\\S +\\) *"
  ;; Was "^\\.[ \t]*\\([a-z0-9]+\\) *" but cvs.1 uses a macro named
  ;; "`" and CGI.man uses a macro named "''"!
  ;; CGI.man uses ' as control character in places -- it *should*
  ;; suppress breaks!

(defvar woman-if-conditions-true '(?n ?e ?o)
  "List of one-character built-in condition names that are true.
Should include ?e, ?o (page even/odd) and either ?n (nroff) or ?t (troff).
Default is '(?n ?e ?o).  Set via `woman-emulation'.")


;;; Specialized utility functions:

;;; Fast deletion without saving on the kill ring (cf. simple.el):

Used non-interactively, arguments are optional: if given then TOPIC
should be a topic string and non-nil RE-CACHE forces re-caching."
  (interactive (list nil current-prefix-arg))
  ;; The following test is for non-interactive calls via gnudoit etc.
  (if (or (not (stringp topic)) (string-match "\\S " topic))
      (let ((file-name (woman-file-name topic re-cache)))
	(if file-name
	    (woman-find-file file-name)
	  (message
	   "WoMan Error: No matching manual files found in search path")

(defvar woman-topic-history nil "Topic read history.")
(defvar woman-file-history nil "File-name read history.")

(defun woman-file-name (topic &optional re-cache)
  "Get the name of the UN*X man-page file describing a chosen TOPIC.
When `woman' is called interactively, the word at point may be
automatically used as the topic, if the value of the user option
`woman-use-topic-at-point' is non-nil.  Return nil if no file can
be found.  Optional argument RE-CACHE, if non-nil, forces the
cache to be re-read."
  ;; Handle the caching of the directory and topic lists:
  (if (and (not re-cache)
	   (or
	    (and woman-expanded-directory-path woman-topic-all-completions)
	    (woman-read-directory-cache)))

    (woman-write-directory-cache))
  ;; There is a problem in that I want to offer case-insensitive
  ;; completions, but to return only a case-sensitive match.  This
  ;; does not seem to work properly by default, so I re-do the
  ;; completion if necessary.
  (let (files
	(default (current-word)))
    (or (stringp topic)
	(and (if (boundp 'woman-use-topic-at-point)
		 woman-use-topic-at-point
	       ;; Was let-bound when file loaded, so ...
	       (setq woman-use-topic-at-point woman-use-topic-at-point-default))
	     (setq topic (or (current-word t) "")) ; only within or adjacent to word
	     (test-completion topic woman-topic-all-completions))
	(setq topic
	      (let* ((word-at-point (current-word))
		     (default
		       (when (and word-at-point
				  (test-completion
				   word-at-point woman-topic-all-completions))
			 word-at-point)))
		(completing-read
		 (if default
		     (format "Manual entry (default %s): " default)
		   "Manual entry: ")
		 woman-topic-all-completions nil 1
		 nil
		 'woman-topic-history
		 default))))
    ;; Note that completing-read always returns a string.
    (if (= (length topic) 0)
	nil				; no topic, so no file!
      (cond
       ((setq files (woman-file-name-all-completions topic)))

       (t
	;; Multiple files for topic, so must select 1.
	;; Unread the command event (TAB = ?\t = 9) that runs the command
	;; `minibuffer-complete' in order to automatically complete the
	;; minibuffer contents as far as possible.
	(setq unread-command-events '(9)) ; and delete any type-ahead!
	(completing-read "Manual file: " files nil 1
			 (try-completion "" files) 'woman-file-history))))))

(defun woman-select (predicate list)
  "Select unique elements for which PREDICATE is true in LIST.
\(Note that this function changes the value of LIST.)"
  ;; Intended to be fast by avoiding recursion and list copying.

  ;; will be a list of the first `woman-cache-level' elements of the
  ;; following list: (topic path-index filename).  This alist `files'
  ;; is re-processed by `woman-topic-all-completions-merge'.
  (let (dir files (path-index 0))	; indexing starts at zero
    (while path
      (setq dir (pop path))
      (if (woman-not-member dir path)	; use each directory only once!
	  (push (woman-topic-all-completions-1 dir path-index)
		files))
      (setq path-index (1+ path-index)))
    ;; Uniquefy topics:
    ;; Concate all lists with a single nconc call to
    ;; avoid retraversing the first lists repeatedly  -- dak
    (woman-topic-all-completions-merge
     (apply #'nconc files))))

(defun woman-topic-all-completions-1 (dir path-index)
  "Return an alist of the man topics in directory DIR with index PATH-INDEX.
A topic is a filename sans type-related extensions.
Support 3 levels of caching: each element of the alist will be a list

  ;; This function used to check that each file in the directory was
  ;; not itself a directory, but this is very slow and should be
  ;; unnecessary.  So let us assume that `woman-file-regexp' will
  ;; filter out any directories, which probably should not be there
  ;; anyway, i.e. it is a user error!
  ;;
  ;; Don't sort files: we do that when merging, anyway.  -- dak
  (let (newlst (lst (directory-files dir nil woman-file-regexp t))
	       ;; Make an explicit regexp for stripping extension and
	       ;; compression extension: file-name-sans-extension is a
	       ;; far too costly function.  -- dak
	       (ext (format "\\(\\.[^.\\/]*\\)?\\(%s\\)?\\'"
			    woman-file-compression-regexp)))
    ;; Use a loop instead of mapcar in order to avoid the speed
    ;; penalty of binding function arguments.  -- dak
      (dolist (file lst newlst)
	(push
	 (cons
	  (if (string-match ext file)
	      (substring file 0 (match-beginning 0))
	    file)
	  (and (> woman-cache-level 1)
	       (cons
		path-index
		(and (> woman-cache-level 2)
		     (list file)))))
	 newlst))))

(defun woman-topic-all-completions-merge (alist)
  "Merge the alist ALIST so that the keys are unique.
Also make each path-info component into a list.
\(Note that this function changes the value of ALIST.)"
  ;; Replaces unreadably "optimized" O(n^2) implementation.
  ;; Instead we use sorting to merge stuff efficiently.  -- dak
  (let (elt newalist)
    ;; Sort list into reverse order
    (setq alist (sort alist (lambda(x y) (string< (car y) (car x)))))
    ;; merge duplicate keys.
    (if (> woman-cache-level 1)
	(while alist
	  (setq elt (pop alist))
	  (if (equal (car elt) (caar newalist))
	      (unless (member (cdr elt) (cdar newalist))
		(setcdr (car newalist) (cons (cdr elt)
					     (cdar newalist))))
	    (setcdr elt (list (cdr elt)))
	    (push elt newalist)))
    ;; woman-cache-level = 1 => elements are single-element lists ...
      (while alist
	(setq elt (pop alist))
	(unless (equal (car elt) (caar newalist))
	  (push elt newalist))))
    newalist))

(defun woman-file-name-all-completions (topic)
  "Return an alist of the files in all man directories that match TOPIC."
  ;; Support 3 levels of caching: each element of
  ;; woman-topic-all-completions is a list of one of the forms:

  "Bind the argument KEY to the command `woman-dired-find-file'."
  (define-key dired-mode-map key 'woman-dired-find-file))

(defsubst woman-dired-define-key-maybe (key)
  "If KEY is undefined in Dired, bind it to command `woman-dired-find-file'."
  (if (or (eq (lookup-key dired-mode-map key) 'undefined)
	  (null (lookup-key dired-mode-map key)))
      (woman-dired-define-key key)))

(defun woman-dired-define-keys ()
  "Define dired keys to run WoMan according to `woman-dired-keys'."
  (if woman-dired-keys

      ;; Multibyte characters exist.
      (progn
	(goto-char (point-min))
	(while (search-forward "__\b\b" nil t)
	  (backward-delete-char 4)
	  (woman-set-face (point) (1+ (point)) 'woman-italic))
	(goto-char (point-min))
	(while (search-forward "\b\b__" nil t)
	  (backward-delete-char 4)
	  (woman-set-face (1- (point)) (point) 'woman-italic))))

  ;; Interpret overprinting to indicate bold face:
  (goto-char (point-min))
  (while (re-search-forward "\\(.\\)\\(\\(+\\1\\)+\\)" nil t)
    (woman-delete-match 2)
    (woman-set-face (1- (point)) (point) 'woman-bold))

  ;; Interpret underlining to indicate italic face:
  ;; (Must be AFTER emboldening to interpret bold _ correctly!)
  (goto-char (point-min))
  (while (search-forward "_" nil t)
    (delete-char -2)
    (woman-set-face (point) (1+ (point)) 'woman-italic))

  ;; Leave any other uninterpreted ^H's in the buffer for now!  (They
  ;; might indicate composite special characters, which could be
  ;; interpreted if I knew what to expect.)

  (cond
   (woman-bold-headings
    (goto-char (point-min))
    (forward-line)
    (while (re-search-forward "^\\(   \\)?\\([A-Z].*\\)" nil t)
      (woman-set-face (match-beginning 2) (match-end 2) 'woman-bold))))
  )

(defun woman-insert-file-contents (filename compressed)
  "Insert file FILENAME into the current buffer.
If COMPRESSED is t, or is non-nil and the filename implies compression,


;;; Major mode (Man) interface:

(defvar woman-mode-map nil "Keymap for woman mode.")

(unless woman-mode-map
  (setq woman-mode-map (make-sparse-keymap))
  (set-keymap-parent woman-mode-map Man-mode-map)

  (define-key woman-mode-map "R" 'woman-reformat-last-file)
  (define-key woman-mode-map "w" 'woman)
  (define-key woman-mode-map "\en" 'WoMan-next-manpage)
  (define-key woman-mode-map "\ep" 'WoMan-previous-manpage)
  (define-key woman-mode-map [M-mouse-2] 'woman-follow-word)

  ;; We don't need to call `man' when we are in `woman-mode'.
  (define-key woman-mode-map [remap man] 'woman))

(defun woman-follow-word (event)
  "Run WoMan with word under mouse as topic.
Argument EVENT is the invoking mouse event."
  (interactive "e")			; mouse event
  (goto-char (posn-point (event-start event)))
  (woman (or (current-word t) "")))

;; WoMan menu bar and pop-up menu:
(easy-menu-define
  woman-menu				; (SYMBOL MAPS DOC MENU)
  ;; That comment was moved after the symbol `woman-menu' to make

  "Reset `woman-emulation' to VALUE and reformat, for menu use."
  (interactive)
  (setq woman-emulation value)
  (woman-reformat-last-file))

(put 'woman-mode 'mode-class 'special)

(defun woman-mode ()
  "Turn on (most of) Man mode to browse a buffer formatted by WoMan.
WoMan is an ELisp emulation of much of the functionality of the Emacs
`man' command running the standard UN*X man and ?roff programs.
WoMan author: [e-mail]

    (fset 'Man-build-page-list 'ignore)
    (fset 'Man-strip-page-headers 'ignore)
    (fset 'Man-unindent 'ignore)
    (fset 'Man-goto-page 'ignore)
    (unwind-protect
	(delay-mode-hooks (Man-mode))
      ;; Restore the status quo:
      (fset 'Man-build-page-list Man-build-page-list)
      (fset 'Man-strip-page-headers Man-strip-page-headers)
      (fset 'Man-unindent Man-unindent)
      (fset 'Man-goto-page Man-goto-page)))
  (setq major-mode 'woman-mode
	mode-name "WoMan")
  ;; Don't show page numbers like Man-mode does.  (Online documents do
  ;; not have pages)
  (kill-local-variable 'mode-line-buffer-identification)
  (use-local-map woman-mode-map)
  ;; Imenu support:
  (set (make-local-variable 'imenu-generic-expression)
       ;; `make-local-variable' in case imenu not yet loaded!
       woman-imenu-generic-expression)
  (set (make-local-variable 'imenu-space-replacement) " ")
  ;; For reformat ...
  ;; necessary when reformatting a file in its old buffer:
  (setq imenu--last-menubar-index-alist nil)
  ;; necessary to avoid re-installing the same imenu:
  (setq woman-imenu-done nil)
  (if woman-imenu (woman-imenu))
  (let (buffer-read-only)
    (Man-highlight-references 'WoMan-xref-man-page))
  (set-buffer-modified-p nil)
  (run-mode-hooks 'woman-mode-hook))

(defun woman-imenu (&optional redraw)
  "Add a \"Contents\" menu to the menubar.
Optional argument REDRAW, if non-nil, forces mode line to be updated."
  (interactive)

			   (substring doc 0 (string-match "\n" doc))))))
	(setq p (cdr p))))
    ;; Output the result:
    (and (apropos-print t nil)
	 message
	 (message "%s" message))))


(defun WoMan-getpage-in-background (topic)
  "Use TOPIC to start WoMan from `Man-follow-manual-reference'."
  ;; topic is a string, generally of the form "section topic"

    (woman topic)))

(defvar WoMan-Man-start-time nil
  "Used to record formatting time used by the `man' command.")

;; Both advices are disabled because "a file in Emacs should not put
;; advice on a function in Emacs" (see Info node "(elisp)Advising
;; Functions").  Counting the formatting time is useful for
;; developping, but less applicable for daily use.  The advice for
;; `Man-getpage-in-background' can be discarded, because the
;; key-binding in `woman-mode-map' has been remapped to call `woman'
;; but `man'.  Michael Albinus <[e-mail]>

;; (defadvice Man-getpage-in-background
;;   (around Man-getpage-in-background-advice (topic) activate)
;;   "Use WoMan unless invoked outside a WoMan buffer or invoked explicitly.
;; Otherwise use Man and record start of formatting time."
;;   (if (and (eq major-mode 'woman-mode)
;; 	   (not (eq (caar command-history) 'man)))
;;       (WoMan-getpage-in-background topic)
;;     ;; Initiates man processing
;;     (setq WoMan-Man-start-time (current-time))
;;     ad-do-it))

;; (defadvice Man-bgproc-sentinel
;;   (after Man-bgproc-sentinel-advice activate)
;;   ;; Terminates man processing
;;   "Report formatting time."
;;   (let* ((time (current-time))
;; 	 (time (+ (* (- (car time) (car WoMan-Man-start-time)) 65536)
;; 		  (- (cadr time) (cadr WoMan-Man-start-time)))))
;;     (message "Man formatting done in %d seconds" time)))


;;; Buffer handling:

(defun WoMan-previous-manpage ()

    (setq woman-if-conditions-true
	  (cons (string-to-char (symbol-name woman-emulation)) '(?e ?o)))

    ;; Prepare non-underlined versions of underlined faces:
    (woman-non-underline-faces)
    ;; Set font of `woman-symbol' face to `woman-symbol-font' if
    ;; `woman-symbol-font' is well defined.
    (and woman-use-symbol-font
	 (stringp woman-symbol-font)
	 (set-face-font 'woman-symbol woman-symbol-font
			(and (frame-live-p woman-frame) woman-frame)))

    ;; Set syntax and display tables:
    (set-syntax-table woman-syntax-table)
    (woman-set-buffer-display-table)

    ;; Based loosely on a suggestion by Theodore Jump:
    (if (or woman-fill-frame
	    (not (and (integerp woman-fill-column) (> woman-fill-column 0))))
	(setq woman-fill-column (- (window-width) woman-default-indent)))

    ;; Check for preprocessor requests:
    (goto-char from)
    (if (looking-at "'\\\\\"[ \t]*\\([a-z]+\\)")
	(let ((letters (append (match-string 1) nil)))

	       (repl (if (or (= (aref esc 0) ?u)
			     (and (>= (length esc) 2) (= (aref esc 2) ?-)))
			 "^" "_")))
	  (cond (first
		 (replace-match repl nil t)
		 (put-text-property (1- (point)) (point) 'face 'woman-addition)
		 (WoMan-warn
		  "Initial vertical motion escape \\%s simulated" esc)
		 (WoMan-log
		  "      by TeX `%s' in woman-addition-face!" repl))
		(t

     ;; ((looking-at "[te]") (setq c nil))   ; reject t(roff) and e(ven page)
     ((looking-at "[ntoe]")
      (setq c (memq (following-char) woman-if-conditions-true)))
     ;; Unrecognised letter so reject:
     ((looking-at "[A-Za-z]") (setq c nil)
      (WoMan-warn "%s %s -- unrecognized condition name rejected!"
		  request (match-string 0)))
     ;; Accept strings if identical:
     ((save-restriction
	(narrow-to-region from woman0-if-to)
	;; String delimiter can be any non-numeric character,

(defsubst woman-replace-match (newtext &optional face)
  "Replace text matched by last search with NEWTEXT and return t.
Set NEWTEXT in face FACE if specified."
  (woman-delete-match 0)
  (insert-before-markers newtext)
  (if face (put-text-property (1- (point)) (point) 'face 'woman-symbol))
  t)

(defun woman-special-characters (to)
  "Process special character escapes \\(xx, \\[xxx] up to buffer position TO.
\(This must be done AFTER translation, which may use special characters.)"

	   (cond ((and (cddr replacement)
		       (if (nthcdr 3 replacement)
			   ;; Need symbol font:
			   (if woman-use-symbol-font
			       (woman-replace-match (nth 2 replacement)
						    'woman-symbol))
			 ;; Need extended font:
			 (if woman-use-extended-font
			     (woman-replace-match (nth 2 replacement))))))
		 ((cadr replacement)	; Use ASCII simulation
		  (woman-replace-match (cadr replacement)))))

      (set-buffer standard-output)
      (let ((i 32))
	(while (< i 256)
	  (insert (format "\\%03o " i) (string i) " " (string i))
	  (put-text-property (1- (point)) (point)
			     'face 'woman-symbol)
	  (insert "   ")
	  (setq i (1+ i))
	  (when (= i 128) (setq i 160) (insert "\n"))
	  (if (zerop (% i 8)) (insert "\n")))
	))


;;; Direct font selection:

(defconst woman-font-alist
  '(("R" . default)
    ("I" . woman-italic)
    ("B" . woman-bold)
    ("P" . previous)
    ("1" . default)
    ("2" . woman-italic)
    ("3" . woman-bold)			; used in bash.1
    )
  "Alist of ?roff font indicators and woman font variables and names.")

(defun woman-change-fonts ()
  "Process font changes."
  ;; ***** NEEDS REVISING IF IT WORKS OK *****
  ;; Paragraph .LP/PP/HP/IP/TP and font .B/.BI etc. macros reset font.
  ;; Should .SH/.SS reset font?
  ;; Font size setting macros (?) should reset font.
  (let ((font-alist woman-font-alist) ; for local updating
	(previous-pos (point))
	(previous-font 'default)
	(current-font 'default))
    (while
	;; Find font requests, paragraph macros and font escapes:

	(if notfont
	    ()
	  ;; Get font name:
	  (or font
	      (let ((fontstring (match-string 0)))
		(setq font (assoc fontstring font-alist)
		      ;; NB: font-alist contains VARIABLE NAMES.
		      font (if font
			       (cdr font)
			     (WoMan-warn "Unknown font %s." fontstring)
			     ;; Output this message once only per call ...
			     (setq font-alist
				   (cons (cons fontstring 'woman-unknown)
					 font-alist))
			     'woman-unknown)
		      )))
	  ;; Delete font control line or escape sequence:
	  (cond (beg (delete-region beg (point))
		     (if (eq font 'previous) (setq font previous-font))))
	  (woman-set-face previous-pos (point) current-font)

			(buffer-substring start here))
	  (delete-region here (point)))
      ))
  ;; Embolden heading (point is at end of heading):
  (woman-set-face
   (save-excursion (beginning-of-line) (point)) (point) 'woman-bold)
  (forward-line)
  (delete-blank-lines)
  (setq woman-left-margin woman-default-indent)
  (setq woman-prevailing-indent woman-default-indent)
  (woman2-format-paragraphs to woman-left-margin))

  (woman-leave-blank-lines woman-interparagraph-distance)
  (setq woman-leave-blank-lines nil)
  ;; Optionally embolden heading (point is at beginning of heading):
  (if woman-bold-headings
      (woman-set-face
       (point) (save-excursion (end-of-line) (point)) 'woman-bold))
  (forward-line)
  (setq woman-left-margin woman-default-indent
	woman-nofill nil)		; fill output lines
  (setq woman-prevailing-indent woman-default-indent)
  (woman2-format-paragraphs to woman-left-margin))

	     )))))
  nil)					; for woman-file-readable-p etc.

(provide 'woman)

;;; arch-tag: eea35e90-552f-4712-a94b-d9ffd3db7651
;;; woman.el ends here