stk/Lib/www.stk

;;;;
;;;; w w w  . s t k			--  WWW for STk
;;;;
;;;; 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 16:14
;;;; Last file update: 16-Sep-1999 17:21 (eg)

;; 
;; This module needs a library of protocol getters & file viewers to be
;; useful. It is merely an interface for structuring access to said
;; libraries. Here the entry points defined here:
;; 
;; (www:insert-url txt url . parent)
;;    Reads in URL and insert it in text widget TXT.  URL is parsed
;;    relative to PARENT (when provided).  Basically, this routine
;;    determines the protocol to use to fetch the URL, and the file type of
;;    the url.  Based on the protocol it selects a protocol getter to open a
;;    port through which the document can be read.  Based on the file type
;;    it selects a document viewing function with which to view the
;;    document.
;; 
;; (www:view-url txt url . parent)
;;    Reads in URL and displays it in text widget TXT. The main difference
;;    with www:insert-url is that this function clears the txt widget 
;;    before inserting the URL content.
;; 
;; (www:add-protocol proto port-maker)
;;    adds protocol getter for specified protocol. Protocol should be
;;    something one would see at the beginning of a url (such as http).
;;    It should be a symbol.  port-maker is a closures taking 1 argument
;;    - a parsed url.  It should return a pair formed of a port through
;;    which the specified URL can be read and a thunk to close this port.
;; 
;; (www:add-viewer regexp viewer) 
;;    adds a viewer for files which satisfy the given regexp.  The viewer
;;    should take 3 arguments, a text widget, a port and a parsed url.
;;    The viewer should read the document from the port, and display it
;;    in the text widget.  However, the viewer is free to take some
;;    action other than viewing the document (such as poping up a save-to
;;    dialog box, or an auxiliary handler for the document).
;;
;; This module also exports the following hooks
;;       (www:hook-title title)      called when title change
;;       (www:hook-location title)   called when location URL change
;;       (www:hook-start-loading)    called when a new page is loaded
;;       (www:hook-stop-loading)     called when a new page has been loaded
;;       (www:hook-formatting)       called often when formatting (pulse)
;;	 (www:hook-mailto . to)      tested when a mailto: is encountered
;;
;; These hooks are set by default to #f (no action)
;;
;; The exported variable 
;;          www:stop-loading 
;; is read periodically during  loading. Setting it to #t interrupts loading
;;

(require "hash")
(require "www-url")
;;
;; Module stuff
;;
(define-module WWW
  (import Scheme Tk URL)

  (export WWW:view-url WWW:insert-url WWW:add-protocol WWW:add-viewer
	  WWW:stop-loading
	  www:hook-title www:hook-location www:hook-start-loading
	  www:hook-stop-loading www:hook-formatting www:hook-mailto))

(select-module WWW)

;=============================================================================


;; Exported variables and Hooks
(define WWW:stop-loading	  #f) ;; Set it to #t to interrupt loading

(define (www:hook-title title)    #f) ;; called when title change
(define (www:hook-location title) #f) ;; called when location URL change
(define (www:hook-start-loading)  #f) ;; called when a new page is loaded
(define (www:hook-stop-loading)   #f) ;; called when a new page has been loaded
(define (www:hook-formatting)     #f) ;; called often when formatting (pulse)

(define www:hook-mailto		  #f) ;; tested when a mailto: is encountered

;=============================================================================
;
; 			P r o t o c o l s   m a n a g e m e n t
;
;=============================================================================
(define *protocols* (make-hash-table)) 		; Table of recognized protocols

(define (www:add-protocol proto port-maker)
  (hash-table-put! *protocols* proto port-maker))

(define (get-protocol->port proto)
  (hash-table-get *protocols* proto #f))

;=============================================================================
;
; 			V i e w e r s   m a n a g e m e n t
;
;=============================================================================  
(define *viewers* (make-hash-table)) 		; Table of document viewers

(define (www:add-viewer key viewer)
  (hash-table-put! *viewers* key  viewer))

(define (get-viewer filename)
  ;; Try to find a viewer for a given file. We work only on the filename 
  ;; suffix, here. That's clearly not sufficient.
  (let loop ((l (hash-table->list *viewers*)))
    (if (null? l) 
	#f
	(let ((item (car l)))
	  (if (and (regexp? (car item)) ((car item) filename))
	      ;; regexp matches
	      (cdr item)
	      ;; continue search
	      (loop (cdr l)))))))

;=============================================================================
;
; 				v i e w - u r l
;
;=============================================================================

(define *loading-document* #f)

(define (WWW:view-url txt url . parent)
  (when *loading-document*
    ;; We are loading a document. Stop this loading
    (set! www:stop-loading #t)
    (update))
  ;;
  ;; Start the loading of the new document
  ;;
  (set! *loading-document* #t)
  ; Reset text
  (tk-set! txt :state "normal" :wrap "word" :tabs 8)
  (txt 'delete 1.0 "end")
  ; Insert url
  (set! www:stop-loading #f)
  (www:hook-start-loading)
  
  (let ((res (apply www:insert-url txt url parent)))
    (www:hook-location (apply url:pretty-url url parent))
    (tk-set! txt :state "disabled")     ; make text read-only
    (www:hook-stop-loading)
    (set! *loading-document* #f)
    res))

;=============================================================================
;
;				 i n s e r t - u r l 
;
;=============================================================================

(define (port-on-url url . parent)
  (letrec ((url->port (lambda (url)
			(let* ((service   (url:service url))
			       (converter (get-protocol->port service)))
			  (and converter (converter url)))))
	   (parsed-url (if (and (list? url) (null? parent))
			   url				 ;already parsed
			   (apply url:parse-url url parent))))
    
    (let ((p (url->port parsed-url))) ; Return <port, full-url, close-port>
      (if p
	  (vector (car p) parsed-url (cdr p))
	  (vector #f parsed-url #f)))))


(define (WWW:insert-url txt url . parent)
  (let* ((P          (apply port-on-url url parent))
	 (port       (vector-ref P 0))
	 (parsed-url (vector-ref P 1))
	 (close      (vector-ref P 2))
	 (viewer     (get-viewer (url:filename parsed-url))))
    (unless viewer
      ;; No viewer, try to guess one depending of protocol used
      (case (url:service parsed-url)
	((HTTP) (set! viewer (hash-table-get *viewers* 'html #f)))
	((FILE) (set! viewer (hash-table-get *viewers* 
					     (if (input-string-port? port)
						 ;; this is generated HTML 
						 ;; (e.g. a dir listing)
						 'html
						 'txt)
					     #f))))
      (unless viewer ; again
	(error "Don't know how to handle the URL ~S" (apply url:pretty-url 
							  url parent))))
    
    ;; Viewer is known now. Here we go
    (let ((res (viewer txt port parsed-url)))
      (close)
      res)))

;==============================================================================

;; File formats
(require "www-html")
(require "www-txt")
(require "www-img")
(require "www-snd")

;;----  Protocols
(require "www-http")
(require "www-file")

(provide "www")