(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 (lambda (arg)
(woman
(if (string-match Man-reference-regexp arg)
(substring arg 0 (match-end 1))
arg))))
(eval-when-compile (require 'dired)
(require 'cl)
(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."
(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'.
As a special case, if PATHS is nil then replace it by calling
`woman-parse-man.conf'."
(if (memq system-type '(windows-nt ms-dos))
(cond ((null paths)
(mapcar 'woman-Cyg-to-Win (woman-parse-man.conf)))
((string-match ";" paths)
(woman-mapcan (lambda (x)
(if x
(list x)
(mapcar 'woman-Cyg-to-Win (woman-parse-man.conf))))
(parse-colon-path paths)))
((string-match "\\`[a-zA-Z]:" paths)
paths)
(t
(woman-mapcan (lambda (x)
(mapcar 'woman-Cyg-to-Win
(if x (list x) (woman-parse-man.conf))))
(let ((path-separator ":"))
(parse-colon-path paths)))))
(woman-mapcan (lambda (x) (if x (list x) (woman-parse-man.conf)))
(parse-colon-path (or paths "")))))
(defun woman-Cyg-to-Win (file)
"Convert an absolute filename FILE from Cygwin to Windows form."
(if (consp file)
file
(if (eq (aref file 0) ?/)
(condition-case nil
(with-temp-buffer
(call-process "cygpath" nil t nil "-m" file)
(buffer-substring 1 (buffer-size)))
(error
(when (string-match "\\`\\(/cygdrive\\|/\\)?/./" file)
(if (match-string 1) (setq file (substring file (match-end 1))))
(aset file 0 (aref file 1)) (aset file 1 ?:)) file))
file)))
(defgroup woman nil
"Browse UNIX manual pages `wo (without) man'."
:tag "WoMan"
:group 'help)
(defcustom woman-show-log nil
"*If non-nil then show the *WoMan-Log* buffer if appropriate.
I.e. if any warning messages are written to it. Default is nil."
:type 'boolean
:group 'woman)
(defcustom woman-pre-format-hook nil
"*Hook run by WoMan immediately before formatting a buffer.
Change only via `Customization' or the function `add-hook'."
:type 'hook
:group 'woman)
(defcustom woman-post-format-hook nil
"*Hook run by WoMan immediately after formatting a buffer.
Change only via `Customization' or the function `add-hook'."
:type 'hook
:group 'woman)
(defgroup woman-interface nil
"Interface options for browsing UNIX manual pages `wo (without) man'."
:tag "WoMan Interface"
:group 'woman)
(defcustom woman-man.conf-path
(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 start with \"man\" and has an extension starting
with \".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)
(defun woman-parse-man.conf ()
"Parse if possible configuration file for man command.
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
or
MANPATH_MAP /opt/bin /opt/man"
(let ((path woman-man.conf-path)
file manpath)
(while (and
path
(not (and
(file-readable-p (setq file (car path)))
(or (not (file-directory-p file))
(and
(setq file
(directory-files file t "\\`man.*\\.conf[a-z]*\\'" t))
(file-readable-p (setq file (car file)))))
(with-temp-buffer
(insert-file-contents file)
(while (re-search-forward
"\
^[ \t]*\\(?:\\(?:MANDATORY_\\|OPTIONAL_\\)?MANPATH[ \t]+\\(\\S-+\\)\\|\
MANPATH_MAP[ \t]+\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\)" nil t)
(add-to-list 'manpath
(if (match-beginning 1)
(match-string 1)
(cons (match-string 2)
(match-string 3)))))
manpath))
))
(setq path (cdr path)))
(nreverse manpath)))
(defcustom woman-manpath
(or (woman-parse-colon-path (getenv "MANPATH"))
'("/usr/man" "/usr/share/man" "/usr/local/man"))
"*List of DIRECTORY TREES to search for UN*X manual files.
Each element should be the name of a directory that contains
subdirectories of the form `man?', or more precisely subdirectories
selected by the value of `woman-manpath-man-regexp'. Non-directory
and unreadable files are ignored.
Elements can also be a cons cell indicating a mapping from PATH
to manual trees: if such an element's car is equal to a path
element of the environment variable PATH, the cdr of the cons
cell is included in the directory tree search.
If not set then the environment variable MANPATH is used. If no such
environment variable is found, the default list is determined by
consulting the man configuration file if found, which is determined by
the user option `woman-man.conf-path'. An empty substring of MANPATH
denotes the default list.
Any environment variables (names must have the UN*X-style form $NAME,
e.g. $HOME, $EMACSDATA, $emacs_dir) are evaluated first but each
element must evaluate to a SINGLE directory name. Trailing `/'s are
ignored. (Specific directories in `woman-path' are also searched.)
Microsoft platforms:
I recommend including drive letters explicitly, e.g.
(\"C:/Cygwin/usr/man/\" \"C:/Cygwin/usr/local/man\").
The MANPATH environment variable may be set using DOS semi-colon-
separated or UN*X/Cygwin colon-separated syntax (but not mixed)."
:type '(repeat (choice string (cons string string)))
:group 'woman-interface)
(defcustom woman-manpath-man-regexp "[Mm][Aa][Nn]"
"Regexp to match man directories UNDER `woman-manpath' directories.
These normally have names of the form `man?'. Its default value is
\"[Mm][Aa][Nn]\", which is case-insensitive mainly for the benefit of
Microsoft platforms. Its purpose is to avoid `cat?', `.', `..', etc."
:type 'string
:group 'woman-interface)
(defcustom woman-path
(if (eq system-type 'ms-dos) '("$DJDIR/info" "$DJDIR/man/cat[1-9onlp]"))
"*List of SPECIFIC DIRECTORIES to search for UN*X manual files.
For example
(\"/emacs/etc\").
These directories are searched in addition to the directory trees
specified in `woman-manpath'. Each element should be a directory
string or nil, which represents the current directory when the path is
expanded and cached. However, the last component (only) of each
directory string is treated as a regexp \(Emacs, not shell) and the
string is expanded into a list of matching directories. Non-directory
and unreadable files are ignored. The default value is nil.
Any environment variables (which must have the UN*X-style form $NAME,
e.g. $HOME, $EMACSDATA, $emacs_dir) are evaluated first but each
element must evaluate to a SINGLE directory name (regexp, see above).
For example
(\"$EMACSDATA\") [or equivalently (\"$emacs_dir/etc\")].
Trailing `/'s are discarded. (The directory trees in `woman-manpath'
are also searched.) On Microsoft platforms I recommend including
drive letters explicitly."
:type '(repeat (choice string (const nil)))
:group 'woman-interface)
(defcustom woman-cache-level 2
"*The level of topic caching.
1 - cache only the topic and directory lists
(the only level before version 0.34 - only for compatibility);
2 - cache also the directories for each topic
(faster, without using much more memory);
3 - cache also the actual filenames for each topic
(fastest, but uses twice as much memory).
The default value is currently 2, a good general compromise.
If the `woman' command is slow to find files then try 3, which may be
particularly beneficial with large remote-mounted man directories.
Run the `woman' command with a prefix argument or delete the cache
file `woman-cache-filename' for a change to take effect.
\(Values < 1 behave like 1; values > 3 behave like 3.)"
:type '(choice (const :tag "Minimal" 1)
(const :tag "Default" 2)
(const :tag "Maximal" 3))
:group 'woman-interface)
(defcustom woman-cache-filename nil
"*The full pathname of the WoMan directory and topic cache file.
It is used to save and restore the cache between sessions. This is
especially useful with remote-mounted man page files! The default
value of nil suppresses this action. The `standard' non-nil
filename is \"~/.wmncach.el\". Remember that a prefix argument forces
the `woman' command to update and re-write the cache."
:type '(choice (const :tag "None" nil)
(const :tag "~/.wmncach.el" "~/.wmncach.el")
file)
:group 'woman-interface)
(defcustom woman-dired-keys t
"*List of `dired' mode keys to define to run WoMan on current file.
E.g. '(\"w\" \"W\"), or any non-null atom to automatically define
\"w\" and \"W\" if they are unbound, or nil to do nothing.
Default is t."
:type '(choice (const :tag "None" nil)
(repeat string)
(other :tag "Auto" t))
:group 'woman-interface)
(defcustom woman-imenu-generic-expression
'((nil "\n\\([A-Z].*\\)" 1) ("*Subsections*" "^ \\([A-Z].*\\)" 1))
"*Imenu support for Sections and Subsections.
An alist with elements of the form (MENU-TITLE REGEXP INDEX) --
see the documentation for `imenu-generic-expression'."
:type 'sexp
:group 'woman-interface)
(defcustom woman-imenu nil
"*If non-nil then WoMan adds a Contents menu to the menubar.
It does this by calling `imenu-add-to-menubar'. Default is nil."
:type 'boolean
:group 'woman-interface)
(defcustom woman-imenu-title "CONTENTS"
"*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
"*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\\)\\)?\\'\".
Built automatically from the customizable user options
`woman-uncompressed-file-regexp' and `woman-file-compression-regexp'.")
(defvar woman-uncompressed-file-regexp) (defvar woman-file-compression-regexp)
(defun set-woman-file-regexp (symbol value)
"Bind SYMBOL to VALUE and set `woman-file-regexp' as per user customizations.
Used as :set cookie by Customize when customizing the user options
`woman-uncompressed-file-regexp' and `woman-file-compression-regexp'."
(set-default symbol value)
(and (boundp 'woman-uncompressed-file-regexp)
(boundp 'woman-file-compression-regexp)
(setq woman-file-regexp
(concat woman-uncompressed-file-regexp
"\\("
(substring woman-file-compression-regexp 0 -2)
"\\)?\\'"))))
(defcustom woman-uncompressed-file-regexp
"\\.\\([0-9lmnt]\\w*\\)" "*Do not change this unless you are sure you know what you are doing!
Regexp used to select man source files (ignoring any compression extension).
The SysV standard man pages use two character suffixes, and this is
becoming more common in the GNU world. For example, the man pages
in the ncurses package include `toe.1m', `form.3x', etc.
Note: an optional compression regexp will be appended, so this regexp
MUST NOT end with any kind of string terminator such as $ or \\'."
:type 'regexp
:set 'set-woman-file-regexp
:group 'woman-interface)
(defcustom woman-file-compression-regexp
"\\.\\(g?z\\|bz2\\)\\'"
"*Do not change this unless you are sure you know what you are doing!
Regexp used to match compressed man file extensions for which
decompressors are available and handled by auto-compression mode,
e.g. \"\\\\.\\\\(g?z\\\\|bz2\\\\)\\\\'\" for `gzip' or `bzip2'.
Should begin with \\. and end with \\' and MUST NOT be optional."
:type 'regexp
:set 'set-woman-file-regexp
:group 'woman-interface)
(defcustom woman-use-own-frame (or (and (fboundp 'display-graphic-p) (display-graphic-p)) (memq window-system '(x w32))) "*If non-nil then use a dedicated frame for displaying WoMan windows.
Only useful when run on a graphic display such as X or MS-Windows."
:type 'boolean
:group 'woman-interface)
(defgroup woman-formatting nil
"Formatting options for browsing UNIX manual pages `wo (without) man'."
:tag "WoMan Formatting"
:group 'woman)
(defcustom woman-fill-column 65
"*Right margin for formatted text -- default is 65."
:type 'integer
:group 'woman-formatting)
(defcustom woman-fill-frame nil
"*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.
Set this variable to 7 to emulate GNU man formatting."
: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."
:type 'boolean
:group 'woman-formatting)
(defcustom woman-emulation 'nroff
"*WoMan emulation, currently either nroff or troff. Default is nroff.
Troff emulation is experimental and largely untested.
\(Add groff later?)"
:type '(choice (const nroff) (const troff))
:group 'woman-formatting)
(defgroup woman-faces nil
"Face options for browsing UNIX manual pages `wo (without) man'."
:tag "WoMan Faces"
:group 'woman
:group 'faces)
(defcustom woman-fontify
(or (and (fboundp 'display-color-p) (display-color-p))
(and (fboundp 'display-graphic-p) (display-graphic-p))
(x-display-color-p))
"*If non-nil then WoMan assumes that face support is available.
It defaults to a non-nil value if the display supports either colors
or different fonts."
:type 'boolean
:group 'woman-faces)
(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)
(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)
(put 'woman-bold-face 'face-alias 'woman-bold)
(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)
(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)
(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))
(defconst woman-font-support
(eq window-system 'w32) "If non-nil then non-ASCII characters and symbol font supported.")
(defun woman-select-symbol-fonts (fonts)
"Select symbol fonts from a list FONTS of font name strings."
(let (symbol-fonts)
(while fonts
(and (string-match "-Symbol-" (car fonts))
(not (member (car fonts) symbol-fonts))
(setq symbol-fonts (cons (car fonts) symbol-fonts)))
(setq fonts (cdr fonts)))
symbol-fonts))
(when woman-font-support
(make-face 'woman-symbol)
(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))
(woman-select-symbol-fonts (x-list-fonts "*")))
"Symbol font(s), preferably same size as default when WoMan was loaded.")
(defcustom woman-symbol-font (car woman-symbol-font-list)
"*A string describing the symbol font to use for special characters.
It should be compatible with, and the same size as, the default text font.
Under MS-Windows, the default is
\"-*-Symbol-normal-r-*-*-*-*-96-96-p-*-ms-symbol\"."
:type `(choice
,@(mapcar (lambda (x) (list 'const x))
woman-symbol-font-list)
string)
:group 'woman-faces)
)
(defvar woman-use-extended-font nil)
(defvar woman-use-symbol-font nil)
(defvar woman-symbol-font nil)
(defconst woman-justify-list
'(left right center full)
"Justify styles for `fill-region-as-paragraph'.")
(defconst woman-adjust-left 0 "Adjustment indicator `l' -- adjust left margin only.")
(defconst woman-adjust-right 1
"Adjustment indicator `r' -- adjust right margin only.")
(defconst woman-adjust-center 2
"Adjustment indicator `c' -- center.")
(defconst woman-adjust-both 3 "Adjustment indicator `b' or `n' -- adjust both margins.")
(defvar woman-adjust woman-adjust-both
"Current adjustment number-register value.")
(defvar woman-adjust-previous woman-adjust
"Previous adjustment number-register value.")
(defvar woman-justify
(nth woman-adjust woman-justify-list) "Current justification style for `fill-region-as-paragraph'.")
(defvar woman-justify-previous woman-justify
"Previous justification style for `fill-region-as-paragraph'.")
(defvar woman-left-margin woman-default-indent
"Current left margin.")
(defvar woman-prevailing-indent woman-default-indent
"Current prevailing indent.")
(defvar woman-interparagraph-distance 1
"Interparagraph distance in lines.
Set by .PD; used by .SH, .SS, .TP, .LP, .PP, .P, .IP, .HP.")
(defvar woman-leave-blank-lines nil
"Blank lines to leave as vertical space.")
(defconst woman-tab-width 5
"Default tab width set by -man macros.")
(defvar woman-nofill nil
"Current fill mode: nil for filling.")
(defvar woman-RS-left-margin nil
"Left margin stack for nested use of `.RS/.RE'.")
(defvar woman-RS-prevailing-indent nil
"Prevailing indent stack for nested use of `.RS/.RE'.")
(defvar woman-nospace nil
"Current no-space mode: nil for normal spacing.
Set by `.ns' request; reset by any output or `.rs' request")
(defsubst woman-reset-nospace ()
"Set `woman-nospace' to nil."
(setq woman-nospace nil))
(defconst woman-request-regexp "^[.'][ \t]*\\(\\S +\\) *"
"Regexp to match a ?roff request plus trailing white space.")
(defvar woman-imenu-done nil
"Buffer-local: set to true if function `woman-imenu' has been called.")
(make-variable-buffer-local 'woman-imenu-done)
(eval-when-compile
(require 'imenu))
(make-variable-buffer-local 'imenu--last-menubar-index-alist)
(defvar woman-buffer-alist nil
"An alist representing WoMan buffers that are already decoded.
Each element is of the form (FILE-NAME . BUFFER-NAME).")
(defvar woman-buffer-number 0
"Ordinal number of current buffer entry in `woman-buffer-alist'.
The ordinal numbers start from 0.")
(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'.")
(defun woman-delete-line (&optional arg)
"Delete rest of current line; if all blank then delete thru newline.
With a numeric argument ARG, delete that many lines from point.
Negative arguments delete lines backward."
(delete-region (point)
(progn
(if arg
(forward-line arg)
(if (eobp)
(signal 'end-of-buffer nil))
(if (looking-at "[ \t]*$")
(forward-line 1)
(end-of-line)))
(point))))
(defsubst woman-delete-whole-line ()
"Delete current line from beginning including eol."
(beginning-of-line)
(woman-delete-line 1))
(defsubst woman-delete-following-space ()
"Delete all spaces and tabs FOLLOWING point (cf. `delete-horizontal-space')."
(delete-region (point) (progn (skip-chars-forward " \t") (point))))
(defsubst woman-delete-match (subexp)
"Delete subexpression SUBEXP of buffer text matched by last search."
(delete-region (match-beginning subexp) (match-end subexp)))
(defvar woman-expanded-directory-path nil
"Expanded directory list cache. Resetting to nil forces update.")
(defvar woman-topic-all-completions nil
"Expanded topic alist cache. Resetting to nil forces update.")
(defun woman (&optional topic re-cache)
"Browse UN*X man page for TOPIC (Without using external Man program).
The major browsing mode used is essentially the standard Man mode.
Choose the filename for the man page using completion, based on the
topic selected from the directories specified in `woman-manpath' and
`woman-path'. The directory expansions and topics are cached for
speed, but a non-nil interactive argument forces the caches to be
updated (e.g. to re-interpret the current directory).
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))
(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")
(ding))
)
(message "WoMan Error: No topic specified in non-interactive call")
(ding))
)
(define-key-after menu-bar-manuals-menu [woman]
'(menu-item "Read Man Page (WoMan)..." woman
:help "Man-page documentation Without Man") t)
(defvar woman-cached-data nil
"A list of cached data used to determine cache validity.
Set from the cache by `woman-read-directory-cache'.")
(defun woman-cached-data ()
"Generate a list of data used to determine cache validity.
Called both to generate and to check the cache!"
(list woman-cache-level
(let (lst path)
(dolist (dir woman-manpath (nreverse lst))
(when (consp dir)
(unless path
(setq path
(split-string (getenv "PATH") path-separator t)))
(setq dir (and (member (car dir) path) (cdr dir))))
(when dir (add-to-list 'lst (substitute-in-file-name dir)))))
(mapcar 'substitute-in-file-name woman-path)))
(defun woman-read-directory-cache ()
"Load the directory and topic cache.
It is loaded from the file named by the variable `woman-cache-filename'.
Return t if the file exists, nil otherwise."
(and
woman-cache-filename
(load woman-cache-filename t nil t) (equal woman-cached-data (woman-cached-data))))
(defun woman-write-directory-cache ()
"Save the directory and topic cache.
It is saved to the file named by the variable `woman-cache-filename'."
(if woman-cache-filename
(save-excursion (let ((standard-output
(set-buffer (generate-new-buffer "WoMan tmp buffer")))
(backup-inhibited t))
(buffer-disable-undo standard-output)
(princ
";;; WoMan directory and topic cache -- generated automatically\n")
(print
`(setq woman-cached-data ',(woman-cached-data)))
(print
`(setq woman-expanded-directory-path
',woman-expanded-directory-path))
(print
`(setq woman-topic-all-completions
',woman-topic-all-completions))
(write-file woman-cache-filename) (kill-buffer standard-output)
))))
(defvaralias 'woman-topic-history 'Man-topic-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."
(if (and (not re-cache)
(or
(and woman-expanded-directory-path woman-topic-all-completions)
(woman-read-directory-cache)))
()
(message "Building list of manual directory expansions...")
(setq woman-expanded-directory-path
(woman-expand-directory-path woman-manpath woman-path))
(message "Building completion list of all manual topics...")
(setq woman-topic-all-completions
(woman-topic-all-completions woman-expanded-directory-path))
(woman-write-directory-cache))
(let (files
(default (current-word)))
(or (stringp topic)
(and (if (boundp 'woman-use-topic-at-point)
woman-use-topic-at-point
(setq woman-use-topic-at-point woman-use-topic-at-point-default))
(setq topic (or (current-word t) "")) (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))))
(if (= (length topic) 0)
nil (cond
((setq files (woman-file-name-all-completions topic)))
((setq files (all-completions topic woman-topic-all-completions))
(while (/= (length topic) (length (car files)))
(setq files (cdr files)))
(setq files (woman-file-name-all-completions (car files)))))
(cond
((null files) nil) ((null (cdr files)) (car (car files))) (t
(setq unread-command-events '(9)) (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.)"
(while (and list
(or
(member (car list) (cdr list))
(not (funcall predicate (car list)))))
(setq list (cdr list)))
(if list
(let ((newlist list) cdr_list)
(while (setq cdr_list (cdr list))
(if (and
(not (member (car cdr_list) (cdr cdr_list)))
(funcall predicate (car cdr_list)))
(setq list cdr_list)
(setcdr list (cdr cdr_list)))
)
newlist)))
(defun woman-file-readable-p (dir)
"Return t if DIR is readable, otherwise log a warning."
(or (file-readable-p dir)
(WoMan-warn "Ignoring unreadable `manpath' directory tree `%s'!" dir)))
(defun woman-directory-files (head dir)
"Return a sorted list of files in directory HEAD matching regexp in DIR.
Value is a sorted list of the absolute pathnames of all the files in
directory HEAD, or the current directory if HEAD is nil, that match the
regexp that is the final component of DIR. Log a warning if list is empty."
(or (directory-files
(or head (directory-file-name default-directory)) t
(file-name-nondirectory dir))
(WoMan-warn "No directories match `woman-path' entry `%s'!" dir)))
(defun woman-file-accessible-directory-p (dir)
"Return t if DIR is accessible, otherwise log a warning."
(or (file-accessible-directory-p dir)
(WoMan-warn "Ignoring inaccessible `man-page' directory `%s'!" dir)))
(defun woman-expand-directory-path (woman-manpath woman-path)
"Expand the manual directories in WOMAN-MANPATH and WOMAN-PATH.
WOMAN-MANPATH should be a list of general manual directories, while
WOMAN-PATH should be a list of specific manual directory regexps.
Ignore any paths that are unreadable or not directories."
(if (not (listp woman-manpath)) (setq woman-manpath (list woman-manpath)))
(if (not (listp woman-path)) (setq woman-path (list woman-path)))
(let (dir head dirs path)
(while woman-manpath
(setq dir (car woman-manpath)
woman-manpath (cdr woman-manpath))
(when (consp dir)
(unless path
(setq path (split-string (getenv "PATH") path-separator t)))
(setq dir (and (member (car dir) path)
(cdr dir))))
(if (and dir (woman-file-readable-p dir))
(setq dir (woman-canonicalize-dir dir)
dirs (nconc dirs (directory-files
dir t woman-manpath-man-regexp)))))
(while woman-path
(setq dir (car woman-path)
woman-path (cdr woman-path))
(if (or (null dir)
(null (setq dir (woman-canonicalize-dir dir)
head (file-name-directory dir)))
(woman-file-readable-p head))
(setq dirs
(if dir
(nconc dirs (woman-directory-files head dir))
(cons (directory-file-name default-directory) dirs))
)))
(woman-select 'woman-file-accessible-directory-p dirs)))
(defun woman-canonicalize-dir (dir)
"Canonicalize the directory name DIR.
Any UN*X-style environment variables are evaluated first."
(setq dir (expand-file-name (substitute-in-file-name dir)))
(if (string= (substring dir -1) "/")
(setq dir (substring dir 0 -1)))
(if (memq system-type '(windows-nt ms-dos cygwin)) (setq dir (concat (file-name-directory dir)
(file-name-nondirectory dir))))
dir)
(defsubst woman-not-member (dir path)
"Return t if DIR is not a member of the list PATH, nil otherwise.
If DIR is `.' it is first replaced by the current directory."
(not (member dir path)))
(defun woman-topic-all-completions (path)
"Return an alist of the man files in all man directories in the list PATH.
The cdr of each alist element is the path-index / filename."
(let (dir files (path-index 0)) (while path
(setq dir (pop path))
(if (woman-not-member dir path) (push (woman-topic-all-completions-1 dir path-index)
files))
(setq path-index (1+ path-index)))
(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
of the first `woman-cache-level' elements from the following list:
\(topic path-index filename)."
(let (newlst (lst (directory-files dir nil woman-file-regexp t))
(ext (format "\\(\\.[^.\\/]*\\)?\\(%s\\)?\\'"
woman-file-compression-regexp)))
(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.)"
(let (elt newalist)
(setq alist (sort alist (lambda(x y) (string< (car y) (car x)))))
(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)))
(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."
(let ((topic-regexp
(concat
"\\`" (regexp-quote topic) "\\(\\..+\\)*" woman-file-regexp)) (topics woman-topic-all-completions)
(path woman-expanded-directory-path)
dir files)
(if (cdr (car topics))
(let ((path-info (cdr (assoc topic topics)))
filename)
(while path-info
(setq dir (nth (car (car path-info)) path)
filename (car (cdr (car path-info)))
path-info (cdr path-info)
files (nconc files
(if filename
(list (concat dir "/" filename))
(directory-files dir t topic-regexp)
)))))
(while path
(setq dir (car path)
path (cdr path))
(if (woman-not-member dir path) (setq files (nconc files
(directory-files dir t topic-regexp))))
))
(mapcar 'list files)
))
(defun woman-dired-define-key (key)
"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
(if (listp woman-dired-keys)
(mapcar 'woman-dired-define-key woman-dired-keys)
(woman-dired-define-key-maybe "w")
(woman-dired-define-key-maybe "W")))
(define-key-after (lookup-key dired-mode-map [menu-bar immediate])
[woman] '("Read Man Page (WoMan)" . woman-dired-find-file) 'view))
(if (featurep 'dired)
(woman-dired-define-keys)
(add-hook 'dired-mode-hook 'woman-dired-define-keys))
(defun woman-dired-find-file ()
"In dired, run the WoMan man-page browser on this file."
(interactive)
(woman-find-file (dired-get-filename)))
(defun woman-tar-extract-file ()
"In tar mode, run the WoMan man-page browser on this file."
(interactive)
(or (eq major-mode 'tar-mode)
(error "`woman-tar-extract-file' can be used only in `tar-mode'"))
(buffer-disable-undo)
(let (global-font-lock-mode)
(funcall (symbol-function 'tar-extract)) (let ((WoMan-current-file buffer-file-name)) (rename-buffer
(woman-make-bufname (file-name-nondirectory buffer-file-name)))
(woman-process-buffer)
(goto-char (point-min)))))
(eval-after-load "tar-mode"
'(progn
(define-key tar-mode-map "w" 'woman-tar-extract-file)
(define-key-after (lookup-key tar-mode-map [menu-bar immediate])
[woman] '("Read Man Page (WoMan)" . woman-tar-extract-file) 'view)))
(defvar woman-last-file-name nil
"The full pathname of the last file formatted by WoMan.")
(defun woman-reformat-last-file ()
"Reformat last file, e.g. after changing fill column."
(interactive)
(if woman-last-file-name
(woman-find-file woman-last-file-name t)
(call-interactively 'woman-find-file)))
(defun woman-find-file (file-name &optional reformat)
"Find, decode and browse a specific UN*X man-page source file FILE-NAME.
Use existing buffer if possible; reformat only if prefix arg given.
When called interactively, optional argument REFORMAT forces reformatting
of an existing WoMan buffer formatted earlier.
No external programs are used, except that `gunzip' will be used to
decompress the file if appropriate. See the documentation for the
`woman' command for further details."
(interactive "fBrowse UN*X manual file: \nP")
(setq woman-last-file-name
(setq file-name (expand-file-name file-name))) (let ((alist-tail woman-buffer-alist) exists)
(setq woman-buffer-number 0)
(while (and alist-tail (not (string= file-name (car (car alist-tail)))))
(setq alist-tail (cdr alist-tail)
woman-buffer-number (1+ woman-buffer-number)))
(or (and (setq exists
(and alist-tail (WoMan-find-buffer))) (not reformat))
(let* ((bufname (file-name-nondirectory file-name))
(case-fold-search t)
(compressed
(not (not (string-match woman-file-compression-regexp bufname)))))
(if compressed
(setq bufname (file-name-sans-extension bufname)))
(setq bufname (if exists
(buffer-name)
(woman-make-bufname bufname)))
(woman-really-find-file file-name compressed bufname)
(or exists
(setq woman-buffer-alist
(cons (cons file-name bufname) woman-buffer-alist)
woman-buffer-number 0))
)))
(Man-build-section-alist)
(Man-build-references-alist)
(goto-char (point-min)))
(defun woman-make-bufname (bufname)
"Create an unambiguous buffer name from BUFNAME."
(let ((dot (string-match "\\." bufname)))
(if dot (setq bufname (concat
(substring bufname (1+ dot)) " "
(substring bufname 0 dot))))
(generate-new-buffer-name (concat "*WoMan " bufname "*"))))
(defvar woman-frame nil
"Dedicated frame used for displaying WoMan windows.")
(defun woman-really-find-file (filename compressed bufname)
"Find, decompress, and decode a UN*X man page FILENAME.
If COMPRESSED is non-nil, turn on auto-compression mode to decompress
the file if necessary. Set buffer name BUFNAME and major mode.
Do not call directly!"
(let ((WoMan-current-file filename)) (if woman-use-own-frame
(select-frame
(or (and (frame-live-p woman-frame) woman-frame)
(setq woman-frame (make-frame)))))
(switch-to-buffer (get-buffer-create bufname))
(buffer-disable-undo)
(setq buffer-read-only nil)
(erase-buffer) (woman-insert-file-contents filename compressed)
(setq default-directory (file-name-directory filename))
(set (make-local-variable 'backup-inhibited) t)
(set-visited-file-name "")
(woman-process-buffer)))
(defun woman-process-buffer ()
"The second half of `woman-really-find-file'!"
(interactive)
(goto-char (point-min))
(if (re-search-forward "^[.']" 1000 t)
(woman-decode-buffer)
(message
"File appears to be pre-formatted -- using source file may be better.")
(woman-man-buffer))
(woman-mode))
(defun woman-man-buffer ()
"Post-process an nroff-preformatted man buffer."
(if (looking-at "\\s-+") (woman-delete-match 0))
(re-search-forward ".*") (let ((regex (concat
"^.*[0-9]\n\\s-*" (regexp-quote (match-string 0)) "\\s-*\n"))) (while (re-search-forward regex nil 1) (woman-delete-match 0)))
(re-search-backward "\\S-")
(beginning-of-line)
(if (looking-at ".*[0-9]$")
(delete-region (point) (point-max)))
(goto-char (point-min))
(while (re-search-forward "^[ \t]*\n\\([ \t]*\n\\)+" nil t)
(replace-match "\n" t t))
(if (< (buffer-size) (position-bytes (point-max)))
(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))))
(goto-char (point-min))
(while (re-search-forward "\\(.\\)\\(\\(+\\1\\)+\\)" nil t)
(woman-delete-match 2)
(woman-set-face (1- (point)) (point) 'woman-bold))
(goto-char (point-min))
(while (search-forward "_" nil t)
(delete-char -2)
(woman-set-face (point) (1+ (point)) 'woman-italic))
(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,
then turn on auto-compression mode to decompress the file.
Leave point at end of new text. Return length of inserted text."
(save-excursion
(let ((case-fold-search t))
(if (and compressed
(or (eq compressed t)
(string-match woman-file-compression-regexp filename))
(not (rassq 'jka-compr-handler file-name-handler-alist)) )
(auto-compression-mode 1))
(nth 1
(condition-case ()
(insert-file-contents filename nil)
(file-error
(insert "\n***** File " filename " not found! *****\n\n")
)))
)))
(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)
(define-key woman-mode-map [remap man] 'woman)
(define-key woman-mode-map [remap man-follow] 'woman-follow))
(defun woman-follow (topic)
"Get a Un*x manual page of the item under point and put it in a buffer."
(interactive (list (Man-default-man-entry)))
(if (or (not topic)
(string= topic ""))
(error "No item under point")
(woman (if (string-match Man-reference-regexp topic)
(substring topic 0 (match-end 1))
topic))))
(defun woman-follow-word (event)
"Run WoMan with word under mouse as topic.
Argument EVENT is the invoking mouse event."
(interactive "e") (goto-char (posn-point (event-start event)))
(woman (or (current-word t) "")))
(easy-menu-define
woman-menu woman-mode-map
"WoMan Menu"
`("WoMan"
["WoMan..." woman t] "--"
["Next Section" Man-next-section t]
["Previous Section" Man-previous-section t]
["Goto Section..." Man-goto-section t]
["Goto See-Also Section" Man-goto-see-also-section t]
["Follow Reference..." Man-follow-manual-reference t]
"--"
["Previous WoMan Buffer" WoMan-previous-manpage t]
["Next WoMan Buffer" WoMan-next-manpage t]
["Bury WoMan Buffer" Man-quit t]
["Kill WoMan Buffer" Man-kill t]
"--"
["Use Full Frame Width" woman-toggle-fill-frame
:active t :style toggle :selected woman-fill-frame]
["Reformat Last Man Page" woman-reformat-last-file t]
["Use Monochrome Main Faces" woman-monochrome-faces t]
["Use Default Main Faces" woman-default-faces t]
["Make Contents Menu" (woman-imenu t) (not woman-imenu-done)]
"--"
["Describe (Wo)Man Mode" describe-mode t]
["Mini Help" woman-mini-help t]
,@(if (fboundp 'customize-group)
'(["Customize..." (customize-group 'woman) t]))
["Show Version" (message "WoMan %s" woman-version) t]
"--"
("Advanced"
["View Source" (view-file woman-last-file-name) woman-last-file-name]
["Show Log" (switch-to-buffer-other-window "*WoMan-Log*" t) t]
["Extended Font" woman-toggle-use-extended-font
:included woman-font-support
:active t :style toggle :selected woman-use-extended-font]
["Symbol Font" woman-toggle-use-symbol-font
:included woman-font-support
:active t :style toggle :selected woman-use-symbol-font]
["Font Map" woman-display-extended-fonts
:included woman-font-support
:active woman-use-symbol-font]
"--"
"Emulation"
["nroff" (woman-reset-emulation 'nroff)
:active t :style radio :selected (eq woman-emulation 'nroff)]
["troff" (woman-reset-emulation 'troff)
:active t :style radio :selected (eq woman-emulation 'troff)]
)
))
(defun woman-toggle-use-extended-font ()
"Toggle `woman-use-extended-font' and reformat, for menu use."
(interactive)
(setq woman-use-extended-font (not woman-use-extended-font))
(woman-reformat-last-file))
(defun woman-toggle-use-symbol-font ()
"Toggle `woman-use-symbol-font' and reformat, for menu use."
(interactive)
(setq woman-use-symbol-font (not woman-use-symbol-font))
(woman-reformat-last-file))
(defun woman-reset-emulation (value)
"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: F.J.Wright@Maths.QMW.ac.uk
WoMan version: see `woman-version'.
See `Man-mode' for additional details."
(let ((Man-build-page-list (symbol-function 'Man-build-page-list))
(Man-strip-page-headers (symbol-function 'Man-strip-page-headers))
(Man-unindent (symbol-function 'Man-unindent))
(Man-goto-page (symbol-function 'Man-goto-page)))
(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))
(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")
(kill-local-variable 'mode-line-buffer-identification)
(use-local-map woman-mode-map)
(set (make-local-variable 'imenu-generic-expression)
woman-imenu-generic-expression)
(set (make-local-variable 'imenu-space-replacement) " ")
(setq imenu--last-menubar-index-alist nil)
(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)
(if woman-imenu-done
()
(setq woman-imenu-done t)
(imenu-add-to-menubar woman-imenu-title)
(if redraw (force-mode-line-update))))
(defun woman-toggle-fill-frame ()
"Toggle formatting to fill (most of) the width of the current frame."
(interactive)
(setq woman-fill-frame (not woman-fill-frame))
(message "Woman fill column set to %s."
(if woman-fill-frame "frame width" woman-fill-column)
))
(defun woman-mini-help ()
"Display WoMan commands and user options in an `apropos' buffer."
(interactive)
(require 'apropos)
(let ((message
(let ((standard-output (get-buffer-create "*Apropos*")))
(print-help-return-message 'identity))))
(setq apropos-accumulator
(apropos-internal "woman"
(lambda (symbol)
(or (commandp symbol)
(user-variable-p symbol)))))
(let ((tem apropos-accumulator))
(while tem
(if (get (car tem) 'apropos-inhibit)
(setq apropos-accumulator (delq (car tem) apropos-accumulator)))
(setq tem (cdr tem))))
(let ((p apropos-accumulator)
doc symbol)
(while p
(setcar p (list (setq symbol (car p)) (if (functionp symbol) (if (setq doc (documentation symbol t))
(substring doc 0 (string-match "\n" doc))
"(not documented)"))
(if (user-variable-p symbol) (if (setq doc (documentation-property
symbol 'variable-documentation t))
(substring doc 0 (string-match "\n" doc))))))
(setq p (cdr p))))
(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'."
(let ((s (string-match " " topic)))
(if s (setq topic (substring topic (1+ s))))
(woman topic)))
(defvar WoMan-Man-start-time nil
"Used to record formatting time used by the `man' command.")
(defun WoMan-previous-manpage ()
"Find the previous WoMan buffer."
(interactive)
(WoMan-find-buffer) (if (null (cdr woman-buffer-alist))
(error "No previous WoMan buffer"))
(if (>= (setq woman-buffer-number (1+ woman-buffer-number))
(length woman-buffer-alist))
(setq woman-buffer-number 0))
(if (WoMan-find-buffer)
()
(if (< (setq woman-buffer-number (1- woman-buffer-number)) 0)
(setq woman-buffer-number (1- (length woman-buffer-alist))))
(WoMan-previous-manpage)))
(defun WoMan-next-manpage ()
"Find the next WoMan buffer."
(interactive)
(WoMan-find-buffer) (if (null (cdr woman-buffer-alist))
(error "No next WoMan buffer"))
(if (< (setq woman-buffer-number (1- woman-buffer-number)) 0)
(setq woman-buffer-number (1- (length woman-buffer-alist))))
(if (WoMan-find-buffer)
()
(WoMan-next-manpage)))
(defun WoMan-find-buffer ()
"Switch to buffer corresponding to `woman-buffer-number' and return it.
If such a buffer does not exist then remove its association from the
alist in `woman-buffer-alist' and return nil."
(if (zerop woman-buffer-number)
(let ((buffer (get-buffer (cdr (car woman-buffer-alist)))))
(if buffer
(switch-to-buffer buffer)
(setq woman-buffer-alist (cdr woman-buffer-alist))
nil))
(let* ((prev-ptr (nthcdr (1- woman-buffer-number) woman-buffer-alist))
(buffer (get-buffer (cdr (car (cdr prev-ptr))))))
(if buffer
(switch-to-buffer buffer)
(setcdr prev-ptr (cdr (cdr prev-ptr)))
(if (>= woman-buffer-number (length woman-buffer-alist))
(setq woman-buffer-number 0))
nil)
)))
(defconst woman-escaped-escape-char ?
"Internal character representation of escaped escape characters.")
(defconst woman-escaped-escape-string
(char-to-string woman-escaped-escape-char)
"Internal string representation of escaped escape characters.")
(defconst woman-unpadded-space-char ?
"Internal character representation of unpadded space characters.")
(defconst woman-unpadded-space-string
(char-to-string woman-unpadded-space-char)
"Internal string representation of unpadded space characters.")
(defvar woman-syntax-table nil
"Syntax table to support special characters used internally by WoMan.")
(if woman-syntax-table
()
(setq woman-syntax-table (make-syntax-table))
(modify-syntax-entry woman-unpadded-space-char "." woman-syntax-table)
(modify-syntax-entry woman-escaped-escape-char "." woman-syntax-table)
)
(defun woman-set-buffer-display-table ()
"Set up a display table for a WoMan buffer.
This display table is used for displaying internal special characters, but
does not interfere with any existing display table, e.g. for displaying
European characters."
(setq buffer-display-table
(if standard-display-table (copy-sequence standard-display-table)
(make-display-table)))
(aset buffer-display-table woman-unpadded-space-char [?\ ])
(aset buffer-display-table woman-escaped-escape-char [?\\]))
(defvar font-lock-mode)
(defun woman-decode-buffer ()
"Decode a buffer in UN*X man-page source format.
No external programs are used."
(interactive) (WoMan-log-begin)
(run-hooks 'woman-pre-format-hook)
(and (boundp 'font-lock-mode) font-lock-mode (font-lock-mode -1))
(let ((start-time (current-time)) time) (message "WoMan formatting buffer...")
(woman-decode-region (point-min) (point-max))
(setq time (current-time)
time (+ (* (- (car time) (car start-time)) 65536)
(- (cadr time) (cadr start-time))))
(message "WoMan formatting buffer...done in %d seconds" time)
(WoMan-log-end time))
(run-hooks 'woman-post-format-hook))
(defvar woman-string-alist '(("S" . "") ("R" . "(Reg.)") ("Tm" . "(TM)")
("lq" . "\"") ("rq" . "\"")
("''" . "\"") (".T" . "") )
"Alist of strings predefined in the -man macro package `tmac.an'.")
(defvar woman-negative-vertical-space nil "Set to t if .sp N with N < 0 encountered.")
(defun woman-pre-process-region (from to)
"Pre-process escapes and comments in the region of text between FROM and TO.
To be called on original buffer and any .so insertions."
(goto-char from)
(while (re-search-forward "\\(\\\\[\\e]\\)\\|^\\.eo" to t) (if (match-string 1)
(replace-match woman-escaped-escape-string t t)
(woman-delete-whole-line)
(while (and (re-search-forward "\\(\\\\\\)\\|^\\.ec" to t) (match-string 1))
(replace-match woman-escaped-escape-string t t))
(woman-delete-whole-line)))
(goto-char from)
(while (re-search-forward "^[.'][ \t]*\\(\\\\\".*\\)?\n\\|\\\\\".*" to t)
(woman-delete-match 0)))
(defun woman-non-underline-faces ()
"Prepare non-underlined versions of underlined faces."
(let ((face-list (face-list)))
(while face-list
(let* ((face (car face-list))
(face-name (symbol-name face)))
(if (and (string-match "\\`woman-" face-name)
(face-underline-p face))
(let ((face-no-ul (intern (concat face-name "-no-ul"))))
(copy-face face face-no-ul)
(set-face-underline-p face-no-ul nil))))
(setq face-list (cdr face-list)))))
(defvar woman-emulate-tbl nil
"True if WoMan should emulate the tbl preprocessor.
This applies to text between .TE and .TS directives.
Currently set only from '\" t in the first line of the source file.")
(defun woman-decode-region (from to)
"Decode the region between FROM and TO in UN*X man-page source format."
(let ((case-fold-search nil) (woman-string-alist woman-string-alist)
(woman-fill-column woman-fill-column)
woman-negative-vertical-space)
(setq woman-left-margin woman-default-indent
woman-prevailing-indent woman-default-indent
woman-interparagraph-distance 1
woman-leave-blank-lines nil
woman-RS-left-margin nil
woman-RS-prevailing-indent nil
woman-adjust woman-adjust-both
woman-justify (nth woman-adjust woman-justify-list)
woman-nofill nil)
(setq woman-if-conditions-true
(cons (string-to-char (symbol-name woman-emulation)) '(?e ?o)))
(woman-non-underline-faces)
(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-table woman-syntax-table)
(woman-set-buffer-display-table)
(if (or woman-fill-frame
(not (and (integerp woman-fill-column) (> woman-fill-column 0))))
(setq woman-fill-column (- (window-width) woman-default-indent)))
(goto-char from)
(if (looking-at "'\\\\\"[ \t]*\\([a-z]+\\)")
(let ((letters (append (match-string 1) nil)))
(if (memq ?t letters)
(setq woman-emulate-tbl t
letters (delete ?t letters)))
(if letters
(WoMan-warn "Unhandled preprocessor request letters %s"
(concat letters)))
(woman-delete-line 1)))
(woman-pre-process-region from nil)
(woman0-roff-buffer from)
(goto-char (point-min))
(let ((case-fold-search nil))
(unless (and (re-search-forward "^\\.SH[ \n]" (point-max) t)
(progn (goto-char (point-min))
(re-search-forward "^\\.TH[ \n]" (point-max) t))
(progn (goto-char (point-min))
(not (re-search-forward "^\\.\\([pnil]p\\|sh\\)[ \n]"
(point-max) t))))
(error "WoMan can only format man pages written with the usual `-man' macros")))
(goto-char from)
(woman-mark-horizonal-position)
(setq fill-column woman-fill-column
tab-width woman-tab-width)
(goto-char from)
(while (re-search-forward "\\\\[ 0]" nil t)
(replace-match woman-unpadded-space-string t t))
(goto-char from)
(while (re-search-forward "\\\\\\([%\n]\\|s[-+]?[0-9]+\\)" nil t)
(woman-delete-match 0))
(goto-char from)
(while (re-search-forward "\\\\\\([-`.]\\)" nil t)
(replace-match "\\1"))
(goto-char from)
(woman1-roff-buffer)
(goto-char from)
(woman-strings)
(goto-char from)
(woman-change-fonts)
(goto-char from)
(let ((first t)) (while (re-search-forward "\\\\\\([du]\\|v'[^']*'\\)" nil t)
(let* ((esc (match-string 1))
(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
(woman-delete-match 0)
(WoMan-warn
"Terminal vertical motion escape \\%s ignored!" esc)))
(setq first (not first))
)))
(goto-char from)
(woman2-roff-buffer)
(if woman-negative-vertical-space
(woman-negative-vertical-space from))
(if woman-preserve-ascii
(progn
(goto-char from)
(while (search-forward woman-escaped-escape-string nil t)
(delete-char -1) (insert ?\\))
(goto-char from)
(while (search-forward woman-unpadded-space-string nil t)
(delete-char -1) (insert ?\ ))
))
(point-max)))
(defun woman-horizontal-escapes (to)
"Process \\h'+/-N' local horizontal motion escapes upto TO.
Implements arbitrary forward and non-overlapping backward motion.
Preserves location of `point'."
(let ((from (point)))
(while (re-search-forward
"\\\\h\\(\\\\(..\\|.\\)\\(|\\)?"
to t)
(let ((from (match-beginning 0))
(delim (regexp-quote (match-string 1)))
(absolute (match-string 2)) (N (woman-parse-numeric-arg)) to
msg) (if (not (looking-at delim))
(WoMan-warn
"Local horizontal motion (%s) delimiter error!"
(buffer-substring from (1+ (point)))) (setq to (match-end 0)
msg (buffer-substring from to))
(delete-region from to)
(if absolute (setq N (- N (current-column))))
(if (>= N 0)
(insert-char woman-unpadded-space-char N)
(while (and
(<= (setq N (1+ N)) 0)
(cond ((memq (preceding-char) '(?\ ?\t))
(delete-backward-char 1) t)
((memq (following-char) '(?\ ?\t))
(delete-char 1) t)
(t nil))))
(if (<= N 0)
(WoMan-warn
"Negative horizontal motion (%s) would overwrite!" msg))))
))
(goto-char from)))
(defvar woman0-if-to) (defvar woman0-macro-alist) (defvar woman0-search-regex) (defvar woman0-search-regex-start "^[.'][ \t]*\\(ig\\|if\\|ie\\|el\\|so\\|rn\\|de\\|am")
(defconst woman0-search-regex-end "\\)\\([ \t]+\\|$\\)")
(defvar woman0-rename-alist)
(defun woman0-roff-buffer (from)
"Process conditional-type requests and user-defined macros.
Start at FROM and re-scan new text as appropriate."
(goto-char from)
(let ((woman0-if-to (make-marker))
request woman0-macro-alist
(woman0-search-regex-start woman0-search-regex-start)
(woman0-search-regex
(concat woman0-search-regex-start woman0-search-regex-end))
woman0-rename-alist)
(set-marker-insertion-type woman0-if-to t)
(while (re-search-forward woman0-search-regex nil t)
(setq request (match-string 1))
(cond ((string= request "ig") (woman0-ig))
((string= request "if") (woman0-if "if"))
((string= request "ie") (woman0-if "ie"))
((string= request "el") (woman0-el))
((string= request "so") (woman0-so))
((string= request "rn") (woman0-rn))
((string= request "de") (woman0-de))
((string= request "am") (woman0-de 'append))
(t (woman0-macro request))))
(set-marker woman0-if-to nil)
(woman0-rename)
))
(defun woman0-ig ()
".ig yy -- Discard input up to `.yy', which defaults to `..')."
(looking-at "\\(\\S +\\)?")
(beginning-of-line)
(let ((yy (or (match-string 1) "."))
(from (point)))
(if (re-search-forward
(concat "^\\.[ \t]*" (regexp-quote yy) ".*\n") nil t)
(delete-region from (point))
(WoMan-warn
"ig request ignored -- terminator `.%s' not found!" yy)
(woman-delete-line 1))
))
(defsubst woman0-process-escapes (from to)
"Process escapes within an if/ie condition between FROM and TO."
(woman-strings to)
(goto-char from) (while (re-search-forward "\\\\f\\(\\[[^]]+\\]\\|(..\\|.\\)" to t)
(woman-delete-match 0))
(goto-char from) (woman2-process-escapes to 'numeric))
(defun woman0-if (request)
".if/ie c anything -- Discard unless c evaluates to true.
Remember condition for use by a subsequent `.el'.
REQUEST is the invoking directive without the leading dot."
(woman-delete-match 0)
(let ((from (point)) negated n (c 0))
(set-marker woman0-if-to
(save-excursion (skip-syntax-forward "^ ") (point)))
(if (setq negated (= (following-char) ?!)) (delete-char 1))
(cond
((looking-at "[ntoe]")
(setq c (memq (following-char) woman-if-conditions-true)))
((looking-at "[A-Za-z]") (setq c nil)
(WoMan-warn "%s %s -- unrecognized condition name rejected!"
request (match-string 0)))
((save-restriction
(narrow-to-region from woman0-if-to)
(looking-at "\\(\\\\(..\\|[^0-9]\\)\\(.*\\)\\1\\(.*\\)\\1\\'"))
(let ((end1 (copy-marker (match-end 2) t))) (delete-region (match-end 3) woman0-if-to)
(delete-region (match-end 2) (match-beginning 3))
(goto-char (match-end 1))
(woman0-process-escapes (point) woman0-if-to)
(setq c (string= (buffer-substring (point) end1)
(buffer-substring end1 woman0-if-to)))
(set-marker end1 nil)
(goto-char from)))
((numberp (setq n (progn
(woman0-process-escapes from woman0-if-to)
(woman-parse-numeric-arg))))
(setq c (> n 0))
(goto-char from))
)
(if (eq c 0)
(woman-if-ignore woman0-if-to request) (woman-if-body request woman0-if-to (eq c negated)))
))
(defun woman-if-body (request to delete) "Process if-body, including \\{ ... \\}.
REQUEST is the invoking directive without the leading dot.
If TO is non-nil then delete the if-body.
If DELETE is non-nil then delete from point."
(let ((from (point)))
(if to (delete-region (point) to))
(delete-horizontal-space)
(cond ( (looking-at "[^{\n]*\\(\\\\\n\\)*\\\\{\\s *\\(\\\\\n\\)*") (let ((from (point)))
(woman-delete-match 0)
(while
(and (re-search-forward
"\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*")
(match-string 1))
(re-search-forward "\\\\}"))
(delete-region (if delete from (match-beginning 0)) (point))
(if (looking-at "^$") (delete-char 1))
))
(delete (woman-delete-line 1)) )
(cond ((string= request "ie")
(cond ((re-search-forward "^[.'][ \t]*el[ \t]*" nil t)
(woman-delete-match 0)
(woman-if-body "el" nil (not delete)))))
((string= request "el")
(cond ((re-search-forward "^[.'][ \t]*el[ \t]*" nil t)
(woman-delete-match 0)
(woman-if-body "el" nil t))))
)
(goto-char from)
))
(defun woman0-el ()
"Isolated .el request -- should not happen!"
(WoMan-warn "el request without matching `ie' rejected!")
(cond (woman-ignore
(woman-delete-match 0)
(delete-horizontal-space)
(woman-if-body "el" nil t))
(t (skip-chars-forward "^ \t")
(if (looking-at "[ \t]*\\{") (search-forward "\\}"))
(forward-line 1))))
(defun woman-if-ignore (to request)
"Ignore but warn about an if request ending at TO, named REQUEST."
(WoMan-warn-ignored request "ignored -- condition not handled!")
(if woman-ignore
(woman-if-body request to t)
(skip-chars-forward "^ \t")
(if (looking-at "[ \t]*\\{") (search-forward "\\}"))
(forward-line 1)))
(defun woman0-so ()
".so filename -- Switch source file. `.so' requests may be nested."
(let* ((beg (point))
(end (progn (woman-forward-arg 'unquote) (point)))
(name (buffer-substring beg end))
(filename name))
(or (file-exists-p filename)
(file-exists-p
(setq filename (concat "../" name)))
(setq filename
(woman-file-name
(file-name-sans-extension
(file-name-nondirectory name))))
(kill-buffer (current-buffer))
(error "File `%s' not found" name))
(beginning-of-line)
(woman-delete-line 1)
(let* ((from (point))
(length (woman-insert-file-contents filename 0))
(to (copy-marker (+ from length) t)))
(woman-pre-process-region from to)
(set-marker to nil)
(goto-char from)
)))
(defun woman0-rn ()
"Process .rn xx yy -- rename macro xx to yy."
(if (eolp) ()
(let* ((beg (point))
(end (progn (woman-forward-arg 'unquote 'concat) (point)))
(old (buffer-substring beg end))
new)
(if (eolp) ()
(setq beg (point)
end (progn (woman-forward-arg 'unquote) (point))
new (buffer-substring beg end)
woman0-rename-alist (cons (cons new old) woman0-rename-alist)))
))
(woman-delete-whole-line))
(defun woman0-rename ()
"Effect renaming required by .rn requests."
(while woman0-rename-alist
(let* ((new (car woman0-rename-alist))
(old (cdr new))
(new (car new)))
(setq woman0-rename-alist (cdr woman0-rename-alist))
(goto-char (point-min))
(setq new (concat "^[.'][ \t]*" (regexp-quote new)))
(setq old (concat "." old))
(while (re-search-forward new nil t)
(replace-match old nil t)))))
(defconst woman-unescape-regex
(concat woman-escaped-escape-string
"\\(" woman-escaped-escape-string "\\)?"))
(defsubst woman-unescape (macro)
"Replace escape sequences in the body of MACRO.
Replaces || by |, but | by \, where | denotes the internal escape."
(let (start)
(while (setq start (string-match woman-unescape-regex macro start))
(setq macro
(if (match-string 1 macro)
(replace-match "" t t macro 1)
(replace-match "\\" t t macro))
start (1+ start)))
macro))
(defun woman0-de (&optional append)
"Process .de/am xx yy -- (re)define/append macro xx; end at `..'.
\(Should be up to call of yy, which defaults to `.')
Optional argument APPEND, if non-nil, means append macro."
(if (eolp) ()
(looking-at "[^ \t\n]+") (let* ((macro (match-string 0)) from
(previous (assoc macro woman0-macro-alist)))
(if (not previous)
(setq woman0-search-regex-start
(concat woman0-search-regex-start "\\|" (regexp-quote macro))
woman0-search-regex
(concat woman0-search-regex-start woman0-search-regex-end)
))
(forward-line)
(setq from (point))
(re-search-forward "^\\.[ \t]*\\.")
(beginning-of-line)
(let ((body (woman-unescape (buffer-substring from (point)))))
(if (and append previous)
(setq previous (cdr previous)
body (concat body (cdr previous))
append (car previous)
))
(setq macro (cons macro (cons append body))))
(setq woman0-macro-alist (cons macro woman0-macro-alist))
(forward-line)
(delete-region from (point))
(backward-char) ))
(beginning-of-line) (woman-delete-line 1))
(defun woman0-macro (request)
"Process the macro call named REQUEST."
(let ((macro (assoc request woman0-macro-alist)))
(if macro
(woman-interpolate-macro (cdr macro))
(WoMan-warn "Undefined macro %s not interpolated!" request))))
(defun woman-interpolate-macro (macro)
"Interpolate (.de) or append (.am) expansion of MACRO into the buffer."
(skip-chars-forward " \t")
(let ((argno 0) (append (car macro))
argno-string formal-arg from actual-arg start)
(setq macro (cdr macro))
(while (not (eolp))
(setq argno (1+ argno))
(setq argno-string (format "%d" argno))
(setq formal-arg (concat "\\\\\\$" argno-string)) (setq from (point))
(woman-forward-arg 'unquote 'noskip)
(setq actual-arg (buffer-substring from (point)))
(skip-chars-forward " \t") (setq start nil)
(while (setq start (string-match formal-arg macro start))
(setq macro (replace-match actual-arg t t macro)))
)
(setq start nil)
(while
(setq start (string-match "\\\\\\$." macro start))
(setq macro (replace-match "" t t macro)))
(setq start nil)
(while
(setq start (string-match "\\\\n(\\.\\$" macro start)) (setq macro (replace-match argno-string t t macro)))
(if append
(forward-char)
(beginning-of-line)
(woman-delete-line 1))
(save-excursion (insert macro))))
(defun woman-match-name ()
"Match and move over name of form: x, (xx or [xxx...].
Applies to number registers, fonts, strings/macros/diversions, and
special characters."
(cond ((= (following-char) ?\[ )
(forward-char)
(re-search-forward "[^]]+")
(forward-char)) ((= (following-char) ?\( )
(forward-char)
(re-search-forward ".."))
(t (re-search-forward "."))))
(defun woman-strings (&optional to)
"Process ?roff string requests and escape sequences up to buffer position TO.
Strings are defined/updated by `.ds xx string' requests and
interpolated by `\*x' and `\*(xx' escapes."
(while
(re-search-forward "\\(^[.'][ \t]*ds\\)\\|\\\\\\*" to t)
(cond ((match-string 1) (skip-chars-forward " \t")
(if (eolp) ()
(re-search-forward "[^ \t\n]+")
(let ((string (match-string 0)))
(skip-chars-forward " \t")
(looking-at ".*")
(setq string (cons string (match-string 0)))
(setq woman-string-alist (cons string woman-string-alist))
))
(beginning-of-line)
(woman-delete-line 1))
(t (let ((beg (match-beginning 0)))
(woman-match-name)
(let* ((stringname (match-string 0))
(string (assoc stringname woman-string-alist)))
(cond (string
(delete-region beg (point))
(if (bolp) (insert-before-markers "\\&"))
(insert-before-markers (cdr string)))
(t
(WoMan-warn "Undefined string %s not interpolated!"
stringname)
(cond (woman-ignore
(delete-region beg (point))
(setq woman-string-alist
(cons (cons stringname "")
woman-string-alist))))
))
))
))
))
(defconst woman-special-characters
'(("em" "--" "\276" . t) ("bu" "*" "\267" . t) ("fm" "'") ("co" "(C)" "\251")
("pl" "+" "+" . t) ("mi" "-" "-" . t) ("**" "*" "*" . t) ("aa" "'" "\242" . t) ("ul" "_")
("*S" "Sigma" "S" . t)
(">=" ">=" "\263" . t) ("<=" "<=" "\243" . t) ("->" "->" "\256" . t) ("<-" "<-" "\254" . t) ("mu" " x " "\264" . t) ("+-" "+/-" "\261" . t) ("bv" "|")
("lq" "\"")
("rq" "\"")
("aq" "'")
("ha" "^")
("ti" "~")
)
"Alist of special character codes with ASCII and extended-font equivalents.
Each alist elements has the form
(input-string ascii-string extended-font-string . use-symbol-font)
where
* `\\(input-string' is the ?roff encoding,
* `ascii-string' is the (multi-character) ASCII simulation,
* `extended-font-string' is the single-character string representing
the character position in the extended 256-character font, and
* `use-symbol-font' is t to indicate use of the symbol font or nil,
i.e. omitted, to indicate use of the default font.
Any element may be nil. Avoid control character codes (0 to \\37, \\180
to \\237) in `extended-font-string' for now, since they can be
displayed only with a modified display table.
Use the WoMan command `woman-display-extended-fonts' or a character
map accessory to help construct this alist.")
(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.)"
(while (re-search-forward "\\\\\\(?:(\\(..\\)\\|\\[\\([[^]]+\\)\\]\\)" to t)
(let* ((name (or (match-string-no-properties 1)
(match-string-no-properties 2)))
(replacement (assoc name woman-special-characters)))
(unless
(and
replacement
(cond ((and (cddr replacement)
(if (nthcdr 3 replacement)
(if woman-use-symbol-font
(woman-replace-match (nth 2 replacement)
'woman-symbol))
(if woman-use-extended-font
(woman-replace-match (nth 2 replacement))))))
((cadr replacement) (woman-replace-match (cadr replacement)))))
(WoMan-warn (concat "Special character "
(if (match-string 1) "\\(%s" "\\[%s]")
" not interpolated!") name)
(if woman-ignore (woman-delete-match 0))))
))
(defun woman-display-extended-fonts ()
"Display table of glyphs of graphic characters and their octal codes.
All the octal codes in the ranges [32..127] and [160..255] are displayed
together with the corresponding glyphs from the default and symbol fonts.
Useful for constructing the alist variable `woman-special-characters'."
(interactive)
(with-output-to-temp-buffer "*WoMan Extended Font Map*"
(save-excursion
(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")))
))
(print-help-return-message)))
(defvar request) (defvar unquote)
(defun woman-unquote (to)
"Delete any double-quote characters between point and TO.
Leave point at TO (which should be a marker)."
(let (in-quote)
(while (search-forward "\"" to 1)
(if (and in-quote (looking-at "\""))
(delete-char 1)
(if (or in-quote (looking-at ".*\"")) (delete-char -1))
(setq in-quote (not in-quote))
))
(if in-quote
(WoMan-warn "Unpaired \" in .%s arguments." request))
))
(defsubst woman-unquote-args ()
"Delete any double-quote characters up to the end of the line."
(woman-unquote (save-excursion (end-of-line) (point-marker))))
(defun woman1-roff-buffer ()
"Process non-breaking requests."
(let ((case-fold-search t)
request fn unquote)
(while
(re-search-forward woman-request-regexp nil t)
(cond
((setq fn (intern-soft
(concat "woman1-"
(setq request (match-string 1)))))
(if (get fn 'notfont) (funcall fn)
(woman-delete-match 0)
(setq unquote (not (eolp)))
(if (eolp) (delete-char 1))
(funcall fn)
(if (and unquote (memq (following-char) '(?. ?')))
(insert "\\&"))
)
)))))
(defun woman1-B ()
".B -- Set words of current line in bold font."
(woman1-B-or-I ".ft B\n"))
(defun woman1-I ()
".I -- Set words of current line in italic font."
(woman1-B-or-I ".ft I\n"))
(defun woman1-B-or-I (B-or-I)
".B/I -- Set words of current line in bold/italic font.
B-OR-I is the appropriate complete control line."
(insert B-or-I) (save-excursion
(if unquote
(woman-unquote-args)
(while (looking-at "^[.']") (forward-line))
(end-of-line)
(delete-horizontal-space))
(insert "\\fR")))
(defun woman1-SM ()
".SM -- Set the current line in small font, i.e. IGNORE!"
nil)
(defalias 'woman1-SB 'woman1-B)
(defun woman1-BI ()
".BI -- Join words of current line alternating bold and italic fonts."
(woman1-alt-fonts (list "\\fB" "\\fI")))
(defun woman1-BR ()
".BR -- Join words of current line alternating bold and Roman fonts."
(woman1-alt-fonts (list "\\fB" "\\fR")))
(defun woman1-IB ()
".IB -- Join words of current line alternating italic and bold fonts."
(woman1-alt-fonts (list "\\fI" "\\fB")))
(defun woman1-IR ()
".IR -- Join words of current line alternating italic and Roman fonts."
(woman1-alt-fonts (list "\\fI" "\\fR")))
(defun woman1-RB ()
".RB -- Join words of current line alternating Roman and bold fonts."
(woman1-alt-fonts (list "\\fR" "\\fB")))
(defun woman1-RI ()
".RI -- Join words of current line alternating Roman and italic fonts."
(woman1-alt-fonts (list "\\fR" "\\fI")))
(defun woman1-alt-fonts (fonts)
"Join words using alternating fonts in FONTS, which MUST be a dynamic list."
(nconc fonts fonts) (insert (car fonts))
(save-excursion
(setq fonts (cdr fonts))
(woman-forward-arg unquote 'concat) (while (not (eolp))
(insert (car fonts))
(setq fonts (cdr fonts))
(woman-forward-arg unquote 'concat)) (insert "\\fR")
))
(defun woman-forward-arg (&optional unquote concat)
"Move forward over one ?roff argument, optionally unquoting and/or joining.
If optional arg UNQUOTE is non-nil then delete any argument quotes.
If optional arg CONCAT is non-nil then join arguments."
(if (eq (following-char) ?\")
(progn
(if unquote (delete-char 1) (forward-char))
(re-search-forward "\"\\|$")
(while (eq (following-char) ?\") ; paired
(if unquote (delete-char 1) (forward-char))
(re-search-forward "\"\\|$"))
(if (eq (preceding-char) ?\")
(if unquote (delete-backward-char 1))
(WoMan-warn "Unpaired \" in .%s arguments." request)
))
(skip-syntax-forward "^ "))
(cond ((null concat) (skip-chars-forward " \t")) ((eq concat 'noskip)) (t (woman-delete-following-space)))
)
(put 'woman1-TP 'notfont t)
(defun woman1-TP ()
".TP -- After tag line, reset font to Roman for paragraph body."
(save-excursion
(forward-line)
(forward-line (if (looking-at "\\.\\S-+[ \t]*$") 2 1))
(insert ".ft R\n")))
(put 'woman1-ul 'notfont t)
(defun woman1-ul ()
".ul N -- Underline (italicize) the next N input lines, default N = 1."
(let ((N (if (eolp) 1 (woman-parse-numeric-arg)))) (woman-delete-whole-line)
(insert ".ft I\n")
(forward-line N)
(insert ".ft R\n")
))
(put 'woman1-nh 'notfont t)
(defun woman1-nh ()
".nh -- No hyphenation, i.e. IGNORE!"
(woman-delete-whole-line))
(put 'woman1-hy 'notfont t)
(defun woman1-hy ()
".hy N -- Set hyphenation mode to N, i.e. IGNORE!"
(woman-delete-whole-line))
(put 'woman1-hc 'notfont t)
(defun woman1-hc ()
".hc c -- Set hyphenation character to c, i.e. delete it!"
(let ((c (char-to-string (following-char))))
(woman-delete-whole-line)
(setq c (concat "\\(" c "\\)\\|^[.'][ \t]*hc"))
(save-excursion
(while (and (re-search-forward c nil t)
(match-string 1))
(delete-char -1)))
))
(put 'woman1-hw 'notfont t)
(defun woman1-hw ()
".hw words -- Set hyphenation exception words, i.e. IGNORE!"
(woman-delete-whole-line))
(put 'woman1-ps 'notfont t)
(defalias 'woman1-ps 'woman-delete-whole-line)
(put 'woman1-ss 'notfont t)
(defalias 'woman1-ss 'woman-delete-whole-line)
(put 'woman1-cs 'notfont t)
(defalias 'woman1-cs 'woman-delete-whole-line)
(put 'woman1-ne 'notfont t)
(defalias 'woman1-ne 'woman-delete-whole-line)
(put 'woman1-vs 'notfont t)
(defalias 'woman1-vs 'woman-delete-whole-line)
(put 'woman1-bd 'notfont t)
(defalias 'woman1-bd 'woman-delete-whole-line)
(defun woman1-TX ()
".TX t p -- Resolve SunOS abbrev t and join to p (usually punctuation)."
(insert "SunOS ")
(woman-forward-arg 'unquote 'concat))
(put 'woman1-IX 'notfont t)
(defalias 'woman1-IX 'woman-delete-whole-line)
(defconst woman-font-alist
'(("R" . default)
("I" . woman-italic)
("B" . woman-bold)
("P" . previous)
("1" . default)
("2" . woman-italic)
("3" . woman-bold) )
"Alist of ?roff font indicators and woman font variables and names.")
(defun woman-change-fonts ()
"Process font changes."
(let ((font-alist woman-font-alist) (previous-pos (point))
(previous-font 'default)
(current-font 'default))
(while
(re-search-forward
"^[.'][ \t]*\\(\\(\\ft\\)\\|\\(.P\\)\\)\\|\\(\\\\f\\)" nil 1)
(let (font beg notfont fescape)
(cond ((match-string 2)
(setq beg (match-beginning 0))
(skip-chars-forward " \t")
(if (eolp) (setq font previous-font)
(looking-at "[^ \t\n]+"))
(forward-line)) ((match-string 3)
(setq font 'default))
((match-string 4)
(setq beg (match-beginning 0)
fescape t)
(woman-match-name))
(t (setq notfont t)))
(if notfont
()
(or font
(let ((fontstring (match-string 0)))
(setq font (assoc fontstring font-alist)
font (if font
(cdr font)
(WoMan-warn "Unknown font %s." fontstring)
(setq font-alist
(cons (cons fontstring 'woman-unknown)
font-alist))
'woman-unknown)
)))
(cond (beg (delete-region beg (point))
(if (eq font 'previous) (setq font previous-font))))
(and fescape
(looking-at woman-request-regexp)
(insert "\\&"))
(woman-set-face previous-pos (point) current-font)
(if beg
(setq previous-pos (point)
previous-font current-font)
(setq previous-pos (point)
previous-font 'default))
(setq current-font font)
)))
(woman-set-face previous-pos (point) current-font)
))
(defun woman-set-face (from to face)
"Set the face of the text from FROM to TO to face FACE.
Ignore the default face and underline only word characters."
(or (eq face 'default) (not woman-fontify)
(if (face-underline-p face)
(save-excursion
(let ((face-no-ul (intern (concat (symbol-name face) "-no-ul"))))
(goto-char from)
(while (< (point) to)
(skip-syntax-forward "w" to)
(put-text-property from (point) 'face face)
(setq from (point))
(skip-syntax-forward "^w" to)
(put-text-property from (point) 'face face-no-ul)
(setq from (point))
)))
(put-text-property from to 'face face))
))
(defvar translations nil)
(defun woman-get-next-char ()
"Return and delete next char in buffer, including special chars."
(if (looking-at "\\\\\\((..\\|\\*\\(\\[[^]]+\\]\\|(..\\|.\\)\\)")
(prog1 (match-string 0)
(woman-delete-match 0))
(prog1 (char-to-string (following-char))
(delete-char 1))))
(defun woman2-tr (to)
".tr abcde -- Translate a -> b, c -> d, ..., e -> space.
Format paragraphs upto TO. Supports special chars.
\(Breaks, but should not.)"
(let ((matches (car translations))
(alist (cdr translations))
a b)
(setq matches
(concat (if matches (substring matches 1 -1)) "]"))
(while (not (eolp)) (setq a (woman-get-next-char))
(if (eolp)
(setq b " ")
(setq b (woman-get-next-char)))
(setq matches
(if (= (length a) 1)
(concat a matches)
(concat matches "\\|\\" a))
alist (cons (cons a b) alist)))
(delete-char 1) (setq matches
(if (= (string-to-char matches) ?\])
(substring matches 3)
(concat "[" matches))
translations (cons matches alist))
(woman2-format-paragraphs to)
))
(defsubst woman-translate (to)
"Translate up to marker TO. Do this last of all transformations."
(if translations
(let ((matches (car translations))
(alist (cdr translations)))
(while (re-search-forward matches to t)
(insert-before-markers-and-inherit
(cdr (assoc
(buffer-substring-no-properties
(match-beginning 0) (match-end 0))
alist)))
(woman-delete-match 0))
)))
(defvar woman-registers '((".H" 24) (".V" 48) (".g" 0) (".i" left-margin) (".j" woman-adjust) (".l" fill-column) (".s" 12) (".u" (if woman-nofill 0 1)) (".v" 48) )
"Register alist: the key is the register name as a string.
Each element has the form (KEY VALUE . INC) -- inc may be nil.
Also bound locally in `woman2-roff-buffer'.")
(defun woman-mark-horizonal-position ()
"\\kx -- Store current horizontal position in INPUT LINE in register x."
(while (re-search-forward "\\\\k\\(.\\)" nil t)
(goto-char (match-beginning 0))
(setq woman-registers
(cons (list (match-string 1) (current-column))
woman-registers))
(woman-delete-match 0)))
(defsubst woman2-process-escapes-to-eol (&optional numeric)
"Process remaining escape sequences up to eol.
Handle numeric arguments specially if optional argument NUMERIC is non-nil."
(woman2-process-escapes (copy-marker (line-end-position) t) numeric))
(defun woman2-nr (to)
".nr R +/-N M -- Assign +/-N (wrt to previous value, if any) to register R.
The increment for auto-incrementing is set to M.
Format paragraphs upto TO. (Breaks, but should not!)"
(let* ((name (buffer-substring
(point)
(progn (skip-syntax-forward "^ ") (point))))
(pm (progn (skip-chars-forward " \t")
(when (memq (char-after) '(?+ ?-))
(forward-char) (char-before))))
(value (if (eolp) nil (woman2-process-escapes-to-eol 'numeric)
(woman-parse-numeric-arg)))
(inc (progn (skip-chars-forward " \t")
(if (eolp) nil (woman-parse-numeric-arg))))
(oldvalue (assoc name woman-registers)))
(when oldvalue
(setq oldvalue (cdr oldvalue)) (unless inc (setq inc (cdr oldvalue))))
(cond ((null value)
(setq value 0) (WoMan-warn "nr %s -- null value assigned as zero!" name))
((symbolp value)
(setq value (list 'quote value))))
(if pm (setq oldvalue (if oldvalue (car oldvalue) 0)
value (if (eq pm ?+)
(+ oldvalue value)
(- oldvalue value))))
(setq woman-registers
(cons (cons name (cons value inc)) woman-registers))
(woman-delete-whole-line)
(woman2-format-paragraphs to)))
(defsubst woman-get-numeric-arg ()
"Get the value of a numeric argument at or after point.
The argument can include the width function and scale indicators.
Assumes 10 characters per inch. Does not move point."
(woman2-process-escapes-to-eol 'numeric)
(save-excursion (woman-parse-numeric-arg)))
(defun woman-parse-numeric-arg ()
"Get the value of a numeric expression at or after point.
Unlike `woman-get-numeric-arg', leaves point after the argument.
The expression may be an argument in quotes."
(if (= (following-char) ?\") (forward-char))
;; Allow leading +/-:
(let ((value (if (looking-at "[+-]") 0 (woman-parse-numeric-value)))
op)
(while (cond
((looking-at "[+-/*%]") ; arithmetic operators
(forward-char)
(setq op (intern-soft (match-string 0)))
(setq value (funcall op value (woman-parse-numeric-value))))
((looking-at "[<=>]=?") ; relational operators
(goto-char (match-end 0))
(setq op (or (intern-soft (match-string 0))
(intern-soft "=")))
(setq value (if (funcall op value (woman-parse-numeric-value))
1 0)))
((memq (setq op (following-char)) '(?& ?:)) ; Boolean and / or
(forward-char)
(setq value
;; and / or are special forms, not functions, in ELisp
(if (eq op ?&)
;; and
(if (> value 0)
(if (> (woman-parse-numeric-value) 0) 1 0)
;; skip second operand
(prog1 0 (woman-parse-numeric-value)))
;; or
(if (> value 0)
;; skip second operand
(prog1 1 (woman-parse-numeric-value))
(if (> (woman-parse-numeric-value) 0) 1 0))
)))
))
; (if (looking-at "[ \t\nRC\)\"]") value
))
(defun woman-parse-numeric-value ()
"Get a single numeric value at or after point.
The value can be a number register or width function (which assumes 10
characters per inch) and can include scale indicators. It may be an
expression in parentheses. Leaves point after the value."
(if (eq (following-char) ?\()
(let (n)
(forward-char)
(setq n (woman-parse-numeric-arg))
(skip-syntax-forward " ")
(if (eq (following-char) ?\))
(forward-char)
(WoMan-warn "Parenthesis confusion in numeric expression!"))
n)
(let ((n (cond ((looking-at "[-+]?[.0-9]+") (string-to-number (match-string 0)))
((looking-at "\\\\n\\([-+]\\)?\\(?:\
\\[\\([^]]+\\)\\]\\|\(\\(..\\)\\|\\(.\\)\\)")
(let* ((pm (match-string-no-properties 1))
(name (or (match-string-no-properties 2)
(match-string-no-properties 3)
(match-string-no-properties 4)))
(value (assoc name woman-registers)))
(if value
(let (inc)
(setq value (cdr value) inc (cdr value)
value (eval (car value)))
(if (and pm inc) (setq value
(funcall (intern-soft pm) value inc)
woman-registers
(cons (cons name (cons value inc))
woman-registers)))
value)
(WoMan-warn "Undefined register %s defaulted to 0."
name)
0) ))
((re-search-forward
"\\=\\\\w\\(\\\\\\[[^]]+\\]\\|\\\\(..\\|.\\)" nil t)
(let ((from (match-end 0))
(delim (regexp-quote (match-string 1))))
(if (re-search-forward delim nil t)
(- (match-beginning 0) from)
(WoMan-warn "Width escape delimiter error!"))))
)))
(if (null n)
(progn
(WoMan-warn "Numeric/register argument error: %s"
(buffer-substring
(point)
(save-excursion (end-of-line) (point))))
(skip-syntax-forward "^ ")
0)
(goto-char (match-end 0))
(if
(cond
((looking-at "\\s ") nil) ((looking-at "[mnuv]")) ((looking-at "i") (setq n (* n 10))) ((looking-at "c") (setq n (* n 3.9))) ((looking-at "P") (setq n (* n 1.7))) ((looking-at "p") (setq n (* n 0.14))) )
(goto-char (match-end 0)))
(if (numberp n) (round n) n))
)))
(defun woman2-roff-buffer ()
"Process breaks. Format paragraphs and headings."
(let ((case-fold-search t)
(to (make-marker))
(canonically-space-region
(symbol-function 'canonically-space-region))
(insert-and-inherit (symbol-function 'insert-and-inherit))
(set-text-properties (symbol-function 'set-text-properties))
(woman-registers woman-registers)
fn request translations
tab-stop-list)
(set-marker-insertion-type to t)
(fset 'canonically-space-region 'ignore)
(fset 'insert-and-inherit (symbol-function 'insert))
(fset 'set-text-properties 'ignore)
(unwind-protect
(while
(re-search-forward woman-request-regexp nil t)
(cond
((setq fn (intern-soft
(concat "woman2-"
(setq request (match-string 1)))))
(woman-delete-match 0))
((prog1 nil
(WoMan-warn-ignored request "ignored!")
))
((or (looking-at "[ \t]*$") woman-ignore) (beginning-of-line) (woman-delete-line 1))
(t (end-of-line) (insert ?\n))
)
(if (not (or fn
(and (not (memq (following-char) '(?. ?')))
(setq fn 'woman2-format-paragraphs))))
()
(set-marker to (woman-find-next-control-line))
(funcall fn to)))
(if (not (eobp)) (woman2-format-paragraphs (copy-marker (point-max) t)
woman-left-margin))
(fset 'canonically-space-region canonically-space-region)
(fset 'set-text-properties set-text-properties)
(fset 'insert-and-inherit insert-and-inherit)
(set-marker to nil))))
(defun woman-find-next-control-line ()
"Find and return start of next control line."
(let (to)
(save-excursion
(while
(and
(setq to (re-search-forward "\\(\\\\c\\)?\n[.']" nil t))
(match-string 1)
(looking-at "br"))
(goto-char (match-beginning 0))
(woman-delete-line 2)))
(if to (1- to) (point-max))))
(defun woman2-PD (to)
".PD d -- Set the interparagraph distance to d.
Round to whole lines, default 1 line. Format paragraphs upto TO.
\(Breaks, but should not.)"
(woman-set-interparagraph-distance)
(woman2-format-paragraphs to))
(defun woman-set-interparagraph-distance ()
"Set the interparagraph distance from a .PD request at point."
(setq woman-interparagraph-distance
(if (eolp) 1 (woman-get-numeric-arg)))
(woman-delete-line 1))
(defsubst woman-interparagraph-space ()
"Set variable `woman-leave-blank-lines' from `woman-interparagraph-distance'."
(setq woman-leave-blank-lines woman-interparagraph-distance)
)
(defun woman2-TH (to)
".TH n c x v m -- Begin a man page. Format paragraphs upto TO.
n is the name of the page in chapter c\; x is extra commentary\;
v alters page foot left; m alters page head center.
\(Should set prevailing indent and tabs to 5.)"
(woman-forward-arg 'unquote 'concat)
(insert ?\()
(woman-forward-arg 'unquote 'concat)
(insert ?\))
(let ((start (point)) here)
(while (not (eolp))
(cond ((looking-at "\"\"[ \t]")
(delete-char 2)
))
(delete-horizontal-space)
(setq here (point))
(insert " -- ")
(woman-forward-arg 'unquote 'concat)
(if (string-match (buffer-substring here (point))
(buffer-substring start here))
(delete-region here (point)))
))
(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))
(defun woman2-SH (to)
".SH -- Sub-head. Leave blank line and subhead.
Format paragraphs upto TO. Set prevailing indent to 5."
(if (eolp) (delete-char 1) (woman-unquote-args) (beginning-of-line))
(woman2-process-escapes-to-eol)
(woman-leave-blank-lines woman-interparagraph-distance)
(setq woman-leave-blank-lines nil)
(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) (setq woman-prevailing-indent woman-default-indent)
(woman2-format-paragraphs to woman-left-margin))
(defun woman2-SS (to)
".SS -- Sub-sub-head. Like .SH but indent heading 3 spaces.
Format paragraphs upto TO."
(if (eolp) (delete-char 1)) (insert " ")
(beginning-of-line)
(woman2-SH to))
(defun woman2-LP (to)
".LP,.PP -- Begin paragraph. Set prevailing indent to 5.
Leave 1 blank line. Format paragraphs upto TO."
(woman-delete-line 1) (woman-interparagraph-space)
(setq woman-prevailing-indent woman-default-indent)
(woman2-format-paragraphs to woman-left-margin))
(defalias 'woman2-PP 'woman2-LP)
(defalias 'woman2-P 'woman2-LP)
(defun woman2-ns (to)
".ns -- Turn on no-space mode. Format paragraphs upto TO."
(woman-delete-line 1) (setq woman-nospace t)
(woman2-format-paragraphs to))
(defun woman2-rs (to)
".rs -- Turn off no-space mode. Format paragraphs upto TO."
(woman-delete-line 1) (setq woman-nospace nil)
(woman2-format-paragraphs to))
(defun woman2-sp (to)
".sp N -- If N > 0 then leave 1 blank line. Format paragraphs upto TO."
(let ((N (if (eolp) 1 (woman-get-numeric-arg))))
(if (>= N 0)
(woman-delete-line 1) (setq woman-negative-vertical-space t)
(insert ".sp ")
(forward-line))
(setq woman-leave-blank-lines N)
(woman2-format-paragraphs to)))
(defun woman-negative-vertical-space (from)
".sp N with N < 0 => overlap following with preceding lines at FROM."
(WoMan-warn "Negative vertical spacing support is experimental!")
(goto-char from)
(while
(re-search-forward "^\\.sp " nil t)
(let ((N (woman-get-numeric-arg))
overlap overwritten)
(woman-delete-whole-line)
(setq from (point)
overlap (buffer-substring from
(progn (forward-line (- N)) (point))))
(delete-region from (point))
(forward-line N)
(let ((imax (length overlap))
(i 0) c)
(while (< i imax)
(setq c (aref overlap i))
(cond ((eq c ?\n) (forward-line))
((eolp) (let ((eol (string-match "\n" overlap i)))
(insert (substring overlap i eol))
(setq i (or eol imax)))
)
((eq c ?\ ) (forward-char))
((eq c ?\t) (if (eq (following-char) ?\t)
(forward-char) (let ((i woman-tab-width))
(while (> i 0)
(if (eolp)
(insert ?\ ) (forward-char)) (setq i (1- i)))
)))
(t
(if (or (eq (following-char) ?\ ) overwritten) ()
(setq overwritten t)
(WoMan-warn
"Character(s) overwritten by negative vertical spacing in line %d"
(count-lines 1 (point))))
(delete-char 1) (insert (substring overlap i (1+ i)))))
(setq i (1+ i))
))
)))
(defun woman2-process-escapes (to &optional numeric)
"Process remaining escape sequences up to marker TO, preserving point.
Optional argument NUMERIC, if non-nil, means the argument is numeric."
(assert (and (markerp to) (marker-insertion-type to)))
(let ((from (point)))
(while (re-search-forward "\\\\[&|^]" to t)
(woman-delete-match 0))
(goto-char from)
(while (re-search-forward "\\\\c.*\n?" to t)
(woman-delete-match 0))
(if (and (or (eobp) (= (point) to)) (not (bolp)))
(insert-before-markers ?\n))
(goto-char from)
(woman-translate to)
(goto-char from)
(woman-special-characters to)
(goto-char from)
(while (search-forward "\\" to t)
(let ((c (following-char)))
(cond ((eq c ?') (delete-char -1)
(cond (numeric (delete-char 1)
(insert ?`))))
((eq c ?\( )) ((eq c ?t) (delete-char 1)
(delete-char -1)
(insert "\t"))
((and numeric
(memq c '(?w ?n ?h)))) ((eq c ?l) (woman-horizontal-line))
(t
(WoMan-warn "Escape ignored: \\%c -> %c" c c)
(delete-char -1))
)))
(goto-char from)
(cond (tab-stop-list
(while (search-forward "\t" to t)
(woman-tab-to-tab-stop))
(goto-char from)))
(while (re-search-forward "\\\\[nw]" to t)
(let ((from (match-beginning 0)) N)
(goto-char from)
(setq N (woman-parse-numeric-value))
(delete-region from (point))
(insert-before-markers (number-to-string N))))
(goto-char from)))
(defun woman-horizontal-line ()
"\\l'Nc' -- Draw a horizontal line of length N using character c, default _."
(delete-char -1)
(delete-char 1)
(looking-at "\\(.\\)\\(.*\\)\\1")
(forward-char 1)
(let* ((to (match-end 2))
(from (match-beginning 0))
(N (woman-parse-numeric-arg))
(c (if (< (point) to) (following-char) ?_)))
(delete-region from to)
(delete-char 1)
(insert (make-string N c))
))
(defun woman2-br (to)
".br -- Break. Leave no blank line. Format paragraphs upto TO."
(woman-delete-line 1) (woman2-format-paragraphs to))
(defun woman2-fi (to)
".fi -- Fill subsequent output lines. Leave no blank line.
Format paragraphs upto TO."
(setq woman-nofill nil)
(woman-delete-line 1) (save-excursion
(forward-line -1)
(if (looking-at "[ \t]*$") (setq woman-leave-blank-lines 1)))
(woman2-format-paragraphs to))
(defun woman2-nf (to)
".nf -- Nofill. Subsequent lines are neither filled nor adjusted.
Input text lines are copied directly to output lines without regard
for the current line length. Format paragraphs upto TO."
(setq woman-nofill t)
(woman-delete-line 1) (woman2-format-paragraphs to))
(defun woman2-ad (to)
".ad c -- Line adjustment is begun (once fill mode is on).
Set justification mode to c if specified.
Format paragraphs upto TO. (Breaks, but should not.)"
(setq woman-adjust
(cond ((eolp) woman-adjust-previous)
((eq (following-char) ?l) woman-adjust-left)
((eq (following-char) ?r) woman-adjust-right)
((eq (following-char) ?c) woman-adjust-center)
((memq (following-char) '(?b ?n)) woman-adjust-both)
(t (woman-get-numeric-arg))
)
woman-justify (nth woman-adjust woman-justify-list))
(woman-delete-line 1) (woman2-format-paragraphs to))
(defun woman2-na (to)
".na -- No adjusting. Format paragraphs upto TO.
\(Breaks, but should not.)"
(setq woman-adjust-previous woman-adjust
woman-justify-previous woman-justify
woman-adjust woman-adjust-left woman-justify (nth woman-adjust woman-justify-list))
(woman-delete-line 1) (woman2-format-paragraphs to))
(defun woman-leave-blank-lines (&optional leave)
"Delete all blank lines around point.
Leave one blank line if optional argument LEAVE is non-nil and
non-zero, or if LEAVE is nil and variable `woman-leave-blank-lines' is
non-nil and non-zero."
(delete-region
(save-excursion
(if (not (eq (skip-syntax-backward " ") 0))
(forward-line)) (point))
(progn (skip-syntax-forward " ")
(beginning-of-line)
(point)))
(if woman-nospace
()
(if (or (null leave) (eq leave 0))
(setq leave woman-leave-blank-lines))
(if (and leave (> leave 0)) (insert-before-markers ?\n))
)
(setq woman-leave-blank-lines nil)
)
(defvar woman-temp-indent nil)
(defun woman2-format-paragraphs (to &optional new-left)
"Indent, fill and adjust paragraphs upto TO to current left margin.
If optional arg NEW-LEFT is non-nil then reset current left margin.
If `woman-nofill' is non-nil then indent without filling or adjusting."
(if new-left (setq left-margin new-left))
(if (looking-at "^\\s *$")
(setq woman-leave-blank-lines 1))
(skip-syntax-forward " ")
(if (>= (point) to) ()
(woman-reset-nospace)
(woman2-process-escapes to 'numeric)
(if woman-nofill
(progn
(woman-leave-blank-lines)
(cond (woman-temp-indent
(indent-to woman-temp-indent)
(forward-line)))
(indent-rigidly (point) to left-margin)
(woman-horizontal-escapes to)) (while (< (point) to)
(woman-leave-blank-lines)
(let ((from (point)))
(indent-to (or woman-temp-indent left-margin))
(woman-horizontal-escapes to) (forward-line)
(and (re-search-forward "\\(^\\s *$\\)\\|\\(^\\s +\\)" to 1)
(eolp)
(skip-syntax-forward " ")
(setq woman-leave-blank-lines 1))
(unless (and (eolp) (eobp))
(beginning-of-line))
(if (or (> (count-lines from (point)) 1)
(save-excursion
(backward-char)
(> (current-column) fill-column)))
(progn
(if (and woman-temp-indent (< woman-temp-indent left-margin))
(let ((left-margin woman-temp-indent))
(fill-region-as-paragraph from (point) woman-justify)
(save-excursion
(goto-char from)
(forward-line)
(setq from (point)))))
(fill-region-as-paragraph from (point) woman-justify))
)
))
)
(setq woman-temp-indent nil)
))
(defun woman2-TP (to)
".TP i -- Set prevailing indent to i. Format paragraphs upto TO.
Begin indented paragraph with hanging tag given by next text line.
If tag doesn't fit, place it on a separate line."
(let ((i (woman2-get-prevailing-indent)))
(woman-leave-blank-lines woman-interparagraph-distance)
(woman2-tagged-paragraph to i)))
(defun woman2-IP (to)
".IP x i -- Same as .TP with tag x. Format paragraphs upto TO."
(woman-interparagraph-space)
(if (eolp) (woman2-format-paragraphs to (+ woman-left-margin
woman-prevailing-indent))
(woman-forward-arg 'unquote)
(let ((i (woman2-get-prevailing-indent 'leave-eol)))
(beginning-of-line)
(woman-leave-blank-lines) (unless (or (looking-at "^\\.IP")
(and (looking-at "^\\.sp")
(save-excursion
(and (zerop (forward-line 1))
(looking-at woman-request-regexp)))))
(woman2-tagged-paragraph to i)))))
(defun woman-find-next-control-line-carefully ()
"Find and return start of next control line, even if already there!"
(if (looking-at "^[.']")
(point)
(woman-find-next-control-line)))
(defun woman2-tagged-paragraph (to i)
"Begin indented paragraph with hanging tag given by current text line.
If tag doesn't fit, leave it on separate line.
Format paragraphs upto TO. Set prevailing indent to I."
(if (not (looking-at "\\s *$")) (setq woman-leave-blank-lines nil))
(cond ((and (= (point) to)
(looking-at "^[.'][ \t]*\\(PD\\|br\\|ta\\|sp\\) *"))
(if (member (match-string 1) '("br" "sp"))
(woman-delete-line 1)
(woman-delete-match 0)
(if (string= (match-string 1) "ta") (woman2-ta to)
(woman-set-interparagraph-distance)))
(set-marker to (woman-find-next-control-line-carefully))
))
(let ((tag (point)))
(woman-reset-nospace)
(woman2-process-escapes-to-eol)
(setq left-margin woman-left-margin)
(forward-line)
(fill-region-as-paragraph (save-excursion (forward-line -1) (point))
(point) woman-justify)
(cond ((and (= (point) to) (looking-at "^[.'][ \t]*PD *"))
(woman-delete-match 0)
(woman-set-interparagraph-distance)
(set-marker to (woman-find-next-control-line-carefully))
))
(setq left-margin (+ woman-left-margin i))
(cond ((< (point) to)
(woman2-format-paragraphs to)
(goto-char tag) (end-of-line)
(cond ((> (setq i (- left-margin (current-column))) 0)
(delete-char 1)
(delete-horizontal-space)
(while (> i 0) (insert ? ) (setq i (1- i)))))
(goto-char to) ))
))
(defun woman2-HP (to)
".HP i -- Set prevailing indent to i. Format paragraphs upto TO.
Begin paragraph with hanging indent."
(let ((i (woman2-get-prevailing-indent)))
(woman-interparagraph-space)
(setq woman-temp-indent woman-left-margin)
(woman2-format-paragraphs to (+ woman-left-margin i))
))
(defun woman2-get-prevailing-indent (&optional leave-eol)
"Set prevailing indent to integer argument at point, and return it.
If no argument then return the existing prevailing indent.
Delete line from point and eol unless LEAVE-EOL is non-nil."
(if (eolp)
(or leave-eol (delete-char 1))
(let ((i (woman-get-numeric-arg)))
(woman-delete-line) (or leave-eol (delete-char 1))
(if (> i 0) (setq woman-prevailing-indent i))))
woman-prevailing-indent)
(defmacro woman-push (value stack)
"Push VALUE onto STACK."
`(setq ,stack (cons ,value ,stack)))
(defmacro woman-pop (variable stack)
"Pop into VARIABLE the value at the top of STACK.
Allow for mismatched requests!"
`(if ,stack
(setq ,variable (car ,stack)
,stack (cdr ,stack))))
(defun woman2-RS (to)
".RS i -- Start relative indent, move left margin in distance i.
Set prevailing indent to 5 for nested indents. Format paragraphs upto TO."
(woman-push woman-left-margin woman-RS-left-margin)
(woman-push woman-prevailing-indent woman-RS-prevailing-indent)
(setq woman-left-margin (+ woman-left-margin
(woman2-get-prevailing-indent))
woman-prevailing-indent woman-default-indent)
(woman2-format-paragraphs to woman-left-margin))
(defun woman2-RE (to)
".RE -- End of relative indent. Format paragraphs upto TO.
Set prevailing indent to amount of starting .RS."
(woman-pop woman-left-margin woman-RS-left-margin)
(woman-pop woman-prevailing-indent woman-RS-prevailing-indent)
(woman-delete-line 1) (woman2-format-paragraphs to woman-left-margin))
(defun woman-set-arg (arg &optional previous)
"Reset, increment or decrement argument ARG, which must be quoted.
If no argument then use value of optional arg PREVIOUS if non-nil,
otherwise set PREVIOUS. Delete the whole remaining control line."
(if (eolp) (set arg (if previous (eval previous) 0))
(if previous (set previous (eval arg)))
(woman2-process-escapes-to-eol 'numeric)
(let ((pm (if (looking-at "[+-]")
(prog1 (following-char)
(forward-char 1))))
(i (woman-parse-numeric-arg)))
(cond ((null pm) (set arg i))
((= pm ?+) (set arg (+ (eval arg) i)))
((= pm ?-) (set arg (- (eval arg) i)))
))
(beginning-of-line))
(woman-delete-line 1))
(defvar woman-ll-fill-column woman-fill-column)
(defvar woman-in-left-margin woman-left-margin)
(defun woman2-ll (to)
".ll +/-N -- Set, increment or decrement line length.
Format paragraphs upto TO. (Breaks, but should not.)"
(woman-set-arg 'fill-column 'woman-ll-fill-column)
(woman2-format-paragraphs to))
(defun woman2-in (to)
".in +/-N -- Set, increment or decrement the indent.
Format paragraphs upto TO."
(woman-set-arg 'left-margin 'woman-in-left-margin)
(woman2-format-paragraphs to))
(defun woman2-ti (to)
".ti +/-N -- Temporary indent. Format paragraphs upto TO."
(setq woman-temp-indent left-margin)
(woman-set-arg 'woman-temp-indent)
(woman2-format-paragraphs to nil))
(defun woman2-ta (to)
".ta Nt ... -- Set tabs, left type, unless t=R(right), C(centered).
\(Breaks, but should not.) The tab stops are separated by spaces\;
a value preceded by + represents an increment to the previous stop value.
Format paragraphs upto TO."
(setq tab-stop-list nil)
(woman2-process-escapes-to-eol 'numeric)
(save-excursion
(let ((tab-stop 0))
(while (not (eolp))
(let ((plus (cond ((eq (following-char) ?+) (forward-char 1) t)))
(i (woman-parse-numeric-arg)))
(setq tab-stop (if plus (+ tab-stop i) i)))
(if (memq (following-char) '(?R ?C))
(setq tab-stop (cons tab-stop (following-char))))
(setq tab-stop-list (cons tab-stop tab-stop-list))
(skip-syntax-forward "^ ") (skip-chars-forward " \t")
)))
(woman-delete-line 1) (setq tab-stop-list (reverse tab-stop-list))
(woman2-format-paragraphs to))
(defsubst woman-get-tab-stop (tab-stop-list)
"If TAB-STOP-LIST is a cons, return its car, else return TAB-STOP-LIST."
(if (consp tab-stop-list) (car tab-stop-list) tab-stop-list))
(defun woman-tab-to-tab-stop ()
"Insert spaces to next defined tab-stop column.
The variable `tab-stop-list' is a list whose elements are either left
tab stop columns or pairs (COLUMN . TYPE) where TYPE is R or C."
(delete-backward-char 1)
(let ((tabs tab-stop-list))
(while (and tabs (>= (current-column)
(woman-get-tab-stop (car tabs))))
(setq tabs (cdr tabs)))
(if tabs
(let* ((tab (car tabs))
(type (and (consp tab) (cdr tab)))
eol n)
(if type
(setq tab (woman-get-tab-stop tab)
eol (save-excursion (end-of-line) (point))
n (save-excursion
(search-forward "\t" eol t))
n (- (if n (1- n) eol) (point))
tab (- tab (if (eq type ?C) (/ n 2) n))) )
(setq n (- tab (current-column)))
(while (> n 0)
(insert ?\ )
(setq n (1- n))))
(insert ?\ ))))
(defun woman2-DT (to)
".DT -- Restore default tabs. Format paragraphs upto TO.
\(Breaks, but should not.)"
(setq tab-stop-list nil)
(woman-delete-line 1) (woman2-format-paragraphs to))
(defun woman2-fc (to)
".fc a b -- Set field delimiter a and pad character b.
Format paragraphs upto TO.
A VERY FIRST ATTEMPT to make fields at least readable!
Needs doing properly!"
(if (eolp)
(woman-delete-whole-line) (let ((delim (following-char))
(pad ?\ ) end) (forward-char)
(skip-chars-forward " \t")
(or (eolp) (setq pad (following-char)))
(woman-delete-whole-line)
(save-excursion
(if (re-search-forward "^[.'][ \t]*fc\\s " nil t)
(setq end (match-beginning 0))))
(setq delim (string delim ?[ ?^ delim ?] ?* delim))
(save-excursion
(while (re-search-forward delim end t)
(goto-char (match-beginning 0))
(delete-char 1)
(insert woman-unpadded-space-char)
(goto-char (match-end 0))
(delete-backward-char 1)
(insert-before-markers woman-unpadded-space-char)
(subst-char-in-region
(match-beginning 0) (match-end 0)
pad woman-unpadded-space-char t)
))
))
(woman2-format-paragraphs to))
(defun woman2-TS (to)
".TS -- Start of table code for the tbl processor.
Format paragraphs upto TO."
(woman-delete-line 1) (when woman-emulate-tbl
(if (looking-at ".*;[ \t]*$") (woman-delete-line 1)) (while (not (looking-at ".*\\.[ \t]*$")) (woman-delete-line 1))
(woman-delete-line 1)
(let ((start (point)) (col 1))
(while (prog1 (search-forward "\t" to t) (goto-char start))
(while (< (point) to)
(when (search-forward "\t" to t)
(backward-char)
(if (> (current-column) col) (setq col (current-column))))
(forward-line))
(goto-char start)
(setq col (+ col 3)) (while (< (point) to)
(when (search-forward "\t" to t)
(delete-char -1)
(insert-char ?\ (- col (current-column))))
(forward-line))
(goto-char start))))
(setq woman-nofill t)
(woman2-format-paragraphs to))
(defalias 'woman2-TE 'woman2-fi)
(defvar WoMan-current-file nil) (defvar WoMan-Log-header-point-max nil)
(defun WoMan-log-begin ()
"Log the beginning of formatting in *WoMan-Log*."
(let ((WoMan-current-buffer (buffer-name)))
(save-excursion
(set-buffer (get-buffer-create "*WoMan-Log*"))
(or (eq major-mode 'view-mode) (view-mode 1))
(setq buffer-read-only nil)
(goto-char (point-max))
(insert "\n\^L\nFormatting "
(if (stringp WoMan-current-file)
(concat "file " WoMan-current-file)
(concat "buffer " WoMan-current-buffer))
" at " (current-time-string) "\n")
(setq WoMan-Log-header-point-max (point-max))
)))
(defun WoMan-log (format &rest args)
"Log a message out of FORMAT control string and optional ARGS."
(WoMan-log-1 (apply 'format format args)))
(defun WoMan-warn (format &rest args)
"Log a warning message out of FORMAT control string and optional ARGS."
(setq format (apply 'format format args))
(WoMan-log-1 (concat "** " format)))
(defun WoMan-warn-ignored (request ignored)
"Log a warning message about ignored directive REQUEST.
IGNORED is a string appended to the log message."
(let ((tail
(buffer-substring (point)
(save-excursion (end-of-line) (point)))))
(if (and (> (length tail) 0)
(/= (string-to-char tail) ?\ ))
(setq tail (concat " " tail)))
(WoMan-log-1
(concat "** " request tail " request " ignored))))
(defun WoMan-log-end (time)
"Log the end of formatting in *WoMan-Log*.
TIME specifies the time it took to format the man page, to be printed
with the message."
(WoMan-log-1 (format "Formatting time %d seconds." time) 'end))
(defun WoMan-log-1 (string &optional end)
"Log a message STRING in *WoMan-Log*.
If optional argument END is non-nil then make buffer read-only after
logging the message."
(save-excursion
(set-buffer (get-buffer-create "*WoMan-Log*"))
(setq buffer-read-only nil)
(goto-char (point-max))
(or end (insert " ")) (insert string "\n")
(if end
(setq buffer-read-only t)
(if woman-show-log
(select-window (prog1 (selected-window) (select-window (display-buffer (current-buffer)))
(cond (WoMan-Log-header-point-max
(goto-char WoMan-Log-header-point-max)
(forward-line -1)
(recenter 0)))
)))))
nil)
(provide 'woman)