From: Brian A. LaMacchia Date: Fri, 10 Jan 1992 18:47:56 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~10007 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cb3e54d12295fc37c262f28379c5eaf1fdd4b18e;p=mit-scheme.git Initial revision --- diff --git a/v7/src/edwin/techinfo.scm b/v7/src/edwin/techinfo.scm new file mode 100644 index 000000000..8558bd58b --- /dev/null +++ b/v7/src/edwin/techinfo.scm @@ -0,0 +1,420 @@ +;;; -*- Scheme -*- + +;; Copyright (c) 1992 Massachusetts Institute of Technology +;; +;; This material was developed by the Scheme project at the Massachusetts +;; Institute of Technology, Department of Electrical Engineering and +;; Computer Science. Permission to copy this software, to redistribute +;; it, and to use it for any purpose is granted, subject to the following +;; restrictions and understandings. +;; +;; 1. Any copy made of this software must include this copyright notice +;; in full. +;; +;; 2. Users of this software agree to make their best efforts (a) to +;; return to the MIT Scheme project any improvements or extensions that +;; they make, so that these may be included in future releases; and (b) +;; to inform MIT of noteworthy uses of this software. +;; +;; 3. All materials developed as a consequence of the use of this +;; software shall duly acknowledge such use, in accordance with the usual +;; standards of acknowledging credit in academic research. +;; +;; 4. MIT has made no warrantee or representation that the operation of +;; this software will be error-free, and MIT is under no obligation to +;; provide any services, by way of maintenance, update, or otherwise. +;; +;; 5. In conjunction with products arising from the use of this material, +;; there shall be no use of the name of the Massachusetts Institute of +;; Technology nor of any adaptation thereof in any advertising, +;; promotional, or sales literature without prior written consent from +;; MIT in each case. + +;;; +;;; techinfo.scm - Edwin mode for accessing TechInfo database +;;; requires ability to "attach" Athena filesystems +;;; +;;; Author: Brian A. LaMacchia -- bal@zurich.ai.mit.edu +;;; +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/techinfo.scm,v 1.1 1992/01/10 18:47:56 bal Exp $ +;;; + +(define-variable techinfo-web-buffer + "Buffer which contains a copy of the TechInfo web file." + false) + +(define-variable techinfo-buffer + "Buffer used for displaying TechInfo information." + false) + +(define-variable techinfo-current-node-list + "Cached list of web file information for the current node." + false) + +(define-variable techinfo-attached-filesystems + "List of filesystems already attached by this run of TechInfo. +If a filesystem name appears in this list subsequent calls to +attach will not be made." + '()) + +(define-variable techinfo-parent-list + "List of parent nodes from this node to the root node." + false) + +(define-variable techinfo-history-list + "List of TechInfo nodes previously visited." + false) + +(define-variable techinfo-need-to-attach-afs + "True if AFS is not available by default, and the NFS->AFS +translator on Atalanta is needed. At Tech Square this variable +is set to t. At Athena it is nil." + true) + +;;; Returns the line of the TechInfo web file which corresponds to node NUMBER. +(define (techinfo-find-line string) + (let ((web-buffer (ref-variable techinfo-web-buffer))) + (let ((the-mark + (re-search-forward + (string-append "^" string ":") + (buffer-start web-buffer) + (buffer-end web-buffer)))) + (extract-string (line-start the-mark 0) (line-end the-mark 0))))) + +;;; Takes one arg, STRING, which is a line from the TechInfo web file. +;;; Parses the line and returns a list of the information contained. +;;; Usually the result of (techinfo-find-line n) is passed directly to +;;; this function. +(define (techinfo-parse-line string) + (define (techinfo-internal-parse string char) + (let loop ((start 0) + (end (string-length string)) + (the-list '())) + (let ((next-index + (substring-find-next-char string start end char))) + (if next-index + (loop (1+ next-index) end (cons (substring string start next-index) the-list)) + (cons (string-tail string start) the-list))))) + (let ((the-list-1 (techinfo-internal-parse string #\:))) + (reverse + (cons + (reverse (techinfo-internal-parse (car the-list-1) #\,)) + (cons + (reverse (techinfo-internal-parse (cadr the-list-1) #\,)) + (cddr the-list-1)))))) + +(define (techinfo-line/number techinfo-line) + (list-ref techinfo-line 0)) + +(define (techinfo-line/unknown2 techinfo-line) + (list-ref techinfo-line 1)) + +(define (techinfo-line/unknown3 techinfo-line) + (list-ref techinfo-line 2)) + +(define (techinfo-line/unknown4 techinfo-line) + (list-ref techinfo-line 3)) + +(define (techinfo-line/title techinfo-line) + (list-ref techinfo-line 4)) + +(define (techinfo-line/source techinfo-line) + (list-ref techinfo-line 5)) + +(define (techinfo-line/filesystem techinfo-line) + (list-ref techinfo-line 6)) + +(define (techinfo-line/filename techinfo-line) + (list-ref techinfo-line 7)) + +(define (techinfo-line/parent-list techinfo-line) + (list-ref techinfo-line 8)) + +(define (techinfo-line/children-list techinfo-line) + (list-ref techinfo-line 9)) + +(define (techinfo-display-node node-number) + (let ((node-list (techinfo-parse-line (techinfo-find-line node-number)))) + (set-variable! techinfo-history-list + (cons (techinfo-line/number node-list) + (ref-variable techinfo-history-list))) + (if (string=? (techinfo-line/filesystem node-list) "") + (let ((foo (member (cadr (ref-variable techinfo-history-list)) + (techinfo-line/children-list node-list)))) + (if foo + (techinfo-display-internal-node + node-list + (1+ (- (length (techinfo-line/children-list node-list)) (length foo)))) + (techinfo-display-internal-node node-list))) + (techinfo-display-leaf-node node-list)))) + +(define (techinfo-insert-node-header node-list) + (let ((siblings (techinfo-line/children-list + (techinfo-parse-line (techinfo-find-line + (car (ref-variable techinfo-parent-list))))))) + (let ((rest (member (techinfo-line/number + (ref-variable techinfo-current-node-list)) siblings))) + (if rest + (let* ((num (- (length siblings) (length rest))) + (prev (-1+ num)) + (next (1+ num)) + (left-string + (if (>= prev 0) + (string-append + "Prev: " + (techinfo-line/title (techinfo-parse-line + (techinfo-find-line (list-ref siblings prev))))) + "Prev: (none)")) + (right-string + (if (< next (length siblings)) + (string-append + "Next: " + (techinfo-line/title (techinfo-parse-line + (techinfo-find-line (list-ref siblings next))))) + "Next: (none)"))) + (let ((padding (- (ref-variable fill-column) (string-length right-string)))) + (insert-string + (if (> padding (+ 10 (string-length left-string))) + (string-pad-right left-string padding) + (string-append left-string (make-string 10 #\space))))) + (insert-string right-string) + (insert-string "\n"))))) + (insert-string "\n") + (insert-string (techinfo-line/title node-list)) + (center-line (current-point)) + (insert-string "\n\n")) + +(define (techinfo-display-internal-node node-list #!optional placement) + (set-variable! techinfo-current-node-list node-list) + (set-buffer-writeable! (current-buffer)) + (set-current-point! (buffer-start (current-buffer))) + (kill-string (buffer-start (current-buffer)) + (buffer-end (current-buffer))) + (techinfo-insert-node-header node-list) + (let ((point (buffer-start (current-buffer))) + (placement-index + (if (default-object? placement) 1 placement))) + (let loop ((the-children (cdr (techinfo-line/children-list node-list))) + (the-index 1) + (this-child (car (techinfo-line/children-list node-list)))) + (if (not (string=? this-child "")) + (begin + (insert-string + (string-append + " " (string-pad-left (number->string the-index) 5) " " + (techinfo-line/title (techinfo-parse-line (techinfo-find-line this-child))) + "\n")) + (if (= the-index placement-index) + (set! point (line-start (current-point) -1))) + (if (not (null? the-children)) + (loop (cdr the-children) (1+ the-index) (car the-children)))))) + (set-buffer-read-only! (current-buffer)) + (set-current-point! point))) + +(define (techinfo-display-leaf-node node-list) + (set-variable! techinfo-current-node-list node-list) + (set-buffer-writeable! (current-buffer)) + (set-current-point! (buffer-start (current-buffer))) + (kill-string (buffer-start (current-buffer)) + (buffer-end (current-buffer))) + (techinfo-insert-node-header node-list) + (let ((the-filesys (techinfo-line/filesystem node-list)) + (the-filename (techinfo-line/filename node-list))) + (if (not (member the-filesys (ref-variable techinfo-attached-filesystems))) + (begin + (if (and (string=? the-filesys "afs") (ref-variable techinfo-need-to-attach-afs)) + (run-synchronous-process false false (->pathname "/usr/local/bin") false + "attach" "-n" "-m" "/afs" "-e" "atalanta.mit.edu:/afs") + (run-synchronous-process false false (->pathname "/usr/local/bin") false + "attach" "-n" the-filesys)) + (set-variable! techinfo-attached-filesystems + (cons the-filesys (ref-variable techinfo-attached-filesystems))))) + (if (file-exists? the-filename) + (insert-file (current-point) the-filename)) + (set-current-point! (buffer-start (current-buffer))))) + +(define (techinfo-space-DWIM-internal-node) + (let ((point (current-point))) + (let ((the-match (re-match-forward "[ ]*\\([0-9][0-9]*\\)" + (line-start point 0) (line-end point 0)))) + (if the-match + (let ((num (string->number + (extract-string (re-match-start 1) (re-match-end 1))))) + ((ref-command techinfo-goto-node) num)))))) + +(define (techinfo-space-DWIM-leaf-node) + ((ref-command scroll-up) false)) + +(define (techinfo-delete-DWIM-internal-node) + ((ref-command techinfo-up))) + +(define (techinfo-delete-DWIM-leaf-node) + ((ref-command scroll-down) false)) + +(define (techinfo-initialize) + (if (not (member "ti_data" (ref-variable techinfo-attached-filesystems))) + (begin + (run-synchronous-process false false (->pathname "/usr/local/bin") false + "attach" "-n" "ti_data") + (set-variable! techinfo-attached-filesystems + (cons "ti_data" (ref-variable techinfo-attached-filesystems))))) + (set-variable! techinfo-web-buffer (find-buffer "*techinfo-web*")) + (if (not (ref-variable techinfo-web-buffer)) + (let ((the-buf (create-buffer "*techinfo-web*"))) + (set-variable! techinfo-web-buffer the-buf) + (kill-string (buffer-start the-buf) + (buffer-end the-buf)) + (insert-file (buffer-start the-buf) "/mit/ti_data/admin/pips.web") + (set-buffer-read-only! the-buf) + (bury-buffer the-buf))) + (select-buffer (find-or-create-buffer "*TechInfo*")) + (set-buffer-read-only! (current-buffer)) + (set-current-point! (buffer-start (current-buffer))) + (set-current-major-mode! (ref-mode-object techinfo)) + (set-variable! techinfo-parent-list '("0")) + (techinfo-display-node "0")) + +(define-major-mode techinfo read-only "TechInfo" + "Major mode for viewing information in the TechInfo database. +In an internal node: +Space Move to node listed on line containing point. +DEL Move to parent of current node. +g Move to node specified by number. + +In a leaf node: +Space Scroll forward a page. +DEL Scroll backward a page. + +In all nodes: +. Move to beginning of buffer. +n Move to next sibling of this node. +p Move to previous sibling of this node. +u Move to parent of this node. + +d Move to root node. + +q Exit TechInfo.") + +(define-key 'techinfo #\. 'beginning-of-buffer) +(define-key 'techinfo #\Space 'techinfo-space) +(define-key 'techinfo #\d 'techinfo-top) +(define-key 'techinfo #\g 'techinfo-goto-node) +(define-key 'techinfo #\n 'techinfo-next) +(define-key 'techinfo #\p 'techinfo-prev) +(define-key 'techinfo #\q 'techinfo-exit) +(define-key 'techinfo #\u 'techinfo-up) +(define-key 'techinfo #\l 'techinfo-last) +(define-key 'techinfo #\Del 'techinfo-delete) + +(define-command techinfo + "Enter TechInfo mode." + '() + (lambda () + (techinfo-initialize))) + +(define-command techinfo-space + "In an internal node, move to the subnode whose title is on the +same line as point. In a leaf node, scroll-up." + '() + (lambda () + (if (string=? (techinfo-line/filesystem (ref-variable techinfo-current-node-list)) "") + (techinfo-space-DWIM-internal-node) + (techinfo-space-DWIM-leaf-node)))) + +(define-command techinfo-delete + "In an internal node, move to the parent of the current node. +In a leaf node, scroll-down." + '() + (lambda () + (if (string=? (techinfo-line/filesystem (ref-variable techinfo-current-node-list)) "") + (techinfo-delete-DWIM-internal-node) + (techinfo-delete-DWIM-leaf-node)))) + +(define-command techinfo-up + "Move to the parent of the current node." + '() + (lambda () + (let ((parent (car (ref-variable techinfo-parent-list)))) + (if (not (null? (cdr (ref-variable techinfo-parent-list)))) + (set-variable! techinfo-parent-list + (cdr (ref-variable techinfo-parent-list)))) + (techinfo-display-node parent)))) + +(define-command techinfo-top + "Move to the top node in the TechInfo tree." + '() + (lambda () + (set-variable! techinfo-parent-list '("0")) + (techinfo-display-node "0"))) + +(define-command techinfo-goto-node + "Go to the NTH node listed as a child of the current node. +NTH is an integer between 1 and the number of children of the current node. +When called interactively, NTH may be provided either as a prefix arg, +or the user will be prompted for a value." + "NItem number: " + (lambda (num) + (let ((new-node (list-ref (techinfo-line/children-list + (ref-variable techinfo-current-node-list)) + (-1+ num)))) + (if new-node + (begin + (set-variable! techinfo-parent-list + (cons (techinfo-line/number + (ref-variable techinfo-current-node-list) ) + (ref-variable techinfo-parent-list))) + (techinfo-display-node new-node)))))) + +(define-command techinfo-next + "Move to the next sibling of the current node. (i.e., the node which +is listed immediately after the current node in the current node's parent.) +Do nothing if no such sibling exists." + '() + (lambda () + (let ((siblings (techinfo-line/children-list + (techinfo-parse-line (techinfo-find-line + (car (ref-variable techinfo-parent-list))))))) + (let ((rest (member (techinfo-line/number + (ref-variable techinfo-current-node-list)) siblings))) + (if (and rest (cdr rest)) + (techinfo-display-node (car (cdr rest)))))))) + +(define-command techinfo-prev + "Move to the previous sibling of the current node. (i.e., the node which +is listed immediately before the current node in the current node's parent.) +Do nothing if no such subling exists." + '() + (lambda () + (let ((siblings (techinfo-line/children-list + (techinfo-parse-line (techinfo-find-line + (car (ref-variable techinfo-parent-list))))))) + (let ((rest (member (techinfo-line/number + (ref-variable techinfo-current-node-list)) siblings))) + (if rest + (let ((num (- (length siblings) (length rest)))) + (techinfo-display-node (list-ref siblings (-1+ num))))))))) + +(define-command techinfo-exit + "Exit TechInfo mode." + '() + (lambda () + (bury-buffer (current-buffer)) + (select-buffer (other-buffer (current-buffer))))) + +(define-command techinfo-last + "Go to the node visited immediately before this node. +WARNING: Calling this function causes the parent information to +no longer be valid." + '() + (lambda () + (if (and (not (null? (ref-variable techinfo-history-list))) + (not (null? (cdr (ref-variable techinfo-history-list))))) + (let ((new-node (car (cdr (ref-variable techinfo-history-list))))) + (set-variable! techinfo-history-list (cdr (ref-variable techinfo-history-list))) + (techinfo-display-node new-node) + (set-variable! techinfo-history-list (cdr (ref-variable techinfo-history-list))))))) + +;; Edwin Variables: +;; scheme-environment: '(edwin) +;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin))) +;; End: