79 lines
2.5 KiB
Plaintext
79 lines
2.5 KiB
Plaintext
;;;;
|
|
;;;; w w w - f i l e . s t k -- WWW for STk (FILE: protocol)
|
|
;;;;
|
|
;;;; Copyright © 1996-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, and/or distribute this software and its
|
|
;;;; documentation for any purpose and without fee is hereby granted, provided
|
|
;;;; that both the above copyright notice and this permission notice appear in
|
|
;;;; all copies and derived works. Fees for distribution or use of this
|
|
;;;; software or derived works may only be charged with express written
|
|
;;;; permission of the copyright holder.
|
|
;;;; This software is provided ``as is'' without express or implied warranty.
|
|
;;;;
|
|
;;;; This version uses some of the enhancements done by Harvey J. Stein:
|
|
;;;; Copyright (c) 1995 Harvey J. Stein (hjstein@math.huji.ac.il)
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 4-Oct-1996 22:14
|
|
;;;; Last file update: 28-Feb-1998 11:06
|
|
|
|
|
|
;; Add the "FILE:" protocol
|
|
|
|
(with-module WWW
|
|
|
|
(define (generate-html-dir dir out)
|
|
;; This function generate a listing of the files in "dir" (HTML format)
|
|
(let* ((cwd (getcwd))
|
|
(all (lambda (dir) (chdir dir) (glob ".*" "*")))
|
|
(files (sort (all dir) string<?))
|
|
(link (lambda (img ref txt)
|
|
(format out "<A HREF=file:~A>" ref)
|
|
(format out "<IMG ALIGN=middle SRC=@~A@.xpm>~A</A>\n"
|
|
img txt))))
|
|
|
|
(chdir cwd)
|
|
|
|
;; Print Header
|
|
(format out "<pre>\n\n</pre><H2> Directory listing of ~A</H2><HR><PRE>\n" dir)
|
|
(link "parentdir"
|
|
(canonical-path (string-append dir "/.."))
|
|
"Up to higher level directory")
|
|
|
|
;; Print each file
|
|
(for-each (lambda (name)
|
|
(unless (or (string=? name ".") (string=? name ".."))
|
|
(link (if (file-is-directory? (string-append dir "/" name) )
|
|
"dir"
|
|
"file")
|
|
(canonical-path (string-append dir "/" name))
|
|
name)))
|
|
files)))
|
|
|
|
|
|
(define (get-file: url)
|
|
;; This function must return a port and the function to close it
|
|
(let ((file (url:filename url)))
|
|
(if (or (not file) (string=? file ""))
|
|
(set! file "/"))
|
|
(if (file-is-directory? file)
|
|
;; File is a directory. Generate a HTML directory
|
|
(let ((p (open-output-string)))
|
|
(generate-html-dir file p)
|
|
(let ((f (open-input-string (get-output-string p))))
|
|
(cons f
|
|
(lambda () (close-port f)))))
|
|
;; Normal file
|
|
(let((f (open-file file "r")))
|
|
(cons f
|
|
(if f
|
|
(lambda () (close-input-port f))
|
|
(lambda () #f)))))))
|
|
|
|
;; Add the protocol
|
|
(WWW:add-protocol 'file get-file:)
|
|
)
|
|
|
|
(provide "www-file")
|