109 lines
3.4 KiB
Plaintext
109 lines
3.4 KiB
Plaintext
;;;;
|
|
;;;; w w w - i m g . s t k -- WWW for STk (images file reader)
|
|
;;;;
|
|
;;;; Copyright © 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")
|
|
|