src/renderer/images.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: RENDERER; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: General image routines
   4 ;;;   Created: 1998-11-11
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1998 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 ;; Changes
  30 ;;
  31 ;;  When        Who     What
  32 ;; ----------------------------------------------------------------------------
  33 ;;  1999-08-18  GB      - Spend a printer for AIMAGE
  34 ;;                      - fixed URL->AIMAGE-REAL,
  35 ;;                         - it now returns the condition
  36 ;;                         - obeys to `deliver-broken-image-p'
  37 ;;
  38
  39 (in-package :RENDERER)
  40
  41 ;;; ---------------------------------------------------------------------------
  42
  43 (defvar *recursive-broken-image-p* nil)
  44
  45 (defun broken-aimage (document)
  46   (if *recursive-broken-image-p*
  47       (error "Recursive broken image")
  48     (let ((*recursive-broken-image-p* t))
  49       (url->aimage document "file://closure/resources/icons/broken.png" t))))
  50
  51 (defun url->aimage-real (document url &optional (deliver-broken-image-p t))
  52   "Attempts to make an AIMAGE from an URL; In case of error return NIL
  53    and the condition if known. If `deliver-broken-image-p' is true, return
  54    broken.png in case of error instead."
  55   (unless (url:url-p url)
  56     (setq url (url:parse-url url)))
  57   (multiple-value-bind (aimage condition)
  58       (ignore-errors
  59        (netlib:with-open-document ((input mime-type) url
  60                                                      nil ;reload-p
  61                                                      t ;binary-p
  62                                                      t ;cache-p
  63                                                      nil) ;any-p
  64          (cond ((makeup-image mime-type input))
  65                (t
  66                 (warn "Image mime type '~A' not understood. -- trying with '~A'."
  67                       (netlib::mime-type-name mime-type)
  68                       ;;XXX
  69                       (netlib::mime-type-name
  70                        (setq mime-type (netlib::find-mime-type-from-extension
  71                                         (url:url-extension url)))))
  72                 (let ((mime-type-2
  73                        (netlib:find-mime-type
  74                         (netlib::mime-type-name
  75                          (setq mime-type
  76                            (netlib::find-mime-type-from-extension
  77                             (url:url-extension url)))))))
  78                   (cond ((makeup-image mime-type-2 input))
  79                         (t
  80                          (warn "Auch das hat nix genuetzt.")
  81                          (cond (deliver-broken-image-p
  82                                 (format *debug-io* "~%;; ~A -> using broken image." url)
  83                                 (broken-aimage document))
  84                                (t
  85                                 (error "Image mime type `~A' or `~A' not understood."
  86                                        (netlib::mime-type-name mime-type)
  87                                        (netlib::mime-type-name mime-type-2) ))))))))))
  88     (cond ((null aimage)
  89            (cond (deliver-broken-image-p
  90                   (progn
  91                     (format *debug-io* "~%;; ~A -> using broken image. [zweite variante]" url)
  92                     (broken-aimage document) ))
  93                  (t
  94                   (format *debug-io* "~&;; Was unable to read ~S as image, because of:~%;; | ~A."
  95                           url condition)
  96                   (values nil condition))))
  97           (t
  98            (values aimage nil)))))
  99
 100 (defun url->aimage (document url &optional (deliver-broken-image-p t))
 101   (let ((res (clue-gui2::aimage-from-url document url)))
 102     (cond ((eq res :error)
 103            (if deliver-broken-image-p
 104                (broken-aimage document)
 105              nil))
 106           (t
 107            res))))
 108
 109 (defun makeup-image (mime-type input)
 110   (cond
 111    ((eq mime-type (netlib:find-mime-type "image/png"))
 112     (png:png-stream->aimage input))
 113    ((eq mime-type (netlib:find-mime-type "image/gif"))
 114     (imagelib:gif-stream->aimage input))
 115    ((eq mime-type (netlib:find-mime-type "image/jpeg"))
 116     (imagelib:jpeg-stream->aimage input))
 117    ;; The rest simply goes to the appropriate ->ppm filters.
 118    ((eq mime-type (netlib:find-mime-type "image/x-xbitmap"))
 119     (imagelib:any->aimage-by-filter "xbmtopbm" input))
 120    ((eq mime-type (netlib:find-mime-type "image/x-xpixmap"))
 121     (imagelib:any->aimage-by-filter "xpmtoppm" input))
 122    ((eq mime-type (netlib:find-mime-type "image/tiff"))
 123     (imagelib:any->aimage-by-filter "tifftopnm" input))))
 124