stk/Lib/www-file.stk

80 lines
2.5 KiB
Plaintext
Raw Normal View History

1998-04-10 06:59:06 -04:00
;;;;
;;;; w w w - f i l e . s t k -- WWW for STk (FILE: protocol)
;;;;
1999-02-02 06:13:40 -05:00
;;;; Copyright <20> 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1998-04-10 06:59:06 -04:00
;;;;
1999-09-05 07:16:41 -04:00
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
1998-04-10 06:59:06 -04:00
;;;;
;;;; 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
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 19:57 (eg)
1998-04-10 06:59:06 -04:00
;; 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)
1999-02-02 06:13:40 -05:00
(format out "<IMG ALIGN=middle SRC=@~A@.gif>~A</A>\n"
1998-04-10 06:59:06 -04:00
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")