107 lines
3.4 KiB
Plaintext
107 lines
3.4 KiB
Plaintext
;;;;
|
|
;;;; w w w - i m g . s t k -- WWW for STk (images file reader)
|
|
;;;;
|
|
;;;; Copyright © 1996-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, and/or distribute this software and its
|
|
;;;; documentation for any purpose and without fee is hereby granted, provided
|
|
;;;; that both the above copyright notice and this permission notice appear in
|
|
;;;; all copies and derived works. Fees for distribution or use of this
|
|
;;;; software or derived works may only be charged with express written
|
|
;;;; permission of the copyright holder.
|
|
;;;; 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: 11-Apr-1998 11:50
|
|
;;;;
|
|
|
|
(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.xpm
|
|
;; file:@dir.xpm
|
|
;; file:@file.xpm
|
|
;; These names are generated by the directory viewer.
|
|
(make-image (string-append "@" name "@.xpm")
|
|
:file (string-append *stk-library* "/Images/" name ".xpm")))
|
|
|
|
;=============================================================================
|
|
;
|
|
; 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")
|