109 lines
3.4 KiB

;;;; w w w - i m g . s t k -- WWW for STk (images file reader)
;;;; Copyright © 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; 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 (
;;;; Author: Erick Gallesio []
;;;; 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)
(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))))
(define (insert-image txt image)
(txt 'image 'create "end" :image image :pady 2 :padx 2)
; 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$")
(www:add-viewer 'img
;;;; Initialize package
(need "pixmap")
;(need "jpeg")
(when (provided? "pixmap")
(load-default-image "parentdir")
(load-default-image "file")
(load-default-image "dir"))
(provide "www-img")