;;
;;  FILE
;;	newicon.el		$VER: V1.00 newicon.el
;;
;;  DESCRIPTION
;;      A new icon-creating scheme.
;;
;;	When creating icons, the following replacement routine searches
;;  	for icons of the name "def_<extension>.info". 
;;  	The routine searches first in the directories specified a _list_
;;  	by the user in the variable "amiga-icon-path" and then in 
;;  	"Gnuemacs:Icons/". The directories in the list must contain the 
;;	trailing slash.
;;
;;  	If it can't find any appropriate icons, and the file 
;;  	"Gnuemacs:Icons/def_emacs.info" exists, it is used. Otherwise
;;  	the original function is called.
;;
;;  	Note: icons are only created when the variable
;;  	"amiga-create-icons" is non-nil.
;;
;;  INSTALLATION
;;	Copy this file to a lisp-directory, for example Gnuemacs:lisp
;;
;;	Create a directory called Gnuemacs:icons and copy the icons to it.
;;
;;	Place the following line in your s:.emacs
;;	        (setq amiga-create-icons t)
;;		(load "newicon")
;;
;;  	Example: If the user would like to use the icons supplied by
;;	the SAS C-complier, the following lines could be placed
;;	in his or hers .emacs file:
;;	  (setq amiga-icon-path '("sc:Icons/"))
;;
;;  LICENSE
;;      Copyright (C) 1993  Anders Lindgren
;;
;;	This program 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 of the License,or
;;	(at your option) any later version.
;;
;;	This program is distributed in the hope that it will be useful,
;;	but WITHOUT ANY WARRANTY; without even the implied warranty of
;;	MERCHANTABILITY of 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 this program; if not, write to the Free Software
;;	Foundation, Inc., 675 Mass Ave, Cambridge, Ma 02139, USA.
;;
;;  HOW TO CONTACT ME:
;;	voice:   Scream  Anders Lindgren  LOUD
;;	email:   d91ali@csd.uu.se
;;	mail:    Anders Lindgren
;;	         Kantorsg. 2-331
;;	         S-754 24 Uppsala
;;	SUGA BBS:+46 (0)8 34 85 23
;;		 +46 (0)8 34 32 76  
;;

(defvar amiga-icon-path '()
  "A list of directories to scan when searching for new icons.")

(if (not (fboundp 'old-amiga-put-icon))
    (fset 'old-amiga-put-icon (symbol-function 'amiga-put-icon)))

(defun amiga-put-icon (file force)
  (if (or force (not (file-readable-p (concat file ".info"))))
      (let ((extpos (string-match "\\.[a-zA-Z]*\\'" file))
	    (iconname nil)
	    (path (append amiga-icon-path '("gnuemacs:icons/")))
	    (found nil))
	(if (and extpos (< 0 extpos))
	    (while (and (not found) path)
	      (setq iconname (concat (car path) "def_" (substring file (+ 1 extpos)) ".info"))
	      (if (and iconname (file-readable-p iconname))
		  (progn
		    (copy-file iconname (concat file ".info"))
		    (setq found t)))
	      (setq path (cdr path))))
	(if (not found)
	    (if (file-readable-p "gnuemacs:Icons/def_emacs.info")
		(copy-file "gnuemacs:Icons/def_emacs.info" (concat file ".info"))
	      (old-amiga-put-icon file force))))))