stk/Lib/www-img.stk

109 lines
3.4 KiB
Plaintext
Raw Normal View History

1998-04-10 06:59:06 -04:00
;;;;
;;;; w w w - i m g . s t k -- WWW for STk (images file reader)
;;;;
1999-02-02 06:13:40 -05:00
;;;; Copyright <20> 1996-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1998-04-10 06:59:06 -04:00
;;;;
1999-09-05 07:16:41 -04:00
;;;; 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.
1998-04-10 06:59:06 -04:00
;;;;
;;;; 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
1999-09-05 07:16:41 -04:00
;;;; Last file update: 3-Sep-1999 19:57 (eg)
1998-04-10 06:59:06 -04:00
;;;;
(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
1999-02-02 06:13:40 -05:00
;; file:@parentdir.gif
;; file:@dir.gif
;; file:@file.gif
1998-04-10 06:59:06 -04:00
;; These names are generated by the directory viewer.
1999-02-02 06:13:40 -05:00
(make-image (string-append "@" name "@.gif")
:file (string-append *stk-library* "/Images/" name ".gif")))
1998-04-10 06:59:06 -04:00
;=============================================================================
;
; 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")
1999-02-02 06:13:40 -05:00
;(need "jpeg")
1998-04-10 06:59:06 -04:00
(when (provided? "pixmap")
(load-default-image "parentdir")
(load-default-image "file")
(load-default-image "dir"))
(provide "www-img")
1999-09-05 07:16:41 -04:00