Mercurial > hg > xemacs-beta

comparison lisp/packages/man.el @ 181:bfd6434d15b3 r20-3b17

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b17
author cvs
date Mon, 13 Aug 2007 09:53:19 +0200
parents 8eaf7971accc
children e121b013d1f0
comparison
equal deleted inserted replaced
180:add28d59e586 181:bfd6434d15b3
1 ;;; man.el --- browse UNIX manual pages 1 ;;; man.el --- browse UNIX manual pages
2 ;; Keywords: help 2 ;; Keywords: help
3 3
4 ;; Copyright (C) 1985, 1993, 1994, 1996 Free Software Foundation, Inc. 4 ;; Copyright (C) 1985, 1993, 1994, 1996, 1997 Free Software Foundation, Inc.
5 ;; 5 ;;
6 ;; This file is part of XEmacs. 6 ;; This file is part of XEmacs.
7 7
8 ;; XEmacs is free software; you can redistribute it and/or modify it 8 ;; XEmacs is free software; you can redistribute it and/or modify it
9 ;; under the terms of the GNU General Public License as published by 9 ;; under the terms of the GNU General Public License as published by
178 (if (equal default "") "Manual entry: " 178 (if (equal default "") "Manual entry: "
179 (concat "Manual entry: (default " default ") ")) 179 (concat "Manual entry: (default " default ") "))
180 nil 'Manual-page-minibuffer-history))) 180 nil 'Manual-page-minibuffer-history)))
181 (if (equal thing "") default thing)) 181 (if (equal thing "") default thing))
182 (prefix-numeric-value current-prefix-arg))) 182 (prefix-numeric-value current-prefix-arg)))
183 ;;(interactive "sManual entry (topic): \np")
184 (or arg (setq arg 1)) 183 (or arg (setq arg 1))
185 (let (section apropos-mode) 184 (let (section apropos-mode)
186 (let ((case-fold-search nil)) 185 (let ((case-fold-search nil))
187 (if (and (null section) 186 (if (and (null section)
188 (string-match "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" 187 (string-match "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'"
189 topic)) 188 topic))
190 (setq section (substring topic (match-beginning 2) 189 (setq section (match-string 2 topic)
191 (match-end 2)) 190 topic (match-string 1 topic))
192 topic (substring topic (match-beginning 1)
193 (match-end 1)))
194 (if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic) 191 (if (string-match "\\`[ \t]*-k[ \t]+\\([^ \t]+\\)\\'" topic)
195 (setq section "-k" 192 (setq section "-k"
196 topic (substring topic (match-beginning 1)))))) 193 topic (match-string 1 topic)))))
197 194
198 (when Manual-snip-subchapter 195 (when Manual-snip-subchapter
199 ;; jwz: turn section "3x11" and "3n" into "3". 196 ;; jwz: turn section "3x11" and "3n" into "3".
200 (if (and section (string-match "\\`\\([0-9]+\\)[^0-9]" section)) 197 (if (and section (string-match "\\`\\([0-9]+\\)[^0-9]" section))
201 (setq section (substring section 0 (match-end 1))))) 198 (setq section (match-string 1 section))))
199
202 (if (equal section "-k") 200 (if (equal section "-k")
203 (setq apropos-mode t)) 201 (setq apropos-mode t))
204 202
205 (let ((bufname (cond (apropos-mode 203 (let ((bufname (flet
206 (concat "*man apropos " topic "*")) 204 ((maybe-star ()
207 (t 205 (if buffers-menu-submenus-for-groups-p
208 (concat "*man " topic 206 ""
209 (if section (concat "." section) "") 207 "*")))
210 "*")))) 208 (if apropos-mode
209 (concat (maybe-star) "man apropos " topic (maybe-star))
210 (concat (maybe-star)
211 topic
212 (if section (concat "(" section ")") "")
213 (maybe-star)))))
211 (temp-buffer-show-function 214 (temp-buffer-show-function
212 (cond ((eq 't Manual-buffer-view-mode) 215 (cond ((eq 't Manual-buffer-view-mode)
213 'view-buffer) 216 'view-buffer)
214 ((eq 'nil Manual-buffer-view-mode) 217 ((eq 'nil Manual-buffer-view-mode)
215 temp-buffer-show-function) 218 temp-buffer-show-function)
253 (kill-buffer (current-buffer)) 256 (kill-buffer (current-buffer))
254 (error "%s not found" args-string))) 257 (error "%s not found" args-string)))
255 258
256 (message "%s (cleaning...)" args-string) 259 (message "%s (cleaning...)" args-string)
257 (Manual-nuke-nroff-bs apropos-mode) 260 (Manual-nuke-nroff-bs apropos-mode)
258 (message "%s (done.)" args-string) 261 (message "%s (done.)" args-string))
259 )
260
261 (set-buffer-modified-p nil) 262 (set-buffer-modified-p nil)
262 (Manual-mode) 263 (Manual-mode)))))
263 )))) 264
264 (setq Manual-page-history 265 (let ((page (flet
265 (cons (buffer-name) 266 ((maybe-star ()
266 (delete (buffer-name) Manual-page-history))))) 267 (if buffers-menu-submenus-for-groups-p
268 ""
269 "*")))
270 (if section
271 (concat (maybe-star) topic "(" section ")" (maybe-star))
272 topic))))
273 (setq Manual-page-history
274 (cons (buffer-name)
275 (delete (buffer-name) Manual-page-history))
276 Manual-page-minibuffer-history
277 (cons page (delete page Manual-page-minibuffer-history))))))
278
267 (message nil) 279 (message nil)
268 t) 280 t)
269 281
270 (defun Manual-mode () 282 (defun Manual-mode ()
271 (kill-all-local-variables) 283 (kill-all-local-variables)
278 ;; overran by a couple of chars. 290 ;; overran by a couple of chars.
279 (setq truncate-lines t) 291 (setq truncate-lines t)
280 ;; turn off horizontal scrollbars in this buffer 292 ;; turn off horizontal scrollbars in this buffer
281 (when (featurep 'scrollbar) 293 (when (featurep 'scrollbar)
282 (set-specifier scrollbar-height (cons (current-buffer) 0))) 294 (set-specifier scrollbar-height (cons (current-buffer) 0)))
295 (make-local-hook 'kill-buffer-hook)
296 (add-hook 'kill-buffer-hook #'(lambda ()
297 (setq Manual-page-history
298 (delete (buffer-name)
299 Manual-page-history)))
300 nil t)
283 (run-hooks 'Manual-mode-hook)) 301 (run-hooks 'Manual-mode-hook))
284 302
285 (defun Manual-last-page () 303 (defun Manual-last-page ()
286 (interactive) 304 (interactive)
287 (while (or (not (get-buffer (car (or Manual-page-history 305 (if Manual-page-history
288 (error "No more history."))))) 306 (let ((page (pop Manual-page-history)))
289 (eq (get-buffer (car Manual-page-history)) (current-buffer))) 307 (if page
290 (setq Manual-page-history (cdr Manual-page-history))) 308 (progn
291 (switch-to-buffer (car Manual-page-history))) 309 (get-buffer page)
310 (cons Manual-page-history page)
311 (switch-to-buffer page))))
312 (error "No manual page buffers found. Use `M-x manual-entry'")))
292 313
293 314
294 (defmacro Manual-delete-char (n) 315 (defmacro Manual-delete-char (n)
295 ;; in v19, delete-char is compiled as a function call, but delete-region 316 ;; in v19, delete-char is compiled as a function call, but delete-region
296 ;; is byte-coded, so it's much faster. (We were spending 40% of our time 317 ;; is byte-coded, so it's much faster. (We were spending 40% of our time
392 413
393 (fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name 414 (fset 'nuke-nroff-bs 'Manual-nuke-nroff-bs) ; use old name
394 415
395 416
396 (defun Manual-nuke-nroff-bs-footers () 417 (defun Manual-nuke-nroff-bs-footers ()
418 "For info see comments in packages/man.el"
397 ;; Nuke headers and footers. 419 ;; Nuke headers and footers.
398 ;; 420 ;;
399 ;; nroff assumes pages are 66 lines high. We assume that, and that the 421 ;; nroff assumes pages are 66 lines high. We assume that, and that the
400 ;; first and last line on each page is expendible. There is no way to 422 ;; first and last line on each page is expendible. There is no way to
401 ;; tell the difference between a page break in the middle of a paragraph 423 ;; tell the difference between a page break in the middle of a paragraph
490 )) 512 ))
491 513
492 (defun Manual-mouseify-xrefs () 514 (defun Manual-mouseify-xrefs ()
493 (goto-char (point-min)) 515 (goto-char (point-min))
494 (let ((case-fold-search nil) 516 (let ((case-fold-search nil)
495 s e name extent) 517 s e name splitp extent)
496 ;; possibly it would be faster to rewrite this expression to search for 518 ;; possibly it would be faster to rewrite this expression to search for
497 ;; a less common sequence first (like "([0-9]") and then back up to see 519 ;; a less common sequence first (like "([0-9]") and then back up to see
498 ;; if it's really a match. This function is 15% of the total time, 13% 520 ;; if it's really a match. This function is 15% of the total time, 13%
499 ;; of which is this call to re-search-forward. 521 ;; of which is this call to re-search-forward.
500 (while (re-search-forward "[a-zA-Z_][-a-zA-Z0-9_.:]*([0-9][a-zA-Z0-9]*)" 522 (while (re-search-forward "[a-zA-Z_][-a-zA-Z0-9_.:]*([0-9][a-zA-Z0-9]*)"
501 nil t) 523 nil t)
502 (setq s (match-beginning 0) 524 (setq s (match-beginning 0)
503 e (match-end 0) 525 e (match-end 0)
504 name (buffer-substring s e)) 526 name (buffer-substring s e)
527 splitp nil)
528
505 (goto-char s) 529 (goto-char s)
506 (skip-chars-backward " \t") 530 ;; if this is a hyphenated xref, we're on the second line, 1st char now.
507 (if (and (bolp) (not (bobp)) 531
508 (progn (backward-char 1) (equal (char-before) ?-))) 532 (when (progn
509 (progn 533 (beginning-of-line)
510 (setq s (point)) 534 (and (looking-at (concat "^[ \t]+" (regexp-quote name)))
511 (skip-chars-backward "-a-zA-Z0-9_.:") 535 (progn
512 (setq name (concat (buffer-substring (point) 536 (backward-char 1)
513 (if (>= s 0) 537 (or (equal (char-before) ?-)
514 (1- s) 538 (equal (char-before) ?\255)))
515 0)) 539 (setq s (progn
516 name)) 540 (skip-chars-backward "-\255_a-zA-Z0-9")
517 (setq s (point)))) 541 (point))
542 name (buffer-substring s e))))
543 (setq splitp t)
544 ;; delete the spaces and dash from `name'
545 (let (i)
546 (while (setq i (string-match "[-\255 \n\t]+" name i))
547 (setq name (concat (substring name 0 i)
548 (substring name (match-end 0)))
549 i (1+ i)))))
550
518 ;; if there are upper case letters in the section, downcase them. 551 ;; if there are upper case letters in the section, downcase them.
519 (if (string-match "(.*[A-Z]+.*)$" name) 552 (if (string-match "(.*[A-Z]+.*)$" name)
520 (setq name (concat (substring name 0 (match-beginning 0)) 553 (setq name (concat (substring name 0 (match-beginning 0))
521 (downcase (substring name (match-beginning 0)))))) 554 (downcase (substring name (match-beginning 0))))))
522 ;; (setq already-fontified (extent-at s)) 555
523 (setq extent (make-extent s e)) 556 ;; if the xref was hyphenated, don't highlight the indention spaces.
557 (if splitp
558 (progn
559 (setq extent (make-extent s (progn (goto-char s) (end-of-line) (point))))
560 (set-extent-property extent 'man (list 'Manual-follow-xref name))
561 (set-extent-property extent 'highlight t)
562 (set-extent-face extent 'man-xref)
563 (goto-char e)
564 (skip-chars-backward "-_a-zA-Z0-9()")
565 (setq extent (make-extent (point) e)))
566 (setq extent (make-extent s e)))
524 (set-extent-property extent 'man (list 'Manual-follow-xref name)) 567 (set-extent-property extent 'man (list 'Manual-follow-xref name))
525 (set-extent-property extent 'highlight t) 568 (set-extent-property extent 'highlight t)
526 ;; (if (not already-fontified)...
527 (set-extent-face extent 'man-xref) 569 (set-extent-face extent 'man-xref)
528 (goto-char e)))) 570 (goto-char e))))
529 571
530 (defun Manual-follow-xref (&optional name-or-event) 572 (defun Manual-follow-xref (&optional name-or-event)
531 "Invoke `manual-entry' on the cross-reference under the mouse. 573 "Invoke `manual-entry' on the cross-reference under the mouse.
559 command, it will be the first item on the menu. Otherwise, they are 601 command, it will be the first item on the menu. Otherwise, they are
560 on the menu in the order in which they appear in the buffer." 602 on the menu in the order in which they appear in the buffer."
561 (interactive "e") 603 (interactive "e")
562 (let ((buffer (current-buffer)) 604 (let ((buffer (current-buffer))
563 (sep "---") 605 (sep "---")
564 (prefix "Show Manual Page for ")
565 xref items) 606 xref items)
566 (cond (event 607 (cond (event
567 (setq buffer (event-buffer event)) 608 (setq buffer (event-buffer event))
568 (let* ((p (event-point event)) 609 (let* ((p (event-point event))
569 (extent (and p (extent-at p buffer 'highlight))) 610 (extent (and p (extent-at p buffer 'highlight)))
577 (not (member (nth 1 data) items))) 618 (not (member (nth 1 data) items)))
578 (setq items (cons (nth 1 data) items))) 619 (setq items (cons (nth 1 data) items)))
579 nil)) 620 nil))
580 buffer) 621 buffer)
581 (if (eq sep (car items)) (setq items (cdr items))) 622 (if (eq sep (car items)) (setq items (cdr items)))
582 (let ((popup-menu-titles nil)) 623 (let ((popup-menu-titles t))
624 (and (null items) (setq popup-menu-titles nil))
583 (popup-menu 625 (popup-menu
584 (cons "Manual Entry" 626 (cons "Manual Entry"
585 (mapcar #'(lambda (item) 627 (mapcar #'(lambda (item)
586 (if (eq item sep) 628 (if (eq item sep)
587 item 629 item
588 (vector (concat prefix item) 630 (vector item
589 (list 'Manual-follow-xref item) t))) 631 (list 'Manual-follow-xref item) t)))
590 (nreverse items))))))) 632 (nreverse items)))))))
591 633
592 (defun pager-cleanup-hook () 634 (defun pager-cleanup-hook ()
593 "cleanup man page if called via $PAGER" 635 "cleanup man page if called via $PAGER"
604 (goto-char (- (point) 1))) 646 (goto-char (- (point) 1)))
605 (if (looking-at "\\([a-zA-Z0-9]+\\)[ \t]*(") 647 (if (looking-at "\\([a-zA-Z0-9]+\\)[ \t]*(")
606 (setq manpage (buffer-substring (match-beginning 1) 648 (setq manpage (buffer-substring (match-beginning 1)
607 (match-end 1))) 649 (match-end 1)))
608 (setq manpage "???")) 650 (setq manpage "???"))
609 (setq buffer 651 (flet
610 (rename-buffer 652 ((maybe-star ()
611 (generate-new-buffer-name (concat "*man " manpage "*")))) 653 (if buffers-menu-submenus-for-groups-p
654 "*"
655 "")))
656 (setq buffer
657 (rename-buffer
658 (generate-new-buffer-name (concat (maybe-star)
659 manpage
660 (maybe-star))))))
612 (setq buffer-file-name nil) 661 (setq buffer-file-name nil)
613 (goto-char (point-min)) 662 (goto-char (point-min))
614 (insert (format "%s\n" buf-name)) 663 (insert (format "%s\n" buf-name))
615 (goto-char (point-min)) 664 (goto-char (point-min))
616 (buffer-disable-undo buffer) 665 (buffer-disable-undo buffer)