;;; image-add.el --- Additions to image.el to support lisp xpm

;; Copyright (C) 2002  Free Software Foundation, Inc.

;; Author: Jason Rumney <jasonr@gnu.org>
;; Keywords: 

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; The functions here override ones in image.el, to allow the Lisp XPM
;; decoder to be a complete substitute for libXpm, including the
;; splash-screen.
;;
;; To use it, add the following to your .emacs
;;
;;   ;; xpm via elisp
;;   (and (display-images-p)
;;        (not (image-type-available-p 'xpm))
;;        (require 'image-add nil t)
;;        ;; Need to reset the toolbar to pick up the xpm images.
;;        (tool-bar-setup))
;;
;; Or you can just (require 'image-add) (tool-bar-setup) if you know
;; you'll never have native XPM support, but always have general image
;; support available.

;;; Code:

;; Need to load image first, so our functions override the real ones.
(require 'image)
(require 'xpm)

(defcustom use-lisp-xpm t
  "If non-nil, use lisp functions to read XPM files.
This happens only if Emacs was compiled without XPM support on the C
level.")

;; Extra internal function to avoid infinite loops. Does exactly what
;; image-type-available-p in image.el does.
(defun image-type-available-natively-p (type)
  "Value is non-nil if image type TYPE is available.
Image types are symbols like `xbm' or `jpeg'."
  (and (boundp 'image-types) (not (null (memq type image-types)))))

;; Override the version in image.el to include lisp based xpm.
(defun image-type-available-p (type)
  "Value is non-nil if image type TYPE is available.
Image types are symbols like `xbm' or `jpeg'."
  (or (image-type-available-natively-p type)
      (and (eq type 'xpm) use-lisp-xpm)))

;; Overridden to use image-type-available-natively-p where we really
;; need it.
(defun create-image (file-or-data &optional type data-p &rest props)
  "Create an image.
FILE-OR-DATA is an image file name or image data.
Optional TYPE is a symbol describing the image type.  If TYPE is omitted
or nil, try to determine the image type from its first few bytes
of image data.  If that doesn't work, and FILE-OR-DATA is a file name,
use its file extension as image type.
Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data.
Optional PROPS are additional image attributes to assign to the image,
like, e.g. `:mask MASK'.
Value is the image created, or nil if images of type TYPE are not supported."
  (when (and (not data-p) (not (stringp file-or-data)))
    (error "Invalid image file name `%s'" file-or-data))
  (cond ((null data-p)
	 ;; FILE-OR-DATA is a file name.
	 (unless (or type
		     (setq type (image-type-from-file-header file-or-data)))
	   (let ((extension (file-name-extension file-or-data)))
	     (unless extension
	       (error "Cannot determine image type"))
	     (setq type (intern extension)))))
	(t
	 ;; FILE-OR-DATA contains image data.
	 (unless type
	   (setq type (image-type-from-data file-or-data)))))
  (unless type
    (error "Cannot determine image type"))
  (unless (symbolp type)
    (error "Invalid image type `%s'" type))
  (if (image-type-available-natively-p type)
      (append (list 'image :type type (if data-p :data :file) file-or-data)
	      props)
    (when (and (eq type 'xpm) use-lisp-xpm)
      ;; Use Lisp to deal with the XPM.
      (apply 'xpm-create-image file-or-data data-p props))))

;; Overridden to use image-type-available-natively-p where we really
;; need it.
(defun find-image (specs)
  "Find an image, choosing one of a list of image specifications.

SPECS is a list of image specifications.

Each image specification in SPECS is a property list.  The contents of
a specification are image type dependent.  All specifications must at
least contain the properties `:type TYPE' and either `:file FILE' or
`:data DATA', where TYPE is a symbol specifying the image type,
e.g. `xbm', FILE is the file to load the image from, and DATA is a
string containing the actual image data.  The specification whose TYPE
is supported, and FILE exists, is used to construct the image
specification to be returned.  Return nil if no specification is
satisfied.

The image is looked for first on `load-path' and then in `data-directory'."
  (let (image)
    (while (and specs (null image))
      (let* ((spec (car specs))
	     (type (plist-get spec :type))
	     (data (plist-get spec :data))
	     (file (plist-get spec :file))
	     found)
	(when (image-type-available-p type)
	  (cond ((stringp file)
		 (let ((path load-path))
		   (while (and (not found) path)
		     (let ((try-file (expand-file-name file (car path))))
		       (when (file-readable-p try-file)
			 (setq found try-file)))
		     (setq path (cdr path)))
		   (unless found
		     (let ((try-file (expand-file-name file data-directory)))
		       (if (file-readable-p try-file)
			   (setq found try-file))))
		   (when found
		     (if (image-type-available-natively-p type)
			 (setq image
			       (cons 'image (plist-put (copy-sequence spec)
						       :file found)))
		       ;; Use Lisp functions to deal with XPMs.
		       (setq image
			     (apply 'xpm-create-image found nil spec))))))
		((not (null data))
		 (if (image-type-available-natively-p type)
		     (setq image (cons 'image spec))
		   (setq image (apply 'xpm-create-image data t spec))))))
	(setq specs (cdr specs))))
    image))

(provide 'image-add)
;;; image-add.el ends here