From: Arthur Gleckler Date: Wed, 18 Sep 1991 15:59:26 +0000 (+0000) Subject: Add autoload library to display UNIX manual pages. X-Git-Tag: 20090517-FFI~10201 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=107d48affad95d8d22ff60e64d3e99f1d63059a7;p=mit-scheme.git Add autoload library to display UNIX manual pages. --- diff --git a/v7/src/edwin/manual.scm b/v7/src/edwin/manual.scm index 711adf33c..4f23bb796 100644 --- a/v7/src/edwin/manual.scm +++ b/v7/src/edwin/manual.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/manual.scm,v 1.1 1991/09/17 20:36:42 arthur Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/manual.scm,v 1.2 1991/09/18 15:59:26 arthur Exp $ ;;; ;;; Copyright (c) 1991 Massachusetts Institute of Technology ;;; @@ -46,79 +46,12 @@ (declare (usual-integrations)) -;;; MAKE THIS A LOAD-OPTION! - -;;; THIS PAGE SHOULD BE IN $se/paths.scm! - -(define manual-program false) - -;; Prefix for directories containing formatted manual pages. Append a -;; section-number or section-name to get a directory name. -(define manual-formatted-dir-prefix false) - -(set! manual-program - (if (file-exists? "/usr/bin/man") - "/usr/bin/man" - "/usr/ucb/man")) - -;; Note that /usr/man/cat is not really right for this on sysV; nothing is, -;; judging by the list of directories below. You can't get the dir -;; for a section by appending the section number to any one prefix. -;; But it turns out that a string that's wrong does no harm here. -(set! manual-formatted-dir-prefix - (if (file-exists? "/usr/man/cat.C") ;; Check for Xenix. - "/usr/man/cat." - "/usr/man/cat")) - -;; IS THIS GOING TO BE TOO SLOW? I DID THIS TO AVOID HAVING TO -;; CLASSIFY BY OPERATING SYSTEM. - -;; List of directories containing formatted manual pages. -(set! manual-formatted-dirlist - (list-transform-positive - '("/usr/catman/u_man/man1" "/usr/catman/u_man/man6" - "/usr/catman/p_man/man2" "/usr/catman/p_man/man3" - "/usr/catman/p_man/man4" "/usr/catman/p_man/man5" - "/usr/catman/a_man/man1" "/usr/catman/a_man/man7" - "/usr/catman/a_man/man8" "/usr/catman/local" - "/usr/man/cat1" "/usr/man/cat2" - "/usr/man/cat3" "/usr/man/cat4" - "/usr/man/cat5" "/usr/man/cat6" - "/usr/man/cat7" "/usr/man/cat8" - "/usr/man/catl" "/usr/man/catn" - "/usr/man/cat.C" "/usr/man/cat.CP" - "/usr/man/cat.CT" "/usr/man/cat.DOS/" - "/usr/man/cat.F" "/usr/man/cat.HW" - "/usr/man/cat.M/" "/usr/man/cat.S" - "/usr/man/cat.LOCAL" "/usr/man/cat1" - "/usr/man/cat2" "/usr/man/cat3" - "/usr/man/cat4" "/usr/man/cat5" - "/usr/man/cat6" "/usr/man/cat7" - "/usr/man/cat1m" "/usr/man/cat8" - "/usr/local/man/cat1" "/usr/local/man/cat2" - "/usr/local/man/cat3" "/usr/local/man/cat4" - "/usr/local/man/cat5" "/usr/local/man/cat6" - "/usr/local/man/cat7" "/usr/local/man/cat1m" - "/usr/local/man/cat8" "/usr/contrib/man/cat1" - "/usr/contrib/man/cat2" "/usr/contrib/man/cat3" - "/usr/contrib/man/cat4" "/usr/contrib/man/cat5" - "/usr/contrib/man/cat6" "/usr/contrib/man/cat7" - "/usr/contrib/man/cat1m" "/usr/contrib/man/cat8") - file-exists?)) - (define-variable manual-entry-reuse-buffer? - "If true, MANUAL-ENTRY uses buffer *Manual Entry* for all entries. + "If true, MANUAL-ENTRY uses buffer *Manual-Entry* for all entries. Otherwise, a new buffer is created for each topic." - true + false boolean?) -(define (manual-string-match pattern string) - (re-match-string-forward - (re-compile-pattern pattern false) - true - false - string)) - (define-command manual-entry "Display the Unix manual entry for TOPIC. TOPIC is either the title of the entry, or has the form TITLE(SECTION) @@ -126,8 +59,12 @@ where SECTION is the desired section of the manual, as in `tty(4)'." "sManual entry (topic): " (lambda (topic #!optional section) (if (and (default-object? section) - (manual-string-match - "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" + (re-match-string-forward + (re-compile-pattern + "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" + false) + true + false topic)) (begin (set! section @@ -135,166 +72,68 @@ where SECTION is the desired section of the manual, as in `tty(4)'." (set! topic (substring topic (match-beginning 1) (match-end 1)))) (set! section false)) - (let* ((section-suffix - (if section (string-append "(" section ")") "")) - (buffer-name - (if (ref-variable manual-entry-reuse-buffer?) - "*Manual Entry*" - (string-append - "*" + (let ((buffer-name + (if (ref-variable manual-entry-reuse-buffer?) + "*Manual-Entry*" + (string-append + "*" + topic + (if section (string-append "(" section ")") "") + "-Manual-Entry*")))) + (let ((buffer (temporary-buffer buffer-name))) + (message "Invoking man " + (if section (string-append section " ") "") topic - section-suffix - " Manual Entry*")))) - (if - (with-output-to-temporary-buffer buffer-name - (lambda () - (let ((buffer (find-buffer buffer-name))) - (with-selected-buffer buffer - (lambda () - (message "Looking for formatted entry for " - topic - section-suffix - "...") - (let ( - ;WHAT SHOULD I DO ABOUT THIS? : - (case-fold-search nil)) - (cond ((and section - (let ((prefix manual-formatted-dir-prefix)) - (or (let ((name (string-append - prefix - (substring section 0 1) - "/" - topic "." section))) - (and (file-exists? name) - name)) - (let ((name (string-append - prefix - section - "/" - topic "." section))) - (and (file-exists? name) - name))))) - => insert-man-file) - (else - (let loop ((dirlist manual-formatted-dirlist)) - (if (not (null? dirlist)) - (let ((directory (car dirlist))) - (let ((name (string-append - directory "/" topic "." - (or section - (substring - directory - (1+ (or (manual-string-match - "\\.[^./]*$" directory) - -2))))))) - (if (file-exists? name) - (insert-man-file name) - (call-with-current-continuation - (lambda (ignore-error) - (bind-condition-handler - condition-type:file-error - (lambda (condition) - (ignore-error unspecific)) - (lambda () - (let loop ((completions - (filename-completions-list - (pathname-new-directory - (->pathname (string-append topic "." (or section ""))) - directory)))) - (if (not (null? completions)) - (begin - (insert-man-file (string-append directory "/" (car completions))) - (loop (cdr completions)))))))))) - (loop (cdr dirlist)))))))) - (if (= (buffer-size) 0) - (progn - (message "No formatted entry, invoking man " - (if section (string-append section " ") "") - topic - "...") - (if section - (call-process manual-program nil t nil section topic) - (call-process manual-program nil t nil topic)))) - (if (< (buffer-size) 80) - (let ((start (buffer-start buffer))) - (buffer-not-modified! buffer) - (extract-string start (line-end start 0))) - (begin - (message "Cleaning manual entry for %s..." topic) - (nuke-nroff-bs buffer) - (buffer-not-modified! buffer) - (set-buffer-read-only! buffer) - (message "Manual page ready") - false)))))))) - (begin - (kill-buffer buffer-name) - (editor-failure error-string)))))) + "...") + (let ((manual-program + (if (file-exists? "/usr/bin/man") + "/usr/bin/man" + "/usr/ucb/man"))) + (if section + (shell-command + (string-append manual-program " " section " " topic) + (buffer-point buffer)) + (shell-command + (string-append manual-program " " topic) + (buffer-point buffer)))) + (message "Cleaning manual entry for " topic "...") + (nuke-nroff-bs buffer) + (buffer-not-modified! buffer) + (set-buffer-read-only! buffer) + (set-buffer-point! buffer (buffer-start buffer)) + (pop-up-buffer buffer false) + (message "Manual page ready"))))) (define (nuke-nroff-bs buffer) - ;; Nuke underlining and overstriking (only by the same letter) + (let ((start (buffer-start buffer)) (end (buffer-end buffer))) - (let loop ((point - (search-forward "\b" start end false))) - (if point - (let* ((two-back (mark- point 2)) - (preceding (extract-right-char two-back)) - (following (extract-right-char point))) - (cond ((char=? preceding following) - ;; x\bx - (region-delete! (make-region point two-back))) - ((char=? preceding #\_) - ;; _\b - (region-delete! (make-region point two-back))) - ((char=? following #\_) - ;; \b_ - (region-delete! - (make-region (mark-1+ point) (mark1+ point))))) - (loop (search-forward "\b" point end false))))) - ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)" - (let ((pattern "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Z]+)\\).*\\1$")) - (let loop ((point - (re-search-forward pattern start end false))) + ;; Nuke underlining and overstriking (only by the same letter) + (let ((pattern "\\(_\b\\|\b.\\)")) + (let loop ((point (re-search-forward pattern start end false))) (if point (begin (replace-match "" false true) - (loop (re-search-forward pattern point end false)))))) + (loop (re-search-forward + pattern (re-match-start 0) end false)))))) - ;; Nuke footers: "Printed 12/3/85 27 April 1981 1" - (let ((pattern - (cond ((eq? system-type 'hpux) - "^[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*$") - ((eq? system-type 'usg-unix-v) - "^ *Page [0-9]*.*(printed [0-9/]*)$") - (else - "^\\(Printed\\|Sun Release\\) [0-9].*[0-9]$")))) - (let loop ((point - (re-search-forward pattern start end false))) + ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)" + (let ((pattern "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Z]+)\\).*\\1$")) + (let loop ((point (re-search-forward pattern start end false))) (if point - (begin (replace-match "" false true) - (loop (re-search-forward pattern point end false)))))) + (begin + (replace-match "" false true) + (loop (re-search-forward + pattern (re-match-start 0) end false)))))) ;; Crunch blank lines (let ((pattern "\n\n\n\n*")) - (let loop ((point - (re-search-forward pattern start end false))) + (let loop ((point (re-search-forward pattern start end false))) (if point (begin (replace-match "\n\n" false true) - (loop (re-search-forward pattern point end false)))))) + (loop (re-search-forward + pattern (re-match-start 0) end false)))))) ;; Nuke blanks lines at start. - (region-delete! - (make-region start - (skip-chars-forward "\n" start end 'limit))))) - -(define (insert-man-file name) - (let ((buffer (current-buffer)) - (pathname (->pathname name))) - (if (or (string=? "Z" (pathname-type pathname)) - (manual-string-match "/cat[0-9][a-z]?\\.Z/" name)) - (call-process "zcat" name t nil) - (if (string=? "z" (pathname-type pathname)) - (call-process "pcat" nil t nil name) - (insert-file (buffer-end buffer) name))) - (set-buffer-point! buffer (buffer-end buffer)))) \ No newline at end of file + (delete-string start (skip-chars-forward "\n" start end 'limit)))) \ No newline at end of file