Parameterize RMAN-HANDLER over locations of the various binaries.
This commit is contained in:
parent
7f5219220b
commit
978f28680e
scheme/httpd
|
@ -2,24 +2,18 @@
|
||||||
|
|
||||||
;;; This file is part of the Scheme Untergrund Networking package.
|
;;; This file is part of the Scheme Untergrund Networking package.
|
||||||
|
|
||||||
;;; Copyright (c) 1996 by Mike Sperber.
|
;;; Copyright (c) 1996-2003 by Mike Sperber.
|
||||||
;;; For copyright information, see the file COPYING which comes with
|
;;; For copyright information, see the file COPYING which comes with
|
||||||
;;; the distribution.
|
;;; the distribution.
|
||||||
|
|
||||||
;;; This uses RosettaMan and is currently based on version 2.5a6
|
;;; This uses RosettaMan
|
||||||
;;; (RosettaMan is based at
|
;;; (based at ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
|
||||||
;;; ftp.cs.berkeley.edu:/ucb/people/phelps/tcltk/rman.tar.Z)
|
|
||||||
|
|
||||||
;(define rman/rman '("/afs/wsi/rs_aix41/bin/rman" -fHTML))
|
(define (rman-handler man-binary
|
||||||
(define rman/man '(man))
|
nroff-binary
|
||||||
(define rman/nroff '(nroff -man))
|
rman-binary
|
||||||
;(define rman/gzcat '("/afs/wsi/rs_aix41/bin/zcat"))
|
gzcat-binary
|
||||||
;(define rman/zcat '("/afs/wsi/rs_aix41/bin/zcat"))
|
finder referencer address . maybe-man)
|
||||||
(define rman/rman '("/usr/bin/rman" -fHTML))
|
|
||||||
(define rman/gzcat '("/usr/bin/zcat"))
|
|
||||||
(define rman/zcat '("/usr/bin/zcat"))
|
|
||||||
|
|
||||||
(define (rman-handler finder referencer address . maybe-man)
|
|
||||||
(let ((parse-man-url
|
(let ((parse-man-url
|
||||||
(cond
|
(cond
|
||||||
((procedure? finder) finder)
|
((procedure? finder) finder)
|
||||||
|
@ -64,7 +58,9 @@
|
||||||
(lambda (out options)
|
(lambda (out options)
|
||||||
(receive (man-path entry and-then)
|
(receive (man-path entry and-then)
|
||||||
(parse-man-url (request-url req))
|
(parse-man-url (request-url req))
|
||||||
(emit-man-page entry man man-path and-then reference-template out))
|
(emit-man-page man-binary nroff-binary rman-binary
|
||||||
|
gzcat-binary
|
||||||
|
entry man man-path and-then reference-template out))
|
||||||
|
|
||||||
(with-tag out address ()
|
(with-tag out address ()
|
||||||
(display address out)))))))
|
(display address out)))))))
|
||||||
|
@ -84,19 +80,24 @@
|
||||||
(copy-inport->outport (current-input-port)
|
(copy-inport->outport (current-input-port)
|
||||||
out)))))
|
out)))))
|
||||||
|
|
||||||
(define (emit-man-page entry man man-path and-then reference-template out)
|
(define (emit-man-page man-binary nroff-binary rman-binary
|
||||||
|
gzcat-binary
|
||||||
|
entry man man-path and-then reference-template out)
|
||||||
(receive (key section) (parse-man-entry entry)
|
(receive (key section) (parse-man-entry entry)
|
||||||
(let ((status
|
(let ((status
|
||||||
(cond
|
(cond
|
||||||
((procedure? and-then)
|
((procedure? and-then)
|
||||||
(run (| (begin (man section key man-path))
|
(run (| (begin (man man-binary nroff-binary gzcat-binary
|
||||||
|
section key man-path))
|
||||||
(begin (and-then key section)))
|
(begin (and-then key section)))
|
||||||
(= 1 ,out)
|
(= 1 ,out)
|
||||||
(= 2 ,out)))
|
(= 2 ,out)))
|
||||||
(else
|
(else
|
||||||
(run (| (begin (man section key man-path))
|
(run (| (begin (man man-binary nroff-binary gzcat-binary
|
||||||
(,@rman/rman ,@and-then
|
section key man-path))
|
||||||
-r ,(reference-template entry section)))
|
(,rman-binary "-fHTML"
|
||||||
|
,@and-then
|
||||||
|
"-r" ,(reference-template entry section)))
|
||||||
(= 1 ,out)
|
(= 1 ,out)
|
||||||
(= 2 ,out))))))
|
(= 2 ,out))))))
|
||||||
|
|
||||||
|
@ -113,15 +114,19 @@
|
||||||
(match:substring match 2))))
|
(match:substring match 2))))
|
||||||
(else (values s #f))))))
|
(else (values s #f))))))
|
||||||
|
|
||||||
(define (man section key man-path)
|
(define (man man-binary nroff-binary gzcat-binary section key man-path)
|
||||||
(cond
|
(cond
|
||||||
((procedure? man-path) (man-path))
|
((procedure? man-path) (man-path))
|
||||||
((find-man-file key section "cat" man-path) => cat-n-decode)
|
((find-man-file key section "cat" man-path) =>
|
||||||
((find-man-file key section "man" man-path) => nroff-n-decode)
|
(lambda (file)
|
||||||
|
(cat-n-decode gzcat-binary file)))
|
||||||
|
((find-man-file key section "man" man-path) =>
|
||||||
|
(lambda (file)
|
||||||
|
(nroff-n-decode nroff-binary file)))
|
||||||
(else
|
(else
|
||||||
(if (not (zero?
|
(if (not (zero?
|
||||||
(with-env (("MANPATH" . ,(string-join man-path ":")))
|
(with-env (("MANPATH" . ,(string-join man-path ":")))
|
||||||
(run (,@rman/man ,@(if section `(,section) '()) ,key)
|
(run (,man-binary "-man" ,@(if section `(,section) '()) ,key)
|
||||||
stdports))))
|
stdports))))
|
||||||
(http-error http-status/not-found #f "man page not found")))))
|
(http-error http-status/not-found #f "man page not found")))))
|
||||||
|
|
||||||
|
@ -166,20 +171,20 @@
|
||||||
(split-file-name
|
(split-file-name
|
||||||
(file-name-directory file)))))))
|
(file-name-directory file)))))))
|
||||||
|
|
||||||
(define (cat-n-decode file)
|
(define (cat-n-decode gzcat-binary file)
|
||||||
(let ((ext (file-name-extension file)))
|
(let ((ext (file-name-extension file)))
|
||||||
(cond
|
(cond
|
||||||
((string=? ".gz" ext) (run (,@rman/gzcat ,file) stdports))
|
((string=? ".gz" ext) (run (,gzcat-binary ,file) stdports))
|
||||||
((string=? ".Z" ext) (run (,@rman/zcat ,file) stdports))
|
((string=? ".Z" ext) (run (,gzcat-binary ,file) stdports))
|
||||||
(else (call-with-input-file
|
(else (call-with-input-file
|
||||||
file
|
file
|
||||||
(lambda (port)
|
(lambda (port)
|
||||||
(copy-inport->outport port (current-output-port))))))))
|
(copy-inport->outport port (current-output-port))))))))
|
||||||
|
|
||||||
(define (nroff-n-decode file)
|
(define (nroff-n-decode nroff-binary gzcat-binary file)
|
||||||
(if (not (zero? (run (| (begin (cat-n-decode file))
|
(if (not (zero? (run (| (begin (cat-n-decode gzcat-binary file))
|
||||||
(begin
|
(begin
|
||||||
(with-cwd (file->man-directory file)
|
(with-cwd (file->man-directory file)
|
||||||
(exec-epf (,@rman/nroff)))))
|
(exec-epf (,nroff-binary "-man")))))
|
||||||
stdports)))
|
stdports)))
|
||||||
(http-error http-status/not-found #f "man page not found")))
|
(http-error http-status/not-found #f "man page not found")))
|
||||||
|
|
Loading…
Reference in New Issue