commit/edit-utils: kehoea: Make `manual-entry' run asynchronously, increasing responsiveness.

1 new commit in edit-utils: https://bitbucket.org/xemacs/edit-utils/commits/759a527caec3/ Changeset: 759a527caec3 User: kehoea Date: 2017-11-05 14:58:10+00:00 Summary: Make `manual-entry' run asynchronously, increasing responsiveness. ChangeLog addition: 2017-11-05 Aidan Kehoe <kehoea(a)parhasard.net&gt; * man.el: * man.el (Manual-switches): * man.el (Manual-mode-hook): * man.el (man-italic): * man.el (man-bold): * man.el (man-heading): * man.el (man-xref): * man.el (Manual-mode-map): * man.el (Manual-use-rosetta-man): Removed. * man.el (Manual-mode-xref-map): New. * man.el (Manual-unicode-to-char): New. * man.el (Manual-process-filter): New. * man.el (This function does four broad things): New. * man.el (manual-entry): * man.el (Manual-boldface-section-titles): New. * man.el (Manual-mode): * man.el (Manual-mode-and-display-buffer): New. * man.el (Manual-last-page): * man.el (Manual-delete-char): Removed. * man.el (Manual-nuke-nroff-bs): * man.el (Manual-nuke-nroff-bs-footers): * man.el (Manual-mouseify-xrefs): * man.el (Manual-follow-xref): * man.el (Manual-popup-menu): Extensive changes to this file. 1. Call `man' asynchronously, and display the output immediately as it starts to arrive. This gives a far more pleasant interactive experience with big man pages, in that XEmacs never becomes unresponsive dealing with a synchronous process output. 2. For those accented, punctuation and other non-ASCII characters that groff attempts to display using overstriking with ASCII characters, use mule characters instead, rather than just deleting them as the old code did. 3. Don't treat text like KSH(1) at the beginning and end of the file as a mouseable cross-reference, that is never the intention with it. 4. Fix problems with the interaction of Manual-mode-map and view-mode-minor-map, and make the implementation of Manual-last-page actually work, so l switches to another man page as is documented. 5. Make clickable hyperlinks respond to button1, return. 6. If there are no entries to show in the mode popup menu, give a menu showing that instead of erroring. Use #'menu-split-long-menu so the menu for big man pages isn't totally unwieldy. 7. Make `man-bold', `man-italic' inherit from the corresponding XEmacs faces, so they are distinctive by default. 8. Remove all mention of RosettaMan, now called PolyglotMan. This file doesn't actually work with it, and with an asynchronous implementation the speed benefit is not as important. Affected #: 2 files diff -r d71ad4063ecb9ad9015342592e7ad367759c7e3d -r 759a527caec38f15f925a523bfdd8d5918532fac ChangeLog --- a/ChangeLog +++ b/ChangeLog ＠＠ -1,3 +1,55 ＠＠ +2017-11-05 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * man.el: + * man.el (Manual-switches): + * man.el (Manual-mode-hook): + * man.el (man-italic): + * man.el (man-bold): + * man.el (man-heading): + * man.el (man-xref): + * man.el (Manual-mode-map): + * man.el (Manual-use-rosetta-man): Removed. + * man.el (Manual-mode-xref-map): New. + * man.el (Manual-unicode-to-char): New. + * man.el (Manual-process-filter): New. + * man.el (This function does four broad things): New. + * man.el (manual-entry): + * man.el (Manual-boldface-section-titles): New. + * man.el (Manual-mode): + * man.el (Manual-mode-and-display-buffer): New. + * man.el (Manual-last-page): + * man.el (Manual-delete-char): Removed. + * man.el (Manual-nuke-nroff-bs): + * man.el (Manual-nuke-nroff-bs-footers): + * man.el (Manual-mouseify-xrefs): + * man.el (Manual-follow-xref): + * man.el (Manual-popup-menu): + Extensive changes to this file. + 1. Call `man' asynchronously, and display the output immediately + as it starts to arrive. This gives a far more pleasant interactive + experience with big man pages, in that XEmacs never becomes + unresponsive dealing with a synchronous process output. + 2. For those accented, punctuation and other non-ASCII characters + that groff attempts to display using overstriking with ASCII + characters, use mule characters instead, rather than just deleting + them as the old code did. + 3. Don't treat text like KSH(1) at the beginning and end of the + file as a mouseable cross-reference, that is never the intention + with it. + 4. Fix problems with the interaction of Manual-mode-map and + view-mode-minor-map, and make the implementation of + Manual-last-page actually work, so l switches to another man page + as is documented. + 5. Make clickable hyperlinks respond to button1, return. + 6. If there are no entries to show in the mode popup menu, give a + menu showing that instead of erroring. Use #'menu-split-long-menu + so the menu for big man pages isn't totally unwieldy. + 7. Make `man-bold', `man-italic' inherit from the corresponding + XEmacs faces, so they are distinctive by default. + 8. Remove all mention of RosettaMan, now called PolyglotMan. This + file doesn't actually work with it, and with an asynchronous + implementation the speed benefit is not as important. + 2015-10-12 Norbert Koch <viteno(a)xemacs.org&gt; * Makefile (VERSION): XEmacs package 2.57 released. diff -r d71ad4063ecb9ad9015342592e7ad367759c7e3d -r 759a527caec38f15f925a523bfdd8d5918532fac man.el --- a/man.el +++ b/man.el ＠＠ -50,13 +50,13 ＠＠ :group 'man) (defcustom Manual-switches nil - "List of switches to the man program." + "*List of switches to the man program." :type '(choice (const :tag "none" nil) (repeat (string :tag "switch"))) :group 'man) (defcustom Manual-mode-hook nil - "Function or functions run on entry to Manual-mode." + "*Function or functions run on entry to Manual-mode." :type 'hook :group 'man) ＠＠ -76,242 +76,686 ＠＠ :type 'boolean :group 'man) -;;Here is information on RosettaMan, from Neal.Becker(a)comsat.com (Neal Becker): - -;;RosettaMan is a filter for UNIX manual pages. It takes as input man -;;pages formatted for a variety of UNIX flavors (not [tn]roff source) -;;and produces as output a variety of file formats. Currently -;;RosettaMan accepts man pages as formatted by the following flavors of -;;UNIX: Hewlett-Packard HP-UX, AT&T System V, SunOS, Sun Solaris, OSF/1, -;;DEC Ultrix, SGI IRIX, Linux, SCO; and produces output for the following -;;formats: printable ASCII only (stripping page headers and footers), -;;section and subsection headers only, TkMan, [tn]roff, Ensemble, RTF, -;;SGML (soon--I finally found a DTD), HTML, MIME, LaTeX, LaTeX 2e, Perl 5's pod. - -;;RosettaMan improves on other man page filters in several ways: (1) its -;;analysis recognizes the structural pieces of man pages, enabling high -;;quality output, (2) its modular structure permits easy augmentation of -;;output formats, (3) it accepts man pages formatted with the varient -;;macros of many different flavors of UNIX, and (4) it doesn't require -;;modification or cooperation with any other program. - -;;RosettaMan is a rewrite of TkMan's man page filter, called bs2tk. (If -;;you haven't heard about TkMan, a hypertext man page browser, you -;;should grab it via anonymous ftp from ftp.cs.berkeley.edu: -;;/ucb/people/phelps/tkman.tar.Z.) Whereas bs2tk generated output only for -;;TkMan, RosettaMan generalizes the process so that the analysis can be -;;leveraged to new output formats. A single analysis engine recognizes -;;section heads, subsection heads, body text, lists, references to other -;;man pages, boldface, italics, bold italics, special characters (like -;;bullets), tables (to a degree) and strips out page headers and -;;footers. The engine sends signals to the selected output functions so -;;that an enhancement in the engine improves the quality of output of -;;all of them. Output format functions are easy to add, and thus far -;;average about about 75 lines of C code each. - - - -;;*** NOTES ON CURRENT VERSION *** - -;;Help! I'm looking for people to help with the following projects. -;;\(1) Better RTF output format. The current one works, but could be -;;made better. (2) Roff macros that produce text that is easily -;;parsable. RosettaMan handles a great variety, but some things, like -;;H-P's tables, are intractable. If you write an output format or -;;otherwise improve RosettaMan, please send in your code so that I may -;;share the wealth in future releases. - -;;This version can try to identify tables (turn this on with the -T -;;switch) by looking for lines with a large amount of interword spacing, -;;reasoning that this is space between columns of a table. This -;;heuristic doesn't always work and sometimes misidentifies ordinary -;;text as tables. In general I think it is impossible to perfectly -;;identify tables from nroff formatted text. However, I do think the -;;heuristics can be tuned, so if you have a collection of manual pages -;;with unrecognized tables, send me the lot, in formatted form (i.e., -;;after formatting with nroff -man), and uuencode them to preserve the -;;control characters. Better, if you can think of heuristics that -;;distinguish tables from ordinary text, I'd like to hear them. - -;;Notes for HTML consumers: This filter does real (heuristic) -;;parsing--no <PRE>! Man page references are turned into hypertext links. - -(defcustom Manual-use-rosetta-man (locate-file "rman" exec-path) - "If non-nil, use RosettaMan (rman) to filter man pages. -This makes man-page cleanup virtually instantaneous, instead of -potentially taking a long time." - :type '(choice (symbol :tag "Do not use Rosettaman" nil) - (file :tag "RosettaMan Programm")) - :group 'man) - (defface man-italic '((t (:italic t))) "Manual italics face" :group 'man) +(set-face-parent 'man-italic 'italic nil '(default)) (defface man-bold '((t (:bold t))) "Manual bold face" :group 'man) +(set-face-parent 'man-bold 'bold nil '(default)) (defface man-heading '((t (:bold t))) "Manual headings face" :group 'man) +(set-face-parent 'man-heading 'bold nil '(default)) (defface man-xref '((t (:underline t))) - "Manual xrefs face" + "Manual cross-reference face" :group 'man) - +(set-face-parent 'man-xref 'underline nil '(default)) (defvar Manual-mode-map (let ((m (make-sparse-keymap))) (set-keymap-name m 'Manual-mode-map) + ;; See the entertainment in #'Manual-mode-and-display-buffer about this + ;; key binding: (define-key m "l" 'Manual-last-page) (define-key m 'button2 'Manual-follow-xref) (define-key m 'button3 'Manual-popup-menu) m)) +(defvar Manual-mode-xref-map + (let ((m (make-sparse-keymap))) + (set-keymap-parents m Manual-mode-map) + (define-key m "\C-m" 'Manual-follow-xref) + (define-key m 'button1 'Manual-follow-xref) + m)) + (defvar Manual-mode-syntax-table nil "Syntax table used in Manual-mode buffers") -(if Manual-mode-syntax-table - () +(unless Manual-mode-syntax-table (setq Manual-mode-syntax-table (make-syntax-table)) (modify-syntax-entry ?: "_" Manual-mode-syntax-table) (modify-syntax-entry ?+ "." Manual-mode-syntax-table) (modify-syntax-entry ?- "." Manual-mode-syntax-table) (modify-syntax-entry ?/ "." Manual-mode-syntax-table) - (modify-syntax-entry ?* "." Manual-mode-syntax-table) - ) + (modify-syntax-entry ?* "." Manual-mode-syntax-table)) + +(defun Manual-unicode-to-char (fixnum) + "Limited compatibility version of `unicode-to-char'. + +Falls back to `decode-char' with a `ucs' first argument if that is available; +otherwise uses those Greek and CJK characters available within every Mule +emacs to represent typographical and other non-ASCII characters +emulated by troff using backspace composition. + +Note that several of the characters needed have no equivalent in those XEmacs +versions where any Unicode support is provided by the mule-ucs package." + (let (acons) + (cond + ((< fixnum #x100) (int-char fixnum)) + ((and (fboundp 'decode-char) (decode-char 'ucs fixnum))) + ((and + (setq acons (assq fixnum '((#x0398 greek-iso8859-7 72) + (#x03a6 greek-iso8859-7 86) + (#x03a7 greek-iso8859-7 87) + (#x03b6 greek-iso8859-7 102) + (#x03b8 greek-iso8859-7 104) + (#x03bb greek-iso8859-7 107) + (#x03be greek-iso8859-7 110) + (#x03c0 greek-iso8859-7 112) + (#x03c3 greek-iso8859-7 115) + (#x03c4 greek-iso8859-7 116) + (#x03c8 greek-iso8859-7 120) + (#x2020 japanese-jisx0208 34 119) + (#x2021 japanese-jisx0208 34 120) + (#x2022 chinese-big5-1 33 38) + (#x2200 japanese-jisx0208 34 79) + (#x2191 japanese-jisx0208 34 44) + (#x2193 japanese-jisx0208 34 45) + (#x222b japanese-jisx0208 34 105) + (#x222b japanese-jisx0208 34 105) + (#x2286 japanese-jisx0208 34 60) + (#x2286 japanese-jisx0208 34 60) + (#x2287 japanese-jisx0208 34 61) + (#x2287 japanese-jisx0208 34 61) + (#x2295 chinese-cns11643-1 34 83) + (#x0444 cyrillic-iso8859-5 100)))) + (featurep 'mule) + (apply #'make-char (cdr acons)))) + ;; For the last no-mule user in the world, at least transform bullets to + ;; something readable: + ((cdr (assq fixnum + (load-time-value + (acons #x2022 (let ((extent (make-extent 0 1 "o"))) + (set-extent-face extent 'man-bold) + (set-extent-property extent 'duplicable t) + (set-extent-property extent 'unique t) + (extent-object extent)) nil)))))))) + +(defun Manual-process-filter (process string &optional flush) + "Handle process output from PROCESS, started from `manual-entry'. + +STRING reflects the most recent output from PROCESS. FLUSH, if supplied, +indicates thaat `Manual-process-filter' should not save any data from STRING +for processing on its next call. + +This function does four broad things: + +1. It interprets the tty sequences for underline, removes them, and applies + the `man-italic' face to the associated text. +2. It interprets the tty sequences for overstriking with the same character, + removes them, and applies the `man-bold' face to the associated text. +3. It interprets other groff sequences with backspace to construct accented + characters and other non-ASCII characters, and transforms them to the + appropriate XEmacs character. +4. It sets up cross-references to other man pages, which can be followed by + right clicking or by hitting `return'. + +In addition, the first time it is called for a given PROCESS, it tells XEmacs +to display the buffer; see `Manual-buffer-view-mode'." + (let* ((buffer (process-buffer process)) + (process-mark (process-mark process)) + (length (length string)) + (last 0) + position character-before character-after stashed extent lookup + extent-start-position) + (defvar #123456=#:Manual-stashed-strings nil) + (with-current-buffer buffer + (save-excursion + (macrolet + ;; The first four of these are macros rather than inline labels + ;; because the macro approach will actually lead to inline code on + ;; 21.4, whereas code with #'labels won't. + ((character-after (position) + `((lambda (position) + (incf position) + (if (< position length) (aref string position))) ,position)) + (character-before (position) + `((lambda (position) + (decf position) + (if (>= position 0) + (if (< position length) + (aref string position)) + (char-after (+ (point) position)))) ,position)) + (stash-string (string) + ;; This was implemented initially as a property of + ;; PROCESS. Unfortunately this doesn't work on 21.4. Then I + ;; implemented it as a buffer-local variable; unfortunately + ;; this doesn't work for the first stashed string, we have a + ;; longstanding bug in the first use of buffer local + ;; variables. An alist is cheap and portable. + `(setq #123456# (cons (cons process ,string) + (delete* process #123456# :key #'car)))) + (get-stashed-string () + `(prog1 + (cdr (assq process #123456#)) + (setq #123456# (delete* process #123456# :key #'car)))) + (adjust-or-make-extent (face-name extent-end-position + fail-early-unless) + `(if (and ,fail-early-unless + (setf extent (extent-at extent-start-position + buffer 'face nil + 'before)) + (eq ,face-name (extent-face extent))) + (prog1 extent (setf (extent-end-position extent) + ,extent-end-position)) + (prog1 (setf extent (make-extent extent-start-position + ,extent-end-position + buffer)) + (setf (extent-face extent) ,face-name)))) + (cond-with-handlers (&rest clauses &environment env) + (cons 'cond + (loop for clause in clauses + collect (if (assq (car-safe clause) env) + (macroexpand clause env) + clause)))) + (try-two-character-sequence (first second output) + `((and (eql character-before ,first) (eql character-after + ,second) + (load-time-value (Manual-unicode-to-char ,output))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert (load-time-value (Manual-unicode-to-char ,output))) + (incf position 2) + (setf last position))) + (try-two-characters-with-table (first alist) + `((and (eql character-before ,first) character-after + (setf lookup + (assq character-after + (load-time-value + (mapcan #'(lambda (cons) + (let ((character + (Manual-unicode-to-char + (cdr cons)))) + (if character + `((,(car cons) . + ,character))))) + ,alist))))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert (cdr lookup)) + (incf position 2) + (setf last position))) + (try-compose-map (first map) + `((and (eql character-before ,first) character-after + (fboundp ',map) + (setf lookup (lookup-key ',map character-after))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert + (if (consp (aref lookup 0)) + (car (aref lookup 0)) + (event-to-character + (make-event 'key-press `(key ,(aref lookup 0))) + nil nil t))) + (incf position 2) + (setf last position)))) + (if (marker-buffer process-mark) + (goto-char process-mark) + (set-marker process-mark (point) buffer)) + (when (eql (point) (point-min)) + (add-one-shot-hook + 'pre-idle-hook ;; This is more responsive for me than + ;; #'enqueue-eval-event. + `(lambda () (Manual-mode-and-display-buffer ,buffer)))) + (when (setf stashed (get-stashed-string)) + (let ((position 2)) + (symbol-macrolet ((do-not-end-with + ;; These make it more likely we would have + ;; to stash the end of the concatted + ;; string. + '(?\b ?_ ?| ?+))) + (while (and (< position length) + (or (member* (aref string position) + do-not-end-with) + (member* (aref string (1- position)) + do-not-end-with))) + (incf position))) + (setf position (min (1+ position) length)) + (Manual-process-filter process + (concat stashed + (substring string 0 position)) + flush) + (setf last (- position (length + (setf stashed (get-stashed-string))))) + (goto-char process-mark))) + (setf buffer-read-only nil) + (while (setf position (position ?\b string :start last :end length)) + (cond-with-handlers + ((eql (setf character-before (character-before position)) + (setf character-after (character-after position))) + ;; Bold, implemented in the TTY as overstriking with the same + ;; character. + (insert (substring string last position)) + (setf extent-start-position (1- (point))) + (incf position 2) + (while (and (< position length) + (eql (setf character-before (aref string position)) + (setf character-after + (character-after (1+ position)))) + (eql (aref string (1+ position)) ?\b)) + (insert character-before) + (incf position 3)) + ;; We don't have extra code to handle overstriking multiple + ;; times; that's fine, the loop with #'position above does + ;; that implicitly. + (setf extent (adjust-or-make-extent + 'man-bold (point) + (eql (character-before + (- position + (* 3 (- (point) extent-start-position)) + 1)) + ?\b)) + last position)) + ((and (eql character-before ?_) character-after) + ;; Underline; treat as italic + (insert (substring string last position)) + ;; We do insert-and-delete rather than substring the inserted + ;; string because that interacts better with stashed strings. + (delete-region (1- (point)) (point)) + (setf extent-start-position (point)) + (insert character-after) + (incf position 2) + (while (and (< position length) + (eql (aref string position) ?_) + (eql (character-after position) ?\b) + (setf character-after + (character-after (1+ position)))) + (insert character-after) + (incf position 3)) + ;; Manual-nuke-nroff-bs, below, worries about the ambiguity + ;; of _\b_. This code treats it as bold--it usually is + ;; bold--unless it is preceded immediately by italic + ;; characters. This gives reasonable results. + (setf extent (adjust-or-make-extent + 'man-italic (point) + (eql (character-before + (- position + (* 3 (- (point) extent-start-position)) + 1)) + ?\b)) + last position)) + ((and (eql character-after ?\b) character-before + (eql character-before (character-after (1+ position)))) + ;; Bolded CJK double-width characters. + (insert (substring string last position)) + (setf extent-start-position (1- (point))) + (setf extent (adjust-or-make-extent + 'man-italic (point) + (eql (character-before + (- position + (* 3 (- (point) extent-start-position)) + 1)) + ?\b)) + position (+ position 3) + last position)) + ;; From here onwards we're dealing with attempts of groff + ;; -mtty-char to create non-ASCII characters using ASCII + ;; primitives and overstriking. If troff has been invoked + ;; using -Tutf8 and if we understand UTF-8 none of the below + ;; will apply, and the code will never execute, absent corrupt + ;; data, because the first three clauses will have matched, so + ;; its performance impact is minimal. + (try-two-character-sequence ?+ ?o #x2022) ;; Bullet + (try-two-characters-with-table + ?| '((?^ . #x2191) ;; Uparrow + (?v . #x2193) ;; Downarrow + (?- . #x2020) ;; Dagger + (?= . #x2021) ;; Double dagger + (?u . #x03C8) ;; Psi + (?o . #x0444))) ;; Phi; use lowercase CYRILLIC SMALL + ;; LETTER EF, to force a glyph without a + ;; loop. + (try-compose-map ?\" compose-diaeresis-map) + (try-two-character-sequence ?\" ?_ #x030b) + (try-compose-map ?' compose-acute-map) + (try-two-character-sequence ?' ?\` #x0306) + ((and (eql character-before ?') + (eql character-after ?,) + (eql (character-after (1+ position)) ?\b) + (eql (character-after (+ position 2)) ?I) + (load-time-value (Manual-unicode-to-char #x222b))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert (load-time-value (Manual-unicode-to-char #x222b))) + (incf position 4) + (setf last position)) + (try-compose-map ?^ compose-circumflex-map) + (try-compose-map ?` compose-grave-map) + ((and (eql character-before ?`) + (eql character-after ?') + (eql (character-after (+ position 1)) ?\b) + (eql (character-after (+ position 2)) ?o)) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + (insert ?\xf0) ;; eth + (incf position 4) + (setf last position)) + (try-compose-map ?~ compose-tilde-map) + (try-two-characters-with-table + ?~ '((?_ . #xAC) ;; Logical not + (?t . #x03c4))) ;; Tau + (try-compose-map ?v compose-caron-map) + (try-compose-map ?/ compose-stroke-map) + (try-two-characters-with-table + ?/ '((?E . #x2209) ;; NOT AN ELEMENT OF + (?c . #xa2))) ;; CENT SIGN + (try-two-characters-with-table + ?, '((?C . #x03b6) ;; Zeta + (?E . #x03be) ;; GREEK SMALL LETTER XI + (?c . #xe7) ;; LATIN SMALL LETTER C WITH CEDILLA + (?f . #x0192) ;; LATIN SMALL LETTER F WITH HOOK + (?i . #xa1) ;; INVERTED EXCLAMATION MARK + (?u . #xb5))) ;; MICRO SIGN + (try-two-characters-with-table + ?- '((?0 . #x03B8) ;; GREEK SMALL LETTER THETA + (?D . #xd0) ;; LATIN CAPITAL LETTER ETH + (?L . #xa3) ;; POUND SIGN (sterling, that is) + (?O . #x0398) ;; GREEK CAPITAL LETTER THETA + (?V . #x2200) ;; FOR ALL + (?n . #x03C0) ;; GREEK SMALL LETTER PI + (?o . #x03C3) ;; GREEK SMALL LETTER SIGMA + (?w . #x03D6))) ;; GREEK PI SYMBOL + (try-two-characters-with-table + ?o '((?A . #xc5) ;; LATIN CAPITAL LETTER A WITH RING ABOVE + (?a . #xea) ;; LATIN SMALL LETTER E WITH CIRCUMFLEX + (?x . #xa4))) ;; CURRENCY SIGN + (try-two-characters-with-table + ?= '((?Y . #xa5) ;; YEN SIGN + (?v . #x21d3) ;; DOWNWARDS DOUBLE ARROW + (?^ . #x21d1))) ;; UPWARDS DOUBLE ARROW + ((and (eql character-before ?=) + (eql character-after ?_) + (eql (character-before (1- position)) ?\() + (load-time-value (Manual-unicode-to-char #x2286))) + (insert (substring string last position)) + (delete-region (- (point) 2) (point)) + ;; Reflex subset + (insert (load-time-value (Manual-unicode-to-char #x2286))) + (incf position 2) + (setf last position)) + ((and (eql character-before ?=) + (eql character-after ?_) + (eql (character-after (1+ position)) ?\)) + (load-time-value (Manual-unicode-to-char #x2287))) + (insert (substring string last position)) + (delete-region (1- (point)) (point)) + ;; Reflex superset + (insert (load-time-value (Manual-unicode-to-char #x2287))) + (incf position 3) + (setf last position)) + (try-two-character-sequence ?p ?b #xfe) + (try-two-characters-with-table + ?I '((?b . #xde) + (?O . #x03a6) + (?Y . #x03a7))) + (try-two-character-sequence ?> ?\\ #x03bb) ;; lambda + (try-two-characters-with-table + ?O '((?x . #x2297) ;; CIRCLED TIMES + (?+ . #x2295))) ;; CIRCLED PLUS + ((and (>= (+ position 3) length) (not flush)) + (stash-string (substring string position)) + (setf length position)) + ;; Let the clean-up below insert the trailing piece of the + ;; string. + (t + (incf position) + (insert (substring string last position)) + (setf last position)))) + (if (< last length) (insert (substring string last length))) + (goto-char process-mark) + (if (member "-k" + ;; #'process-command doesn't cons, to my surprise, no + ;; point saving whether this is an apropos or real + ;; man(1) call. + (process-command process)) + (progn + (while (re-search-forward "[a-zA-Z0-9] ([0-9]" nil t) + (forward-char -2) + (delete-region (point) (1- (point)))) + (goto-char process-mark)) + (if (eql (point) (point-min)) + (progn + ;; Treat the first line as a heading. + (set-extent-face (make-extent (point) (point-at-eol)) + 'man-heading) + ;; Some of the Perl module man pages have ridiculously long + ;; titles, which groff chokes on for the title line, + ;; emitting backspaces with the intention of rubbing out an + ;; already-printed character. Handle that. + (while (re-search-forward "[^\b]\b" (point-at-eol) t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Skip the top line of manual pages, but not apropos + ;; listings. + (forward-line 1)) + ;; Zap ESC7, ESC8, and ESC9 + ;; This is for Sun man pages like "man 1 csh" + (backward-char) + (while (re-search-forward "\e[789]" nil t) + (delete-region (match-beginning 0) (point))) + (goto-char process-mark))) + (if (position ?\) string :end length) ;; Can a cross-reference have + ;; ended in the text we just + ;; inserted? + (Manual-mouseify-xrefs (point) (point-max))) + (setf (marker-position process-mark) (point-max) + buffer-read-only t + (buffer-modified-p buffer) nil)))))) + +(defun Manual-boldface-section-titles () + "Mark subsection header lines bold in the current buffer. + +These are recognized heuristically as text in the first column following two +newlines, and followed by indented text on the next line. + +This function also handles the title lines of meta-manpages created with +troff's .so command, and extra backspaces that may have been inserted into the +final title line." + (labels ((delete-extent-mapper (extent ignore) (delete-extent extent))) + ;; + ;; Turn subsection header lines into bold. The first line is bolded + ;; separately in `Manual-process-filter'. + (goto-char (point-min)) + ;; Regexp to match section headers changed to match a non-indented + ;; line preceded by a blank line and followed by an indented line. + ;; This seems to work ok for manual pages but gives better results + ;; with other nroff'd files + ;; + ;; Most systems have indented text the next line after a section + ;; header, but some (Tru64) have an extra newline in between. + (while (re-search-forward "\n\n\\([^ \t\n].*\\)\n\n?[ \t]+[^ \t\n]" nil + t) + (goto-char (match-end 1)) + ;; section headings are often highlighted by the man page + ;; author, but other parts of the man page are highlighted the + ;; same way, so make our lisp-deduced section header + ;; highlighting higher priority. This also avoids having + ;; section headers being _random_ly highlighted alternately by + ;; either man-heading or man-bold, which sure looks like a bug. + ;; And for user interface issues, if it looks like a bug, it + ;; _is_ a bug. + (set-extent-properties (make-extent (match-beginning 1) + (match-end 1)) + '(face man-heading priority 1)) + (forward-line 1)) + (goto-char (point-min)) + ;; If this man page is a meta-manpage created with .so (cf. zshall(1)), + ;; the individual sub-manpages have first-lines included that + ;; Manual-mouseify-xref has made into cross-references. These should + ;; really be treated as first lines and given the heading face. + (while (re-search-forward "\n\n\n\n[A-Z0-9_.:]+([0-9][^)]*)[^\n]*\n\n\n\n" + nil t) + (map-extents #'delete-extent-mapper nil (match-beginning 0) (match-end 0) + nil nil 'man) + (set-extent-face (make-extent (+ (match-beginning 0) (length "\n\n\n\n")) + (- (match-end 0) (length "\n\n\n\n"))) + 'man-heading)) + ;; Do the same thing for the very last line, which tends to get an xref + ;; extent when it shouldn't. + (goto-char (point-max)) + (backward-char) + (map-extents #'delete-extent-mapper nil (point-at-bol) (point-max) nil nil + 'man) + (set-extent-face (make-extent (point-at-bol) (point)) 'man-heading) + ;; Some of the Perl module man pages have ridiculously long titles, which + ;; groff chokes on for the title line, emitting backspaces with the + ;; intention of rubbing out an already-printed character. Handle that. + (beginning-of-line) + (while (re-search-forward "[^\b]\b" (point-max) t) + (delete-region (match-beginning 0) (match-end 0))))) ;;;###autoload -(defun manual-entry (topic &optional arg silent) - "Display the Unix manual entry (or entries) for TOPIC. +(defun manual-entry (topic) + "Display the Unix manual entry for TOPIC. + If TOPIC starts with -k, then a system apropos search is performed using man -k for TOPIC." (interactive - (list (let* ((default (save-excursion - (buffer-substring - (progn - (if (not (eobp)) - (forward-char)) - (if (re-search-backward "\\sw\\|\\s_" nil t) - (forward-char)) - (re-search-backward - "\\(\\sw\\|\\s_\\)([0-9]+[A-Za-z]*\\=" - (point-at-bol) t) - (skip-syntax-backward "w_") - (point)) - (progn - (skip-syntax-forward "w_") - (re-search-forward "\\=([0-9]+[A-Za-z]*)" nil t) - (point) )))) - (thing (read-string - (if (equal default "") "Manual entry: " - (concat "Manual entry: (default " default ") ")) - nil 'Manual-page-minibuffer-history))) - (if (equal thing "") default thing)) - (prefix-numeric-value current-prefix-arg))) - (let (buffer) - (or arg (setq arg 1)) + (list (let ((default (save-excursion + (buffer-substring + (progn + (if (not (eobp)) + (forward-char)) + (if (re-search-backward "\\sw\\|\\s_" nil t) + (forward-char)) + (re-search-backward + "\\(\\sw\\|\\s_\\)([0-9]+[A-Za-z]*\\=" + (point-at-bol) t) + (skip-syntax-backward "w_") + (point)) + (progn + (skip-syntax-forward "w_") + (re-search-forward "\\=([0-9]+[A-Za-z]*)" nil t) + (point)))))) + (read-string (if (equal default "") + "Manual entry: " + (concat "Manual entry (default " default "): ")) + nil 'Manual-page-minibuffer-history default)))) + (let (buffer section apropos-mode bufname) ;; Allow leading chapter numbers (if (string-match "\\([1-9n][a-zA-Z0-9]*\\) \\(.*\\)" topic) - (setq topic (replace-match "\\2(\\1)" t nil topic)) - ) - (let (section apropos-mode) - (let ((case-fold-search nil)) - (if (and (null section) - (string-match - "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" - topic)) - (setq section (match-string 2 topic) - topic (match-string 1 topic)) + (setq topic (replace-match "\\2(\\1)" t nil topic))) + (let ((case-fold-search nil)) + (if (and (null section) + (string-match + "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" + topic)) + (setq section (match-string 2 topic) + topic (match-string 1 topic)) (if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic) (setq section "-k" topic (substring topic (match-beginning 1)))))) - - (when Manual-snip-subchapter - ;; jwz: turn section "3x11" and "3n" into "3". - (if (and section (string-match "\\`\\([0-9]+\\)[^0-9]" section)) - (setq section (match-string 1 section)))) - - (if (or (equal section "-k") (member "-k" Manual-switches)) - (setq apropos-mode t)) - - (let ((bufname (concat "Man" - (when apropos-mode " apropos") - ": " topic - (when section (concat "(" section ")")))) - (temp-buffer-show-function - (cond ((eq 't Manual-buffer-view-mode) - 'view-buffer) - ((eq 'nil Manual-buffer-view-mode) - temp-buffer-show-function) - (t - 'view-buffer-other-window)))) - - (cond ((get-buffer bufname) - ;; reselect an old man page buffer if it exists already. - (save-excursion - (set-buffer (get-buffer bufname)) - (Manual-mode) - (setq buffer (current-buffer))) - (if temp-buffer-show-function - (funcall temp-buffer-show-function (get-buffer bufname)) - (display-buffer bufname))) - (t - (with-output-to-temp-buffer bufname - (buffer-disable-undo standard-output) - (save-excursion - (set-buffer standard-output) - (setq buffer-read-only nil) - (erase-buffer) + (when Manual-snip-subchapter + ;; jwz: turn section "3x11" and "3n" into "3". + (if (and section (string-match "\\`\\([0-9]+\\)[^0-9]" section)) + (setq section (match-string 1 section)))) - (let ((args (append Manual-switches (list topic))) - args-string) - (if section - (setq args - (if (and (eq system-type 'usg-unix-v) - (null apropos-mode)) - (cons "-s" (cons section args)) - (cons section args)))) - (setq args-string - (mapconcat 'identity - (cons Manual-program args) " ")) - (if (string-match "\\`\\([^ \t/]*/\\)+" args-string) - (setq args-string - (substring args-string (match-end 0)))) - - (message "%s (running...)" args-string) - (apply 'call-process Manual-program nil '(t nil) nil args) - - (if (< (buffer-size) (if apropos-mode 20 200)) - (progn - (kill-buffer (current-buffer)) - (error "%s not found" args-string))) - - (message "%s (cleaning...)" args-string) - (Manual-nuke-nroff-bs apropos-mode) - (message "%s (done.)" args-string)) - (set-buffer-modified-p nil) - (Manual-mode) - (setq buffer (current-buffer)))))) - (let ((page (if section - (concat topic "(" section ")") - topic))) - (setq Manual-page-history - (cons (buffer-name) - (delete (buffer-name) Manual-page-history)) - Manual-page-minibuffer-history - (cons page (delete page Manual-page-minibuffer-history)))))) - - (message nil) - buffer)) + (if (or (equal section "-k") (member "-k" Manual-switches)) + (setq apropos-mode t)) + (setq bufname (concat "Man" (when apropos-mode " apropos") ": " topic + (when section (concat "(" section ")")))) + (if (setq buffer (get-buffer bufname)) + ;; Reselect an old man page buffer if it exists already. + (Manual-mode-and-display-buffer buffer) + (let ((args (append (if section (list section)) Manual-switches + (list topic))) + (process-environment + (list* "EMACS=t" "MAN_KEEP_FORMATTING=1" + "PAGER=cat" ;; apropos doesn't obery MANPAGER + process-environment)) + (page (if section (concat topic "(" section ")") topic)) + process) + (with-current-buffer (setq buffer (get-buffer-create bufname)) + (buffer-disable-undo buffer) + (defvar #424242=#:saved-window-configuration) + (set (make-local-variable '#424242#) (current-window-configuration))) + (message (concat + (mapconcat 'identity + (cons (file-name-nondirectory Manual-program) + args) " ") + " (running...)")) + (setf Manual-page-minibuffer-history + (cons page (delete page Manual-page-minibuffer-history)) + process (apply #'start-process (concat "Manual (" topic ")") + (if (fboundp 'process-stderr-buffer) + (list buffer (generate-new-buffer + " *Manual-standard-error*")) + buffer) + Manual-program args) + (process-filter process) 'Manual-process-filter + (process-sentinel process) + (lambda (process message) + (let* ((buffer (process-buffer process)) saved-point + process-stderr-buffer process-command) + (labels + ((chomp-buffer-string (buffer) + (buffer-substring + (point-min buffer) + (if (eql (char-before (point-max buffer)) ?\n) + (1- (point-max buffer)) + (point-max buffer)) + buffer))) + (when (member (process-status process) '(signal exit)) + (if (not (fboundp 'process-stderr-buffer)) + ;; XEmacs 21.4, no way to tell stderr from stdout + (when (not (eql (process-exit-status process) 0)) + (error (prog1 + (chomp-buffer-string buffer) + (kill-buffer buffer)))) + (setq process-stderr-buffer + (process-stderr-buffer process)) + (if (eql (process-exit-status process) 0) + (if (> (buffer-size process-stderr-buffer) 0) + (display-warning 'alert + (buffer-string process-stderr-buffer))) + (set-window-configuration + (symbol-value-in-buffer '#424242# buffer)) + (error (prog1 + (chomp-buffer-string + process-stderr-buffer) + (kill-buffer buffer) + (kill-buffer process-stderr-buffer)))) + (kill-buffer process-stderr-buffer)) + (setq saved-point (point buffer)) + ;; Flush any stashed data. + (Manual-process-filter process "" t) + (save-excursion + (setf process-command (process-command process) + (current-buffer) buffer + buffer-read-only nil + #424242# nil) + ;; This can't be done in the process filter because it + ;; depends on the number of lines of the complete + ;; output: + (Manual-nuke-nroff-bs-footers) + (or (member "-k" process-command) + ;; And this is tough to do in the filter because + ;; of the extra need to stash text that might + ;; overlap, when determining where the section + ;; titles are. + (Manual-boldface-section-titles)) + ; (message "%s (done.)" args-string) + (setf buffer-read-only t) + (set-buffer-modified-p nil buffer) + (goto-char saved-point) + (setf Manual-page-history + (cons (buffer-name) + (delete (buffer-name) + Manual-page-history))))))))))) + buffer)) ;;;###autoload (define-key help-map "\C-m" 'manual-entry) (defun Manual-mode () + "Major mode for viewing Unix manual entries. See `manual-entry'." (kill-all-local-variables) (setq buffer-read-only t) (use-local-map Manual-mode-map) + (set (make-local-variable 'Manual-mode) t) (set-syntax-table Manual-mode-syntax-table) (setq major-mode 'Manual-mode mode-name "Manual") ＠＠ -330,31 +774,69 ＠＠ nil t) (run-hooks 'Manual-mode-hook)) +(defun Manual-mode-and-display-buffer (buffer) + "Call `Manual-mode' in BUFFER, and then display it. + +BUFFER is displayed as described in `Manual-buffer-view-mode'." + (when (buffer-name buffer) ;; If we don't have a separate stderr, and + ;; man(3) has errored, BUFFER may have been + ;; killed. Don't choke on this. + (save-excursion (set-buffer buffer) (Manual-mode)) + (funcall (case Manual-buffer-view-mode + ((t) 'view-buffer) + ((nil) (or temp-buffer-show-function 'display-buffer)) + (otherwise 'view-buffer-other-window)) + buffer) + ;; view-minor-mode-map is a suppressed keymap; that is, usually + ;; self-inserting characters are explicitly undefined, and this + ;; un-definition overrides further keymaps that are searched when + ;; processing a keystroke. This means that the Manual mode local map is + ;; ignored for key-presses. Work around this by adding it to the + ;; minor-mode-map-alist ahead of view-minor-mode-map. + ;; view-minor-mode-map probably shouldn't be a suppressed keymap. + (if (or (and (assq 'Manual-mode minor-mode-map-alist) + (assq 'view-minor-mode minor-mode-map-alist) + (< (position 'view-minor-mode minor-mode-map-alist :key #'car) + (position 'Manual-mode minor-mode-map-alist :key #'car))) + (not (assq 'Manual-mode minor-mode-map-alist))) + (setq minor-mode-map-alist + (acons 'Manual-mode Manual-mode-map + (delete* 'Manual-mode minor-mode-map-alist :key #'car)))))) + (defun Manual-last-page () + "Switch to the last manual entry buffer viewed." (interactive) - (if Manual-page-history - (let ((page (pop Manual-page-history))) - (if page - (progn - (get-buffer page) - (cons Manual-page-history page) - (switch-to-buffer page)))) - (error "No manual page buffers found. Use `M-x manual-entry'"))) - - -(defmacro Manual-delete-char (n) - ;; in v19, delete-char is compiled as a function call, but delete-region - ;; is byte-coded, so it's much faster. (We were spending 40% of our time - ;; in delete-char alone.) - `(delete-region (point) (+ (point) ,n))) + (let ((list Manual-page-history)) + (while (or (not + (get-buffer + (car + (or + list + (error + 'invalid-argument + (substitute-command-keys + (format + "No %smanual page buffers found. Use \\[manual-entry]." + (if (eq 'Manual-mode major-mode) "other " "")))))))) + (eq (get-buffer (car list)) (current-buffer))) + (setq list (cdr list))) + (setq Manual-page-history + (cons (car list) (delete (car list) Manual-page-history))) + (switch-to-buffer (car Manual-page-history)))) ;; Hint: BS stands for more things than "back space" ;;;###autoload (defun Manual-nuke-nroff-bs (&optional apropos-mode) + ;; This function doesn't work as a process filter, and is mostly deprecated; + ;; it is still in use by #'pager-cleanup-hook, below, but + ;; #'pager-cleanup-hook is mostly not in use. (interactive "*") - (if (and Manual-use-rosetta-man (not apropos-mode)) - (call-process-region (point-min) (point-max) - Manual-use-rosetta-man t t nil) + (macrolet + ((Manual-delete-char (n) + ;; in v19, delete-char is compiled as a function call, but + ;; delete-region is byte-coded, so it's much faster. (We were + ;; spending 40% of our time in delete-char alone.) + `(delete-region (point) (+ (point) ,n)))) ;; ;; turn underlining into italics ;; ＠＠ -418,8 +900,8 ＠＠ (while (search-forward "\b" nil t) (Manual-delete-char -2)) - (Manual-nuke-nroff-bs-footers) - ) ;; not Manual-use-rosetta-man + (Manual-nuke-nroff-bs-footers)) + ;; ;; turn subsection header lines into bold ;; ＠＠ -462,25 +944,38 ＠＠ (forward-line 1)) ) - (if Manual-use-rosetta-man - nil - ;; Zap ESC7, ESC8, and ESC9 - ;; This is for Sun man pages like "man 1 csh" - (goto-char (point-min)) - (while (re-search-forward "\e[789]" nil t) - (replace-match ""))) - - (Manual-mouseify-xrefs apropos-mode) - ) + ;; Zap ESC7, ESC8, and ESC9 + ;; This is for Sun man pages like "man 1 csh" + (goto-char (point-min)) + (while (re-search-forward "\e[789]" nil t) + (replace-match "")) + (Manual-mouseify-xrefs (point-min) (point-max))) ;;;###autoload (defalias 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name +(defun Manual-nuke-nroff-bs-footers () + "Remove page footers from nroff output, for on-screen display. -(defun Manual-nuke-nroff-bs-footers () - "For info see comments in packages/man.el" +Some implementations of man use nroff to produce `paginated' output with a +page size of 66 lines, of which several are devoted to the header and footer. +Each header and footer consists of 3 newlines, one informational line, and +either 3 additional newlines in the case of Solaris nroff, or 2 additional +newlines in the case of groff. + +Of course, pagination is an incredibly stupid idea for online information +presentation instead of printing to real paper, and so some system vendors +have chosen to improve on traditional behavior by providing non-paginated +output. We conservatively autodetect whether the output is in fact paginated. +Misdetection is still possible, but highly unlikely. For starters, the output +from man must accidentally be a multiple of 66 lines. + +Note that if nroff spits out error messages, pages will be more than 66 lines +high, and we'll misdetect page starts. That's ok because standard nroff +doesn't do any diagnostics, and the `gnroff' wrapper for groff turns off error +messages for compatibility. (At least, it's supposed to.)" + ;; Autodetect and nuke headers and footers in nroff output. - (goto-char (point-min)) ;; first lose the status output ＠＠ -497,26 +992,6 ＠＠ (if (looking-at " *done\n") (delete-region (point) (match-end 0))))) - ;; Some implementations of man use nroff to produce "paginated" - ;; output with a page size of 66 lines, of which several are devoted - ;; to the header and footer. Each header and footer consists of 3 - ;; newlines, one informational line, and either 3 additional - ;; newlines in the case of Solaris nroff, or 2 additional newlines - ;; in the case of groff. - ;; - ;; Of course, pagination is an incredibly stupid idea for online - ;; information presentation instead of printing to real paper, and - ;; so some system vendors have chosen to improve on traditional - ;; behavior by providing non-paginated output. We conservatively - ;; autodetect whether the output is in fact paginated. Misdetection - ;; is still possible, but highly unlikely. For starters, the output - ;; from man must accidentally be a multiple of 66 lines. - ;; - ;; Note that if nroff spits out error messages, pages will be more - ;; than 66 lines high, and we'll misdetect page starts. That's ok - ;; because standard nroff doesn't do any diagnostics, and the - ;; "gnroff" wrapper for groff turns off error messages for - ;; compatibility. (At least, it's supposed to.) (block nuke-headers-and-footers (let* ((page-starts '()) (solaris-pagination ; 66 - 2 * (3 + 1 + 3) = 52 ＠＠ -545,7 +1020,7 ＠＠ (looking-at pagination) ; guaranteed to match, by first pass. ;; Delete footers, except merely trim whitespace from the last one. - (if (= (match-end 0) (point-max)) + (if (eql (match-end 0) (point-max)) (progn ;; last footer ;; Leave exactly two newlines before last footer. ＠＠ -579,7 +1054,7 ＠＠ (insert ?\n)))))) ;; Delete headers, except merely trim whitespace from the first one. - (if (= page-start (point-min)) + (if (eql page-start (point-min)) ;; Leave exactly two newlines between first header and body. (delete-region (match-end 1) (save-excursion (goto-char (match-end 1)) ＠＠ -604,72 +1079,94 ＠＠ (delete-region (point-min) (save-excursion (goto-char (point-min)) (skip-chars-forward "\n") - (point))) - ) + (point)))) + +(defun Manual-mouseify-xrefs (begin end) + "Make the manual cross-references between BEGIN and END clickable. -(defun Manual-mouseify-xrefs (&optional apropos-mode) - (goto-char (point-min)) - ;; skip the top line of manual pages, but not apropos listings. - (unless apropos-mode (forward-line 1)) - (let ((case-fold-search nil) - s e name splitp extent) - ;; possibly it would be faster to rewrite this expression to search for - ;; a less common sequence first (like "([0-9]") and then back up to see - ;; if it's really a match. This function is 15% of the total time, 13% - ;; of which is this call to re-search-forward. - (while (re-search-forward "[a-zA-Z_][-a-zA-Z0-9_.:]*([0-9][a-zA-Z0-9]*)" - nil t) +Clicking on a cross-reference of the form `ls(1)' calls `manual-entry' with an +appropriate TOPIC argument." + (let ((case-fold-search nil) s e name extent re-search-forward + found section-length) + (goto-char begin) + (while (progn + (while (and (not found) + (setq re-search-forward + (re-search-forward "([0-9]" end t))) + (goto-char (- (point) (length "(1"))) + (if (eql (skip-chars-backward "-a-zA-Z0-9_.:") 0) + ;; Don't limit the above #'skip-chars-forward by BEGIN, + ;; there may be parts of the command name before that. + (goto-char re-search-forward) + (if (looking-at + ;; This function used to just #'re-search-forward for + ;; the following regexp. It takes about a third of the + ;; time to #'re-search-forward for the shorter + ;; expression, above, and then to back up. + ;; + ;; This is reduced further by only calling + ;; #'Manual-mouseify-xrefs if there is a close + ;; parenthesis in the string supplied to + ;; #'Manual-process-filter; see that latter function. + "[a-zA-Z_][-a-zA-Z0-9_.:]*\\(([0-9][a-zA-Z0-9]*)\\)") + (setq found t) + (goto-char re-search-forward)))) + re-search-forward) (setq s (match-beginning 0) e (match-end 0) name (buffer-substring s e) - splitp nil) + section-length (- (match-end 1) (match-beginning 1)) + found nil) ;; Let the loop above continue next time around. - (goto-char s) - ;; if this is a hyphenated xref, we're on the second line, 1st char now. + ;; If there could be upper case letters in the section, downcase them. + (if (> section-length (length "(1)")) + (setq name (concat (substring name 0 (- section-length)) + (downcase (substring name (- section-length)))))) + + ;; If this is a hyphenated xref, we're on the second line, first char + ;; now. Deal with the part of the xref on the previous line. (when (progn (beginning-of-line) - (and (looking-at (concat "^[ \t]+" (regexp-quote name))) - (progn - (backward-char 1) - (or (equal (char-before) ?-) - (equal (char-before) ?\255))) - (setq s (progn - (skip-chars-backward "-\255_a-zA-Z0-9") - (point)) - name (buffer-substring s e)))) - (setq splitp t) - ;; delete the spaces and dash from `name' - (let (i) - (while (setq i (string-match "[-\255 \n\t]+" name i)) - (setq name (concat (substring name 0 i) - (substring name (match-end 0))) - i (1+ i))))) - - ;; if there are upper case letters in the section, downcase them. - (if (string-match "(.*[A-Z]+.*)$" name) - (setq name (concat (substring name 0 (match-beginning 0)) - (downcase (substring name (match-beginning 0)))))) - - ;; if the xref was hyphenated, don't highlight the indention spaces. - (if splitp - (progn - (setq extent (make-extent s (progn (goto-char s) (end-of-line) (point)))) - (set-extent-property extent 'man (list 'Manual-follow-xref name)) - (set-extent-property extent 'highlight t) - (set-extent-face extent 'man-xref) - (goto-char e) - (skip-chars-backward "-_a-zA-Z0-9()") - (setq extent (make-extent (point) e))) - (setq extent (make-extent s e))) - (set-extent-property extent 'man (list 'Manual-follow-xref name)) - (set-extent-property extent 'highlight t) - (set-extent-face extent 'man-xref) - (goto-char e)))) + (and (member* (char-before (1- (point))) '(?- ?\255)) + (looking-at (concat "^[ \t]+" (regexp-quote name))))) + (setf extent + ;; Make an extent just for the bit on the previous line. Either + ;; order for FROM, TO for the args is fine. + (make-extent + (progn (backward-char) (point)) + (progn (skip-chars-backward "-\255a-zA-Z0-9_.:") (point))) + ;; Construct the concatenated name, including the bits on both + ;; lines. Don't include the trailing ?- or ?\255 from this line. + name (concat (buffer-substring (point) (1- (point-at-eol))) + name) + ;; Now set the properties of this constructed extent. + (extent-property extent 'man) `(Manual-follow-xref ,name) + (extent-property extent 'highlight) t + (extent-property extent 'keymap) Manual-mode-xref-map + (extent-face extent) 'man-xref)) + ;; Create an extent reflecting the original matched regexp, using the + ;; NAME (possibly de-hyphenated). Create the appropriate interactive + ;; properties. + (setf extent (make-extent s e) + (extent-property extent 'man) `(Manual-follow-xref ,name) + (extent-property extent 'highlight) t + (extent-property extent 'keymap) Manual-mode-xref-map + (extent-face extent) 'man-xref) + (goto-char (min e (or re-search-forward 1)))))) (defun Manual-follow-xref (&optional name-or-event) "Invoke `manual-entry' on the cross-reference under the mouse. -When invoked noninteractively, the arg may be an xref string to parse instead." - (interactive "e") + +When invoked noninteractively, NAME-OR-EVENT may be a cross-reference string +to parse instead." + (interactive + (list (or current-mouse-event ;; also reflects current misc-user events + (and (eql last-command-char ?\C-m) + (let* ((extent (extent-at (point) nil 'man)) + (data (and extent (extent-property extent + 'man)))) + (and (eq 'Manual-follow-xref (car-safe data)) + (cadr data))))))) (if (eventp name-or-event) (let* ((p (event-point name-or-event)) (extent (and p (extent-at p ＠＠ -677,56 +1174,45 ＠＠ 'highlight))) (data (and extent (extent-property extent 'man)))) (if (eq (car-safe data) 'Manual-follow-xref) - (eval data) + (apply 'Manual-follow-xref (cdr data)) (error "no manual cross-reference there."))) - (or (manual-entry name-or-event) - ;; If that didn't work, maybe it's in a different section than the - ;; man page writer expected. For example, man pages tend assume - ;; that all user programs are in section 1, but X tends to generate - ;; makefiles that put things in section "n" instead... - (and (string-match "[ \t]*([^)]+)\\'" name-or-event) - (progn - (message "No entries found for %s; checking other sections..." - name-or-event) - (manual-entry - (substring name-or-event 0 (match-beginning 0)) - nil t)))))) + (manual-entry name-or-event))) -(defun Manual-popup-menu (&optional event) - "Pops up a menu of cross-references in this manual page. +(defun Manual-popup-menu (event) + "Pop up a menu of cross-references in this manual page. + If there is a cross-reference under the mouse button which invoked this command, it will be the first item on the menu. Otherwise, they are -on the menu in the order in which they appear in the buffer." +qon the menu in the order in which they appear in the buffer." (interactive "e") - (let ((buffer (current-buffer)) - (sep "---") - xref items) - (cond (event - (setq buffer (event-buffer event)) - (let* ((p (event-point event)) - (extent (and p (extent-at p buffer 'highlight))) - (data (and extent (extent-property extent 'man)))) - (if (eq (car-safe data) 'Manual-follow-xref) - (setq xref (nth 1 data)))))) - (if xref (setq items (list sep xref))) + (let* ((buffer (event-buffer event)) + (p (event-point event)) + (extent (and p (extent-at p buffer 'highlight))) + (data (and extent (extent-property extent 'man))) + (xref (and (eq (car-safe data) 'Manual-follow-xref) data)) + (sep "---") + (items (if xref (list xref)))) (map-extents #'(lambda (extent ignore) (let ((data (extent-property extent 'man))) (if (and (eq (car-safe data) 'Manual-follow-xref) - (not (member (nth 1 data) items))) - (setq items (cons (nth 1 data) items))) - nil)) - buffer) - (if (eq sep (car items)) (setq items (cdr items))) - (let ((popup-menu-titles t)) - (and (null items) (setq popup-menu-titles nil)) - (popup-menu - (cons "Manual Entry" - (mapcar #'(lambda (item) - (if (eq item sep) - item - (vector item - (list 'Manual-follow-xref item) t))) - (nreverse items))))))) + (not (member data items))) + (setq items (cons data items))) + nil)) + buffer nil nil nil nil 'man) + (popup-menu + (if items + `("Manual Entry" + ,＠(if xref `([,(cadr xref) ,xref t] ,sep)) + ,＠(menu-split-long-menu + (loop for item in (delete* xref items) + with result = nil + do (setq result + (cons (if (eq item sep) + item + (vector (cadr item) item t)) + result)) + finally return result))) + '("Manual Entry" ["No cross-references in this buffer" nil nil]))))) (defun pager-cleanup-hook () "cleanup man page if called via $PAGER" ＠＠ -759,3 +1245,5 ＠＠ (add-hook 'server-visit-hook 'pager-cleanup-hook) (provide 'man) + +;;; man.el ends here Repository URL: https://bitbucket.org/xemacs/edit-utils/ -- This is a commit notification from bitbucket.org. You are receiving this because you have the service enabled, addressing the recipient of this email.