stk/Lib/www-img.stk

;;;;
;;;; w w w - i m g . s t k	--  WWW for STk (images file reader)
;;;;
;;;; 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:  6-Oct-1996 17:12
;;;; Last file update:  3-Sep-1999 19:57 (eg)
;;;;

(require "image")
(select-module WWW)

;=============================================================================
;
; 			U t i l i t i e s
;
;=============================================================================
(define (copy-port-image in out)
  (do ((c (read-char in) (read-char in)) (count 0 (+ count 1)))
      ((or www:stop-loading (eof-object? c)))
    (write-char c out)
    (when (= count 100)  ; animate screen
      (set! count 0)
      (www:hook-formatting))))


(define (need pkg)
  (unless (provided? pkg) (try-load pkg)))


(define (load-default-image name)
  ;; Default images must have the following name
  ;;   file:@parentdir.gif
  ;;   file:@dir.gif
  ;;   file:@file.gif
  ;; These names are generated by the directory viewer.
  (make-image (string-append "@" name "@.gif")
	      :file (string-append *stk-library* "/Images/" name ".gif")))

;=============================================================================
;
;		 I m a g e s   m a n a g e m e n t
;
;=============================================================================

(define (make-remote-image key url port)
  (let ((image (find-image key)))
    (unless image
      ; We don't have loaded this image yet
      (let* ((tmpname (temporary-file-name))
	     (file    (open-file tmpname "w")))
	(when file
	  (copy-port-image port file)
	  (close-output-port file)
	  (set! image (make-image key :file tmpname))
	  (remove-file tmpname))))
    image))

(define (insert-image txt image)
  (txt 'image 'create "end" :image image :pady 2 :padx 2)
  image)

;=============================================================================
;
; 			 I m a g e   v i e w e r 
;
;=============================================================================
(define (view-image txt fd url)
  (let* ((str-url (if (string? url) url (URL:unparse-url url)))
	 (image   (if (eq? (URL:service url) 'file)
		      ;; Image is in a file
		      (make-image (URL:filename url))
		      ;; Image is distant
		      (make-remote-image str-url url fd))))
    (and image (insert-image txt image))))

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

;;;; Add the txt viewer
(www:add-viewer (string->regexp "\\.gif$|\\.ppm$|\\.jpg$|\\.pbm$|\\.x[bp]m$")
		view-image)
(www:add-viewer 'img 
		view-image)

;;;; Initialize package
(need "pixmap")
;(need "jpeg")

(when (provided? "pixmap")
  (load-default-image "parentdir")
  (load-default-image "file")
  (load-default-image "dir"))

(provide "www-img")