cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/images.el

   1 ;;; images.el --- Automatic image converters
   2 ;; Author: $Author: legoscia $
   3 ;; Created: $Date: 2007/11/15 12:22:34 $
   4 ;; Version: $Revision: 1.6 $
   5 ;; Keywords: images
   6
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;; Copyright (c) 1996 - 1999, 2007 Free Software Foundation Inc.
   9 ;;; Copyright (c) 1995 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
  10 ;;;
  11 ;;; This file is part of GNU Emacs.
  12 ;;;
  13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 2, or (at your option)
  16 ;;; any later version.
  17 ;;;
  18 ;;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;;; Boston, MA 02111-1307, USA.
  27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28
  29 (defvar image-temp-stack nil "Do no touch - internal storage.")
  30 (defvar image-converters nil "Storage for the image converters.")
  31 (defvar image-native-formats
  32   (cond
  33    ((featurep 'xemacs)
  34     (delq nil (cons (if (featurep 'x) 'xbm)
  35                     (mapcar (function (lambda (x) (if (featurep x) x)))
  36                             '(xpm gif jpeg tiff png imagick)))))
  37    ((boundp 'image-types)
  38     image-types)
  39    (t nil))
  40   "A list of image formats that this version of emacs supports natively.")
  41
  42 (defun image-register-converter (from to converter)
  43   "Register the image converter for FROM to TO.  CONVERTER is the actual
  44 command used to convert the image.  If this is a string, it will be executed
  45 in a subprocess.  If a symbol, it is assumed to be a function.  It will be
  46 called with two arguments, the start and end of the data to be converted.
  47 The function should replace that data with the new image data.  The return
  48 value is not significant."
  49   (let* ((node (assq from image-converters))
  50          (replace (assq to (cdr-safe node))))
  51     (cond
  52      (replace                           ; Replace existing converter
  53       (setcdr replace converter)
  54       (display-warning 'image (format "Replacing image converter %s->%s"
  55                                       from to)))
  56      (node                              ; Add to existing node
  57       (setcdr node (cons (cons to converter) (cdr node))))
  58      (t                                 ; New toplevel converter
  59       (setq image-converters (cons (cons from (list (cons to converter)))
  60                                    image-converters))))))
  61
  62 (defun image-unregister-converter (from to)
  63   "Unregister the image converter for FROM to TO"
  64   (let* ((node (assq from image-converters))
  65          (tos (cdr-safe node))
  66          (new nil))
  67     (while tos
  68       (if (eq to (car (car tos)))
  69           nil
  70         (setq new (cons (car tos) new)))
  71       (setq tos (cdr tos)))
  72     (setcdr node new)))
  73
  74 (defun image-converter-registered-p (from to)
  75   (cdr-safe (assq to (cdr-safe (assq from image-converters)))))
  76
  77 (defun image-converter-chain (from to)
  78   "Return the shortest converter chain for image format FROM to TO"
  79   (setq image-temp-stack (cons from image-temp-stack))
  80   (let ((converters (cdr-safe (assq from image-converters)))
  81         (thisone nil)
  82         (possibles nil)
  83         (done nil))
  84     (while (and (not done) converters)
  85       (setq thisone  (car converters))
  86       (cond
  87        ((eq (car thisone) to)
  88         (setq done t))
  89        ((memq (car thisone) image-temp-stack)
  90         nil)
  91        (t
  92         (setq possibles (cons (image-converter-chain (car thisone) to)
  93                               possibles))))
  94       (setq converters (cdr converters)))
  95     (setq image-temp-stack (cdr image-temp-stack)
  96           possibles (sort (delq nil possibles)
  97                           (function
  98                            (lambda (x y)
  99                              (< (length (delete 'ignore x))
 100                                 (length (delete 'ignore y)))))))
 101     (if (not done)
 102         (setq done (car possibles)))
 103     (cond
 104      ((eq done t) (list (cdr thisone)))
 105      (done (setq done (cons (cdr thisone) done)))
 106      (t nil))))
 107
 108 (defun image-normalize (format data)
 109   "Return an image specification for XEmacs 19.13 and later.  FORMAT specifies
 110 the image format, DATA is the image data as a string.  Any conversions to get
 111 to a suitable internal image format will be carried out."
 112   (setq image-temp-stack nil)
 113   (if (stringp format) (setq format (intern format)))
 114   (if (not (memq format image-native-formats))
 115       (let* ((winner (car-safe
 116                       (sort (mapcar
 117                              (function
 118                               (lambda (x)
 119                                 (cons x
 120                                       (delete 'ignore
 121                                               (image-converter-chain format
 122                                                                      x)))))
 123                                     image-native-formats)
 124                             (function
 125                              (lambda (x y)
 126                                (cond
 127                                 ((null (cdr x)) nil)
 128                                 ((= (length (cdr x))
 129                                     (length (cdr y)))
 130                                  (< (length (memq (car x)
 131                                                   image-native-formats))
 132                                     (length (memq (car y)
 133                                                   image-native-formats))))
 134                                 (t
 135                                  (< (length (cdr x))
 136                                     (length (cdr y))))))))))
 137              (type (car-safe winner))
 138              (chain (cdr-safe winner))
 139              )
 140         (if chain
 141             (save-excursion
 142               (set-buffer (generate-new-buffer " *image-conversion*"))
 143               (erase-buffer)
 144               (insert data)
 145               (while chain
 146                 (cond
 147                  ((stringp (car chain))
 148                   (let ((coding-system-for-read 'binary))
 149                     (call-process-region
 150                      (point-min) (point-max)
 151                      shell-file-name t
 152                      (list (current-buffer) nil)
 153                      shell-command-switch
 154                      (car chain))))
 155                  ((and (symbolp (car chain)) (fboundp (car chain)))
 156                   (funcall (car chain) (point-min) (point-max))))
 157                 (setq chain (cdr chain)))
 158               (setq data (buffer-string))
 159               (kill-buffer (current-buffer)))
 160           (setq type format))
 161         (vector type ':data data))
 162     (vector format ':data data)))
 163
 164 (defun image-register-netpbm-utilities ()
 165   "Register all the netpbm utility packages converters."
 166   (interactive)
 167   (if (image-converter-registered-p 'pgm 'pbm)
 168       nil
 169     (image-register-converter 'pgm 'pbm "pgmtopbm")
 170     (image-register-converter 'ppm 'pgm "ppmtopgm")
 171     (image-register-converter 'pnm 'xpm "ppmtoxpm")
 172     (image-register-converter 'ppm 'xpm "ppmtoxpm")
 173     (image-register-converter 'xpm 'ppm "xpmtoppm")
 174     (image-register-converter 'gif 'ppm "giftopnm")
 175     (image-register-converter 'pnm 'gif "(ppmquant 256 | ppmtogif)")
 176     (image-register-converter 'ppm 'gif "(ppmquant 256 | ppmtogif)")
 177     (image-register-converter 'bmp 'ppm "bmptoppm")
 178     (image-register-converter 'ppm 'bmp "ppmtobmp")
 179     (image-register-converter 'ppm 'ps "pnmtops")
 180     (image-register-converter 'pnm 'ps "pnmtops")
 181     (image-register-converter 'ps 'pnm "pstopnm")
 182     (image-register-converter 'g3  'pbm "g3topbm")
 183     (image-register-converter 'macpt 'pbm "macptopbm")
 184     (image-register-converter 'pbm 'macpt "pbmtomacp")
 185     (image-register-converter 'pcx 'ppm "pcxtoppm")
 186     (image-register-converter 'ppm 'pcx "ppmtopcx")
 187     (image-register-converter 'pict 'ppm "picttoppm")
 188     (image-register-converter 'ppm 'pict "ppmtopict")
 189     (image-register-converter 'pnm 'sgi "pnmtosgi")
 190     (image-register-converter 'tga 'ppm "tgatoppm")
 191     (image-register-converter 'ppm 'tga "ppmtotga")
 192     (image-register-converter 'sgi 'pnm "sgitopnm")
 193     (image-register-converter 'tiff 'pnm "tifftopnm")
 194     (image-register-converter 'pnm 'tiff "pnmtotiff")
 195     (image-register-converter 'xbm 'pbm "xbmtopbm")
 196     (image-register-converter 'pbm 'xbm "pbmtoxbm")
 197     (image-register-converter 'png 'pnm "pngtopnm")
 198     (image-register-converter 'pnm 'png "pnmtopng")
 199     (image-register-converter 'pnm 'jbg "pbmtojbg")
 200     (image-register-converter 'jbg 'pnm "jbgtopbm")
 201     (image-register-converter 'jpeg 'ppm "djpeg")))
 202
 203 (provide 'images)