stk/Lib/www-file.stk

;;;;
;;;; w w w - f i l e . s t k		--  WWW for STk (FILE: protocol)
;;;;
;;;; Copyright <20> 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; 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.
;;;;
;;;; 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:  3-Sep-1999 19:57 (eg)


;; 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@.gif>~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")