PageRenderTime 74ms CodeModel.GetById 12ms app.highlight 49ms RepoModel.GetById 1ms app.codeStats 1ms

/vendor/color-theme/color-theme.el

http://github.com/rejeep/emacs
Emacs Lisp | 1668 lines | 1178 code | 176 blank | 314 comment | 37 complexity | f19e84fcf791042f22d125434314f391 MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1;;; color-theme.el --- install color themes
   2
   3;; Copyright (C) 1999, 2000  Jonadab the Unsightly One <jonadab@bright.net>
   4;; Copyright (C) 2000, 2001, 2002, 2003  Alex Schroeder <alex@gnu.org>
   5;; Copyright (C) 2003, 2004, 2005, 2006  Xavier Maillard <zedek@gnu.org>
   6
   7;; Version: 6.6.0
   8;; Keywords: faces
   9;; Author: Jonadab the Unsightly One <jonadab@bright.net>
  10;; Maintainer: Xavier Maillard <zedek@gnu.org>
  11;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ColorTheme
  12
  13;; This file is not (YET) part of GNU Emacs.
  14
  15;; This is free software; you can redistribute it and/or modify it under
  16;; the terms of the GNU General Public License as published by the Free
  17;; Software Foundation; either version 2, or (at your option) any later
  18;; version.
  19;;
  20;; This is distributed in the hope that it will be useful, but WITHOUT
  21;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  22;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  23;; for more details.
  24;;
  25;; You should have received a copy of the GNU General Public License
  26;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  28;; MA 02111-1307, USA.
  29
  30;;; Commentary:
  31
  32;; Please read README and BUGS files for any relevant help.
  33;; Contributors (not themers) should also read HACKING file.
  34
  35;;; Thanks
  36
  37;; Deepak Goel  <deego@glue.umd.edu>
  38;; S. Pokrovsky <pok@nbsp.nsk.su> for ideas and discussion.
  39;; Gordon Messmer <gordon@dragonsdawn.net> for ideas and discussion.
  40;; Sriram Karra <karra@cs.utah.edu> for the color-theme-submit stuff.
  41;; Olgierd `Kingsajz' Ziolko <kingsajz@rpg.pl> for the spec-filter idea.
  42;; Brian Palmer for color-theme-library ideas and code
  43;; All the users that contributed their color themes.
  44
  45
  46
  47;;; Code:
  48(eval-when-compile
  49  (require 'easymenu)
  50  (require 'reporter)
  51  (require 'sendmail))
  52
  53(require 'cl); set-difference is a function...
  54
  55;; for custom-face-attributes-get or face-custom-attributes-get
  56(require 'cus-face)
  57(require 'wid-edit); for widget-apply stuff in cus-face.el
  58
  59(defconst color-theme-maintainer-address "zedek@gnu.org"
  60  "Address used by `submit-color-theme'.")
  61
  62;; Emacs / XEmacs compatibility and workaround layer
  63
  64(cond ((and (facep 'tool-bar)
  65	    (not (facep 'toolbar)))
  66       (put 'toolbar 'face-alias 'tool-bar))
  67      ((and (facep 'toolbar)
  68	    (not (facep 'tool-bar)))
  69       (put 'tool-bar 'face-alias 'toolbar)))
  70
  71(defvar color-theme-xemacs-p (and (featurep 'xemacs) 
  72                                  (string-match "XEmacs" emacs-version))
  73  "Non-nil if running XEmacs.")
  74
  75;; Add this since it appears to miss in emacs-2x
  76(or (fboundp 'replace-in-string)
  77    (defun replace-in-string (target old new)
  78      (replace-regexp-in-string old new  target)))
  79
  80;; face-attr-construct has a problem in Emacs 20.7 and older when
  81;; dealing with inverse-video faces.  Here is a short test to check
  82;; wether you are affected.
  83
  84;; (set-background-color "wheat")
  85;; (set-foreground-color "black")
  86;; (setq a (make-face 'a-face))
  87;; (face-spec-set a '((t (:background "white" :foreground "black" :inverse-video t))))
  88;; (face-attr-construct a)
  89;;     => (:background "black" :inverse-video t)
  90
  91;; The expected response is the original specification:
  92;;     => (:background "white" :foreground "black" :inverse-video t)
  93
  94;; That's why we depend on cus-face.el functionality.
  95
  96(cond ((fboundp 'custom-face-attributes-get)
  97       (defun color-theme-face-attr-construct (face frame)
  98         (if (atom face)
  99             (custom-face-attributes-get face frame)
 100             (if (and (consp face) (eq (car face) 'quote))
 101                 (custom-face-attributes-get (cadr face) frame)
 102                 (custom-face-attributes-get (car face) frame)))))
 103      ((fboundp 'face-custom-attributes-get)
 104       (defalias 'color-theme-face-attr-construct
 105	 'face-custom-attributes-get))
 106      (t
 107       (defun color-theme-face-attr-construct (&rest ignore)
 108	 (error "Unable to construct face attributes"))))
 109
 110(defun color-theme-alist (plist)
 111  "Transform PLIST into an alist if it is a plist and return it.
 112If the first element of PLIST is a cons cell, we just return PLIST,
 113assuming PLIST to be an alist.  If the first element of plist is not a
 114symbol, this is an error: We cannot distinguish a plist from an ordinary
 115list, but a list that doesn't start with a symbol is certainly no plist
 116and no alist.
 117
 118This is used to make sure `default-frame-alist' really is an alist and not
 119a plist.  In XEmacs, the alist is deprecated; a plist is used instead."
 120  (cond ((consp (car plist))
 121	 plist)
 122	((not (symbolp (car plist)))
 123	 (error "Wrong type argument: plist, %S" plist))
 124	((featurep 'xemacs)
 125	 (plist-to-alist plist)))); XEmacs only
 126
 127;; Customization
 128
 129(defgroup color-theme nil
 130  "Color Themes for Emacs.
 131A color theme consists of frame parameter settings, variable settings,
 132and face definitions."
 133  :version "20.6"
 134  :group 'faces)
 135
 136(defcustom color-theme-legal-frame-parameters "\\(color\\|mode\\)$"
 137  "Regexp that matches frame parameter names.
 138Only frame parameter names that match this regexp can be changed as part
 139of a color theme."
 140  :type '(choice (const :tag "Colors only" "\\(color\\|mode\\)$")
 141		 (const :tag "Colors, fonts, and size"
 142			"\\(color\\|mode\\|font\\|height\\|width\\)$")
 143		 (regexp :tag "Custom regexp"))
 144  :group 'color-theme
 145  :link '(info-link "(elisp)Window Frame Parameters"))
 146
 147(defcustom color-theme-legal-variables "\\(color\\|face\\)$"
 148  "Regexp that matches variable names.
 149Only variables that match this regexp can be changed as part of a color
 150theme.  In addition to matching this name, the variables have to be user
 151variables (see function `user-variable-p')."
 152  :type 'regexp
 153  :group 'color-theme)
 154
 155(defcustom color-theme-illegal-faces "^w3-"
 156  "Regexp that matches face names forbidden in themes.
 157The default setting \"^w3-\" excludes w3 faces since these
 158are created dynamically."
 159  :type 'regexp
 160  :group 'color-theme
 161  :link '(info-link "(elisp)Faces for Font Lock")
 162  :link '(info-link "(elisp)Standard Faces"))
 163
 164(defcustom color-theme-illegal-default-attributes '(:family :height :width)
 165  "A list of face properties to be ignored when installing faces.
 166This prevents Emacs from doing terrible things to your display just because
 167a theme author likes weird fonts."
 168  :type '(repeat symbol)
 169  :group 'color-theme)
 170
 171(defcustom color-theme-is-global t
 172  "*Determines wether a color theme is installed on all frames or not.
 173If non-nil, color themes will be installed for all frames.
 174If nil, color themes will be installed for the selected frame only.
 175
 176A possible use for this variable is dynamic binding. Here is a larger
 177example to put in your ~/.emacs; it will make the Blue Sea color theme
 178the default used for the first frame, and it will create two additional
 179frames with different color themes.
 180
 181setup:
 182    \(require 'color-theme)
 183    ;; set default color theme
 184    \(color-theme-blue-sea)
 185    ;; create some frames with different color themes
 186    \(let ((color-theme-is-global nil))
 187      \(select-frame (make-frame))
 188      \(color-theme-gnome2)
 189      \(select-frame (make-frame))
 190      \(color-theme-standard))
 191
 192Please note that using XEmacs and and a nil value for
 193color-theme-is-global will ignore any variable settings for the color
 194theme, since XEmacs doesn't have frame-local variable bindings.
 195
 196Also note that using Emacs and a non-nil value for color-theme-is-global
 197will install a new color theme for all frames.  Using XEmacs and a
 198non-nil value for color-theme-is-global will install a new color theme
 199only on those frames that are not using a local color theme."
 200  :type 'boolean
 201  :group 'color-theme)
 202
 203(defcustom color-theme-is-cumulative t
 204  "*Determines wether new color themes are installed on top of each other.
 205If non-nil, installing a color theme will undo all settings made by
 206previous color themes."
 207  :type 'boolean
 208  :group 'color-theme)
 209
 210(defcustom color-theme-directory nil
 211  "Directory where we can find additionnal themes (personnal).
 212Note that there is at least one directory shipped with the official
 213color-theme distribution where all contributed themes are located.
 214This official selection can't be changed with that variable. 
 215However, you still can decide to turn it on or off and thus,
 216not be shown with all themes but yours."
 217  :type '(repeat string)
 218  :group 'color-theme)
 219
 220(defcustom color-theme-libraries (directory-files 
 221                                  (concat 
 222                                   (file-name-directory (locate-library "color-theme"))
 223                                   "/themes") t "^color-theme")
 224  "A list of files, which will be loaded in color-theme-initialize depending
 225on `color-theme-load-all-themes' value. 
 226This allows a user to prune the default color-themes (which can take a while
 227to load)."
 228  :type '(repeat string)
 229  :group 'color-theme)
 230
 231(defcustom color-theme-load-all-themes t
 232  "When t, load all color-theme theme files
 233as presented by `color-theme-libraries'. Else
 234do not load any of this themes."
 235  :type 'boolean
 236  :group 'color-theme)
 237
 238(defcustom color-theme-mode-hook nil
 239  "Hook for color-theme-mode."
 240  :type 'hook
 241  :group 'color-theme)
 242
 243(defvar color-theme-mode-map
 244  (let ((map (make-sparse-keymap)))
 245    (define-key map (kbd "RET") 'color-theme-install-at-point)
 246    (define-key map (kbd "c") 'list-colors-display)
 247    (define-key map (kbd "d") 'color-theme-describe)
 248    (define-key map (kbd "f") 'list-faces-display)
 249    (define-key map (kbd "i") 'color-theme-install-at-point)
 250    (define-key map (kbd "l") 'color-theme-install-at-point-for-current-frame)
 251    (define-key map (kbd "p") 'color-theme-print)
 252    (define-key map (kbd "q") 'bury-buffer)
 253    (define-key map (kbd "?") 'color-theme-describe)
 254    (if color-theme-xemacs-p
 255	(define-key map (kbd "<button2>") 'color-theme-install-at-mouse)
 256      (define-key map (kbd "<mouse-2>") 'color-theme-install-at-mouse))
 257    map)
 258  "Mode map used for the buffer created by `color-theme-select'.")
 259
 260(defvar color-theme-initialized nil
 261  "Internal variable determining whether color-theme-initialize has been invoked yet")
 262
 263(defvar color-theme-buffer-name "*Color Theme Selection*"
 264  "Name of the color theme selection buffer.")
 265
 266(defvar color-theme-original-frame-alist nil
 267  "nil until one of the color themes has been installed.")
 268
 269(defvar color-theme-history nil
 270  "List of color-themes called, in reverse order")
 271
 272(defcustom color-theme-history-max-length nil
 273  "Max length of history to maintain.
 274Two other values are acceptable: t means no limit, and
 275nil means that no history is maintained."
 276  :type '(choice (const :tag "No history" nil)
 277		 (const :tag "Unlimited length" t)
 278		 integer)
 279  :group 'color-theme)
 280
 281(defvar color-theme-counter 0
 282  "Counter for every addition to `color-theme-history'.
 283This counts how many themes were installed, regardless
 284of `color-theme-history-max-length'.")
 285
 286(defvar color-theme-entry-path (cond
 287                                ;; Emacs 22.x and later
 288                                ((lookup-key global-map [menu-bar tools])
 289                                 '("tools"))
 290                                ;; XEmacs
 291                                ((featurep 'xemacs)
 292                                 (setq tool-entry '("Tools")))
 293                                ;; Emacs < 22
 294                                (t
 295                                 '("Tools")))
 296  "Menu tool entry path.")
 297
 298(defun color-theme-add-to-history (name)
 299  "Add color-theme NAME to `color-theme-history'."
 300  (setq color-theme-history
 301	(cons (list name color-theme-is-cumulative)
 302	      color-theme-history)
 303	color-theme-counter (+ 1 color-theme-counter))
 304  ;; Truncate the list if necessary.
 305  (when (and (integerp color-theme-history-max-length)
 306	     (>= (length color-theme-history)
 307		 color-theme-history-max-length))
 308    (setcdr (nthcdr (1- color-theme-history-max-length)
 309		    color-theme-history)
 310	    nil)))
 311
 312;; (let ((l '(1 2 3 4 5)))
 313;;   (setcdr (nthcdr 2 l) nil)
 314;;   l)
 315
 316
 317
 318;; List of color themes used to create the *Color Theme Selection*
 319;; buffer.
 320
 321(defvar color-themes
 322  '((color-theme-aalto-dark "Aalto Dark" "Jari Aalto <jari.aalto@poboxes.com>")
 323    (color-theme-aalto-light "Aalto Light" "Jari Aalto <jari.aalto@poboxes.com>")
 324    (color-theme-aliceblue "Alice Blue" "Girish Bharadwaj <girishb@gbvsoft.com>")
 325    (color-theme-andreas "Andreas" "Andreas Busch <Andreas.Busch@politics.ox.ac.uk>")
 326    (color-theme-arjen "Arjen" "Arjen Wiersma <arjen@wiersma.org>")
 327    (color-theme-beige-diff "Beige Diff" "Alex Schroeder <alex@gnu.org>" t)
 328    (color-theme-bharadwaj "Bharadwaj" "Girish Bharadwaj <girishb@gbvsoft.com>")
 329    (color-theme-bharadwaj-slate "Bharadwaj Slate" "Girish Bharadwaj <girishb@gbvsoft.com>")
 330    (color-theme-billw "Billw" "Bill White <billw@wolfram.com>")
 331    (color-theme-black-on-gray "BlackOnGray" "Sudhir Bhojwani <sbhojwani@altoweb.com>")
 332    (color-theme-blippblopp "Blipp Blopp" "Thomas Sicheritz-Ponten<thomas@biopython.org>")
 333    (color-theme-simple-1 "Black" "Jonadab <jonadab@bright.net>")
 334    (color-theme-blue-erc "Blue ERC" "Alex Schroeder <alex@gnu.org>" t)
 335    (color-theme-blue-gnus "Blue Gnus" "Alex Schroeder <alex@gnu.org>" t)
 336    (color-theme-blue-mood "Blue Mood" "Nelson Loyola <nloyola@yahoo.com>")
 337    (color-theme-blue-sea "Blue Sea" "Alex Schroeder <alex@gnu.org>")
 338    (color-theme-calm-forest "Calm Forest" "Artur Hefczyc <kobit@plusnet.pl>")
 339    (color-theme-charcoal-black "Charcoal Black" "Lars Chr. Hausmann <jazz@zqz.dk>")
 340    (color-theme-goldenrod "Cheap Goldenrod" "Alex Schroeder <alex@gnu.org>")
 341    (color-theme-clarity "Clarity and Beauty" "Richard Wellum <rwellum@cisco.com>")
 342    (color-theme-classic "Classic" "Frederic Giroud <postcard@worldonline.fr>")
 343    (color-theme-comidia "Comidia" "Marcelo Dias de Toledo <mtole@ig.com.br>")
 344    (color-theme-jsc-dark "Cooper Dark" "John S Cooper <John.Cooper@eu.citrix.com>")
 345    (color-theme-jsc-light "Cooper Light" "John S Cooper <John.Cooper@eu.citrix.com>")
 346    (color-theme-jsc-light2 "Cooper Light 2" "John S Cooper <John.Cooper@eu.citrix.com>")
 347    (color-theme-dark-blue "Dark Blue" "Chris McMahan <cmcmahan@one.net>")
 348    (color-theme-dark-blue2 "Dark Blue 2" "Chris McMahan <cmcmahan@one.net>")
 349    (color-theme-dark-green "Dark Green" "eddy_woody@hotmail.com")
 350    (color-theme-dark-laptop "Dark Laptop" "Laurent Michel <ldm@cs.brown.edu>")
 351    (color-theme-deep-blue "Deep Blue" "Tomas Cerha <cerha@brailcom.org>")
 352    (color-theme-digital-ofs1 "Digital OFS1" "Gareth Owen <gowen@gwowen.freeserve.co.uk>")
 353    (color-theme-euphoria "Euphoria" "oGLOWo@oGLOWo.cjb.net")
 354    (color-theme-feng-shui "Feng Shui" "Walter Higgins <walterh@rocketmail.com>")
 355    (color-theme-fischmeister "Fischmeister"
 356			      "Sebastian Fischmeister <sfischme@nexus.lzk.tuwien.ac.at>")
 357    (color-theme-gnome "Gnome" "Jonadab <jonadab@bright.net>")
 358    (color-theme-gnome2 "Gnome 2" "Alex Schroeder <alex@gnu.org>")
 359    (color-theme-gray1 "Gray1" "Paul Pulli <P.Pulli@motorola.com>")
 360    (color-theme-gray30 "Gray30" "Girish Bharadwaj <girishb@gbvsoft.com>")
 361    (color-theme-kingsajz "Green Kingsajz" "Olgierd `Kingsajz' Ziolko <kingsajz@rpg.pl>")
 362    (color-theme-greiner "Greiner" "Kevin Greiner <kgreiner@mapquest.com>")
 363    (color-theme-gtk-ide "GTK IDE" "Gordon Messmer <gordon@dragonsdawn.net>")
 364    (color-theme-high-contrast "High Contrast" "Alex Schroeder <alex@gnu.org>")
 365    (color-theme-hober "Hober" "Edward O'Connor <ted@oconnor.cx>")
 366    (color-theme-infodoc "Infodoc" "Frederic Giroud <postcard@worldonline.fr>")
 367    (color-theme-jb-simple "JB Simple" "jeff@dvns.com")
 368    (color-theme-jedit-grey "Jedit Grey" "Gordon Messmer <gordon@dragonsdawn.net>")
 369    (color-theme-jonadabian "Jonadab" "Jonadab <jonadab@bright.net>")
 370    (color-theme-jonadabian-slate "Jonadabian Slate" "Jonadab <jonadab@bright.net>")
 371    (color-theme-katester "Katester" "Higgins_Walter@emc.com")
 372    (color-theme-late-night "Late Night" "Alex Schroeder <alex@gnu.org>")
 373    (color-theme-lawrence "Lawrence" "lawrence mitchell <wence@gmx.li>")
 374    (color-theme-lethe "Lethe" "Ivica Loncar <ivica.loncar@srk.fer.hr>")
 375    (color-theme-ld-dark "Linh Dang Dark" "Linh Dang <linhd@nortelnetworks.com>")
 376    (color-theme-marine "Marine" "Girish Bharadwaj <girishb@gbvsoft.com>")
 377    (color-theme-matrix "Matrix" "Walter Higgins <walterh@rocketmail.com>")
 378    (color-theme-marquardt "Marquardt" "Colin Marquardt <colin@marquardt-home.de>")
 379    (color-theme-midnight "Midnight" "Gordon Messmer <gordon@dragonsdawn.net>")
 380    (color-theme-mistyday "Misty Day" "Hari Kumar <Hari.Kumar@mtm.kuleuven.ac.be>")
 381    (color-theme-montz "Montz" "Brady Montz <bradym@becomm.com>")
 382    (color-theme-oswald "Oswald" "Tom Oswald <toswald@sharplabs.com>")
 383    (color-theme-parus "Parus" "Jon K Hellan <hellan@acm.org>")
 384    (color-theme-pierson "Pierson" "Dan L. Pierson <dan@sol.control.com>")
 385    (color-theme-ramangalahy "Ramangalahy" "Solofo Ramangalahy <solofo@irisa.fr>")
 386    (color-theme-raspopovic "Raspopovic" "Pedja Raspopovic <pedja@lsil.com>")
 387    (color-theme-renegade "Renegade" "Dave Benjamin <ramen@ramenfest.com>")
 388    (color-theme-resolve "Resolve" "Damien Elmes <resolve@repose.cx>")
 389    (color-theme-retro-green "Retro Green" "Alex Schroeder <alex@gnu.org>")
 390    (color-theme-retro-orange "Retro Orange" "Alex Schroeder <alex@gnu.org>")
 391    (color-theme-robin-hood "Robin Hood" "Alex Schroeder <alex@gnu.org>")
 392    (color-theme-rotor "Rotor" "Jinwei Shen <shenjw@wam.umd.edu>")
 393    (color-theme-ryerson "Ryerson" "Luis Fernandes <elf@ee.ryerson.ca>")
 394    (color-theme-salmon-diff "Salmon Diff" "Alex Schroeder <alex@gnu.org>" t)
 395    (color-theme-salmon-font-lock "Salmon Font-Lock" "Alex Schroeder <alex@gnu.org>" t)
 396    (color-theme-scintilla "Scintilla" "Gordon Messmer <gordon@dragonsdawn.net>")
 397    (color-theme-shaman "Shaman" "shaman@interdon.net")
 398    (color-theme-sitaramv-nt "Sitaram NT"
 399			     "Sitaram Venkatraman <sitaramv@loc251.tandem.com>")
 400    (color-theme-sitaramv-solaris "Sitaram Solaris"
 401				  "Sitaram Venkatraman <sitaramv@loc251.tandem.com>")
 402    (color-theme-snow "Snow" "Nicolas Rist <Nicolas.Rist@alcatel.de>")
 403    (color-theme-snowish "Snowish" "Girish Bharadwaj <girishb@gbvsoft.com>")
 404    (color-theme-standard-ediff "Standard Ediff" "Emacs Team, added by Alex Schroeder <alex@gnu.org>" t)
 405    (color-theme-standard "Standard Emacs 20" "Emacs Team, added by Alex Schroeder <alex@gnu.org>")
 406    (color-theme-emacs-21 "Standard Emacs 21" "Emacs Team, added by Alex Schroeder <alex@gnu.org>")
 407    (color-theme-emacs-nw "Standard Emacs 21 No Window" "Emacs Team, added by D. Goel <deego@gnufans.org>")
 408    (color-theme-xemacs "Standard XEmacs" "XEmacs Team, added by Alex Schroeder <alex@gnu.org>")
 409    (color-theme-subtle-blue "Subtle Blue" "Chris McMahan <cmcmahan@one.net>")
 410    (color-theme-subtle-hacker "Subtle Hacker" "Colin Walters <levanti@verbum.org>")
 411    (color-theme-taming-mr-arneson "Taming Mr Arneson" "Erik Arneson <erik@aarg.net>")
 412    (color-theme-taylor "Taylor" "Art Taylor <reeses@hemisphere.org>")
 413    (color-theme-tty-dark "TTY Dark" "O Polite <m2@plusseven.com>")
 414    (color-theme-vim-colors "Vim Colors" "Michael Soulier <msoulier@biryani.nssg.mitel.com>")
 415    (color-theme-whateveryouwant "Whateveryouwant" "Fabien Penso <penso@linuxfr.org>, color by Scott Jaderholm <scott@jaderholm.com>")
 416    (color-theme-wheat "Wheat" "Alex Schroeder <alex@gnu.org>")
 417    (color-theme-pok-wob "White On Black" "S. Pokrovsky <pok@nbsp.nsk.su>")
 418    (color-theme-pok-wog "White On Grey" "S. Pokrovsky <pok@nbsp.nsk.su>")
 419    (color-theme-word-perfect "WordPerfect" "Thomas Gehrlein <Thomas.Gehrlein@t-online.de>")
 420    (color-theme-xp "XP" "Girish Bharadwaj <girishb@gbvsoft.com>"))
 421  "List of color themes.
 422
 423Each THEME is itself a three element list (FUNC NAME MAINTAINER &optional LIBRARY).
 424
 425FUNC is a color theme function which does the setup.  The function
 426FUNC may call `color-theme-install'.  The color theme function may be
 427interactive.
 428
 429NAME is the name of the theme and MAINTAINER is the name and/or email of
 430the maintainer of the theme.
 431
 432If LIBRARY is non-nil, the color theme will be considered a library and
 433may not be shown in the default menu.
 434
 435If you defined your own color theme and want to add it to this list,
 436use something like this:
 437
 438  (add-to-list 'color-themes '(color-theme-gnome2 \"Gnome2\" \"Alex\"))")
 439
 440;;; Functions
 441
 442(defun color-theme-backup-original-values ()
 443  "Back up the original `default-frame-alist'.
 444The values are stored in `color-theme-original-frame-alist' on
 445startup."
 446  (if (null color-theme-original-frame-alist)
 447      (setq color-theme-original-frame-alist
 448	    (color-theme-filter (frame-parameters (selected-frame))
 449				color-theme-legal-frame-parameters))))
 450(add-hook 'after-init-hook 'color-theme-backup-original-values)
 451
 452;;;###autoload
 453(defun color-theme-select (&optional arg)
 454  "Displays a special buffer for selecting and installing a color theme.
 455With optional prefix ARG, this buffer will include color theme libraries
 456as well.  A color theme library is in itself not complete, it must be
 457used as part of another color theme to be useful.  Thus, color theme
 458libraries are mainly useful for color theme authors."
 459  (interactive "P")
 460  (unless color-theme-initialized (color-theme-initialize))
 461  (switch-to-buffer (get-buffer-create color-theme-buffer-name))
 462  (setq buffer-read-only nil)
 463  (erase-buffer)
 464  ;; recreate the snapshot if necessary
 465  (when (or (not (assq 'color-theme-snapshot color-themes))
 466	    (not (commandp 'color-theme-snapshot)))
 467    (fset 'color-theme-snapshot (color-theme-make-snapshot))
 468    (setq color-themes (delq (assq 'color-theme-snapshot color-themes)
 469			     color-themes)
 470	  color-themes (delq (assq 'bury-buffer color-themes)
 471			     color-themes)
 472	  color-themes (append '((color-theme-snapshot
 473				  "[Reset]" "Undo changes, if possible.")
 474				 (bury-buffer
 475				  "[Quit]" "Bury this buffer."))
 476			     color-themes)))
 477  (dolist (theme color-themes)
 478    (let ((func (nth 0 theme))
 479	  (name (nth 1 theme))
 480	  (author (nth 2 theme))
 481	  (library (nth 3 theme))
 482	  (desc))
 483      (when (or (not library) arg)
 484	(setq desc (format "%-23s %s" 
 485			   (if library (concat name " [lib]") name)
 486			   author))
 487	(put-text-property 0 (length desc) 'color-theme func desc)
 488	(put-text-property 0 (length name) 'face 'bold desc)
 489	(put-text-property 0 (length name) 'mouse-face 'highlight desc)
 490	(insert desc)
 491	(newline))))
 492  (goto-char (point-min))
 493  (setq buffer-read-only t)
 494  (set-buffer-modified-p nil)
 495  (color-theme-mode))
 496
 497(when (require 'easymenu)
 498  (easy-menu-add-item nil color-theme-entry-path "--")
 499  (easy-menu-add-item  nil color-theme-entry-path
 500                       ["Color Themes" color-theme-select t]))
 501
 502(defun color-theme-mode ()
 503  "Major mode to select and install color themes.
 504
 505Use \\[color-theme-install-at-point] to install a color theme on all frames.
 506Use \\[color-theme-install-at-point-for-current-frame] to install a color theme for the current frame only.
 507
 508The changes are applied on top of your current setup.  This is a
 509feature.
 510
 511Some of the themes should be considered extensions to the standard color
 512theme: they modify only a limited number of faces and variables.  To
 513verify the final look of a color theme, install the standard color
 514theme, then install the other color theme.  This is a feature. It allows
 515you to mix several color themes.
 516
 517Use \\[color-theme-describe] to read more about the color theme function at point.
 518If you want to install the color theme permanently, put the call to the
 519color theme function into your ~/.emacs:
 520
 521    \(require 'color-theme)
 522    \(color-theme-gnome2)
 523
 524If you worry about the size of color-theme.el: You are right.  Use
 525\\[color-theme-print] to print the current color theme and save the resulting buffer
 526as ~/.emacs-color-theme.  Now you can install only this specific color
 527theme in your .emacs:
 528
 529    \(load-file \"~/.emacs-color-theme\")
 530    \(my-color-theme)
 531
 532The Emacs menu is not affected by color themes within Emacs.  Depending
 533on the toolkit you used to compile Emacs, you might have to set specific
 534X ressources.  See the info manual for more information.  Here is an
 535example ~/.Xdefaults fragment:
 536
 537    emacs*Background: DarkSlateGray
 538    emacs*Foreground: wheat
 539
 540\\{color-theme-mode-map}
 541
 542The color themes are listed in `color-themes', which see."
 543  (kill-all-local-variables)
 544  (setq major-mode 'color-theme-mode)
 545  (setq mode-name "Color Themes")
 546  (use-local-map color-theme-mode-map)
 547  (when (functionp 'goto-address); Emacs
 548    (goto-address))
 549  (run-hooks 'color-theme-mode-hook))
 550
 551;;; Commands in Color Theme Selection mode
 552
 553;;;###autoload
 554(defun color-theme-describe ()
 555  "Describe color theme listed at point.
 556This shows the documentation of the value of text-property color-theme
 557at point.  The text-property color-theme should be a color theme
 558function.  See `color-themes'."
 559  (interactive)
 560  (describe-function (get-text-property (point) 'color-theme)))
 561
 562;;;###autoload
 563(defun color-theme-install-at-mouse (event)
 564  "Install color theme clicked upon using the mouse.
 565First argument EVENT is used to set point.  Then
 566`color-theme-install-at-point' is called."
 567  (interactive "e")
 568  (save-excursion
 569    (mouse-set-point event)
 570    (color-theme-install-at-point)))
 571
 572;;;autoload
 573(defun color-theme-install-at-point ()
 574  "Install color theme at point.
 575This calls the value of the text-property `color-theme' at point.
 576The text-property `color-theme' should be a color theme function.
 577See `color-themes'."
 578  (interactive)
 579  (let ((func (get-text-property (point) 'color-theme)))
 580    ;; install theme
 581    (if func
 582	(funcall func))
 583    ;; If goto-address is being used, remove all overlays in the current
 584    ;; buffer and run it again.  The face used for the mail addresses in
 585    ;; the the color theme selection buffer is based on the variable
 586    ;; goto-address-mail-face.  Changes in that variable will not affect
 587    ;; existing overlays, however, thereby confusing users.
 588    (when (functionp 'goto-address); Emacs
 589      (dolist (o (overlays-in (point-min) (point-max)))
 590	(delete-overlay o))
 591      (goto-address))))
 592
 593;;;###autoload
 594(defun color-theme-install-at-point-for-current-frame ()
 595  "Install color theme at point for current frame only.
 596Binds `color-theme-is-global' to nil and calls
 597`color-theme-install-at-point'."
 598  (interactive)
 599  (let ((color-theme-is-global nil))
 600    (color-theme-install-at-point)))
 601
 602
 603
 604;; Taking a snapshot of the current color theme and pretty printing it.
 605
 606(defun color-theme-filter (old-list regexp &optional exclude)
 607  "Filter OLD-LIST.
 608The resulting list will be newly allocated and contains only elements
 609with names matching REGEXP.  OLD-LIST may be a list or an alist.  If you
 610want to filter a plist, use `color-theme-alist' to convert your plist to
 611an alist, first.
 612
 613If the optional argument EXCLUDE is non-nil, then the sense is
 614reversed: only non-matching elements will be retained."
 615  (let (elem new-list)
 616    (dolist (elem old-list)
 617      (setq name (symbol-name (if (listp elem) (car elem) elem)))
 618      (when (or (and (not exclude)
 619		     (string-match regexp name))
 620		(and exclude
 621		     (not (string-match regexp name))))
 622	;; Now make sure that if elem is a cons cell, and the cdr of
 623	;; that cons cell is a string, then we need a *new* string in
 624	;; the new list.  Having a new cons cell is of no use because
 625	;; modify-frame-parameters will modify this string, thus
 626	;; modifying our color theme functions!
 627	(when (and (consp elem)
 628		   (stringp (cdr elem)))
 629	  (setq elem (cons (car elem)
 630			   (copy-sequence (cdr elem)))))
 631	;; Now store elem
 632	(setq new-list (cons elem new-list))))
 633    new-list))
 634
 635(defun color-theme-spec-filter (spec)
 636  "Filter the attributes in SPEC.
 637This makes sure that SPEC has the form ((t (PLIST ...))).
 638Only properties not in `color-theme-illegal-default-attributes'
 639are included in the SPEC returned."
 640  (let ((props (cadar spec))
 641	result prop val)
 642    (while props
 643      (setq prop (nth 0 props)
 644	    val (nth 1 props)
 645	    props (nthcdr 2 props))
 646      (unless (memq prop color-theme-illegal-default-attributes)
 647	(setq result (cons val (cons prop result)))))
 648    `((t ,(nreverse result)))))
 649
 650;; (color-theme-spec-filter '((t (:background "blue3"))))
 651;; (color-theme-spec-filter '((t (:stipple nil :background "Black" :foreground "SteelBlue" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :width semi-condensed :family "misc-fixed"))))
 652
 653(defun color-theme-plist-delete (plist prop)
 654  "Delete property PROP from property list PLIST by side effect.
 655This modifies PLIST."
 656  ;; deal with prop at the start
 657  (while (eq (car plist) prop)
 658    (setq plist (cddr plist)))
 659  ;; deal with empty plist
 660  (when plist
 661    (let ((lastcell (cdr plist))
 662	  (l (cddr plist)))
 663      (while l
 664	(if (eq (car l) prop)
 665	    (progn
 666	      (setq l (cddr l))
 667	      (setcdr lastcell l))
 668	  (setq lastcell (cdr l)
 669		l (cddr l))))))
 670  plist)
 671
 672;; (color-theme-plist-delete '(a b c d e f g h) 'a)
 673;; (color-theme-plist-delete '(a b c d e f g h) 'b)
 674;; (color-theme-plist-delete '(a b c d e f g h) 'c)
 675;; (color-theme-plist-delete '(a b c d e f g h) 'g)
 676;; (color-theme-plist-delete '(a b c d c d e f g h) 'c)
 677;; (color-theme-plist-delete '(a b c d e f c d g h) 'c)
 678
 679(if (or (featurep 'xemacs)
 680	(< emacs-major-version 21))
 681    (defalias 'color-theme-spec-compat 'identity)
 682  (defun color-theme-spec-compat (spec)
 683    "Filter the attributes in SPEC such that is is never invalid.
 684Example: Eventhough :bold works in Emacs, it is not recognized by
 685`customize-face' -- and then the face is uncustomizable.  This
 686function replaces a :bold attribute with the corresponding :weight
 687attribute, if there is no :weight, or deletes it.  This undoes the
 688doings of `color-theme-spec-canonical-font', more or less."
 689    (let ((props (cadar spec)))
 690      (when (plist-member props :bold)
 691	(setq props (color-theme-plist-delete props :bold))
 692	(unless (plist-member props :weight)
 693	  (setq props (plist-put props :weight 'bold))))
 694      (when (plist-member props :italic)
 695	(setq props (color-theme-plist-delete props :italic))
 696	(unless (plist-member props :slant)
 697	  (setq props (plist-put props :slant 'italic))))
 698      `((t ,props)))))
 699
 700;; (color-theme-spec-compat '((t (:foreground "blue" :bold t))))
 701;; (color-theme-spec-compat '((t (:bold t :foreground "blue" :weight extra-bold))))
 702;; (color-theme-spec-compat '((t (:italic t :foreground "blue"))))
 703;; (color-theme-spec-compat '((t (:slant oblique :italic t :foreground "blue"))))
 704
 705(defun color-theme-spec-canonical-font (atts)
 706  "Add :bold and :italic attributes if necessary."
 707  ;; add these to the front of atts -- this will keept the old value for
 708  ;; customize-face in Emacs 21.
 709  (when (and (memq (plist-get atts :weight)
 710		   '(ultra-bold extra-bold bold semi-bold))
 711	     (not (plist-get atts :bold)))
 712    (setq atts (cons :bold (cons t atts))))
 713  (when (and (not (memq (plist-get atts :slant)
 714			'(normal nil)))
 715	     (not (plist-get atts :italic)))
 716    (setq atts (cons :italic (cons t atts))))
 717  atts)
 718;; (color-theme-spec-canonical-font (color-theme-face-attr-construct 'bold (selected-frame)))
 719;; (defface foo '((t (:weight extra-bold))) "foo")
 720;; (color-theme-spec-canonical-font (color-theme-face-attr-construct 'foo (selected-frame)))
 721;; (face-spec-set 'foo '((t (:weight extra-bold))) nil)
 722;; (face-spec-set 'foo '((t (:bold t))) nil)
 723;; (face-spec-set 'foo '((t (:bold t :weight extra-bold))) nil)
 724
 725;; Handle :height according to NEWS file for Emacs 21
 726(defun color-theme-spec-resolve-height (old new)
 727  "Return the new height given OLD and NEW height.
 728OLD is the current setting, NEW is the setting inherited from."
 729  (cond ((not old)
 730	 new)
 731	((integerp old)
 732	 old)
 733	((and (floatp old)
 734	      (integerp new))
 735	 (round (* old new)))
 736	((and (floatp old)
 737	      (floatp new))
 738	 (* old new))
 739	((and (functionp old)
 740	      (integerp new))
 741	 (round (funcall old new)))
 742	((and (functionp old)
 743	      (float new))
 744	 `(lambda (f) (* (funcall ,old f) ,new)))
 745	((and (functionp old)
 746	      (functionp new))
 747	 `(lambda (f) (* (funcall ,old (funcall ,new f)))))
 748	(t
 749	 (error "Illegal :height attributes: %S or %S" old new))))
 750;; (color-theme-spec-resolve-height 12 1.2)
 751;; (color-theme-spec-resolve-height 1.2 1.2)
 752;; (color-theme-spec-resolve-height 1.2 12)
 753;; (color-theme-spec-resolve-height 1.2 'foo)
 754;; (color-theme-spec-resolve-height (lambda (f) (* 2 f)) 5)
 755;; (color-theme-spec-resolve-height (lambda (f) (* 2 f)) 2.0)
 756;; the following lambda is the result from the above calculation
 757;; (color-theme-spec-resolve-height (lambda (f) (* (funcall (lambda (f) (* 2 f)) f) 2.0)) 5)
 758
 759(defun color-theme-spec-resolve-inheritance (atts)
 760  "Resolve all occurences of the :inherit attribute."
 761  (let ((face (plist-get atts :inherit)))
 762    ;; From the Emacs 21 NEWS file: "Attributes from inherited faces are
 763    ;; merged into the face like an underlying face would be." --
 764    ;; therefore properties of the inherited face only add missing
 765    ;; attributes.
 766    (when face
 767      ;; remove :inherit face from atts -- this assumes only one
 768      ;; :inherit attribute.
 769      (setq atts (delq ':inherit (delq face atts)))
 770      (let ((more-atts (color-theme-spec-resolve-inheritance
 771			(color-theme-face-attr-construct
 772			 face (selected-frame))))
 773	    att val)
 774	(while more-atts
 775	  (setq att (car more-atts)
 776		val (cadr more-atts)
 777		more-atts (cddr more-atts))
 778	  ;; Color-theme assumes that no value is ever 'unspecified.
 779	  (cond ((eq att ':height); cumulative effect!
 780		 (setq atts (plist-put atts 
 781				       ':height 
 782				       (color-theme-spec-resolve-height
 783					(plist-get atts att) 
 784					val))))
 785		;; Default: Only put if it has not been specified before.
 786		((not (plist-get atts att))
 787		 (setq atts (cons att (cons val atts))))
 788		  
 789))))
 790    atts))
 791;; (color-theme-spec-resolve-inheritance '(:bold t))
 792;; (color-theme-spec-resolve-inheritance '(:bold t :foreground "blue"))
 793;; (color-theme-face-attr-construct 'font-lock-comment-face (selected-frame))
 794;; (color-theme-spec-resolve-inheritance '(:bold t :inherit font-lock-comment-face))
 795;; (color-theme-spec-resolve-inheritance '(:bold t :foreground "red" :inherit font-lock-comment-face))
 796;; (color-theme-face-attr-construct 'Info-title-2-face (selected-frame))
 797;; (color-theme-face-attr-construct 'Info-title-3-face (selected-frame))
 798;; (color-theme-face-attr-construct 'Info-title-4-face (selected-frame))
 799;; (color-theme-spec-resolve-inheritance '(:inherit Info-title-2-face))
 800
 801;; The :inverse-video attribute causes Emacs to swap foreground and
 802;; background colors, XEmacs does not.  Therefore, if anybody chooses
 803;; the inverse-video attribute, we 1. swap the colors ourselves in Emacs
 804;; and 2. we remove the inverse-video attribute in Emacs and XEmacs.
 805;; Inverse-video is only useful on a monochrome tty.
 806(defun color-theme-spec-maybe-invert (atts)
 807  "Remove the :inverse-video attribute from ATTS.
 808If ATTS contains :inverse-video t, remove it and swap foreground and
 809background color.  Return ATTS."
 810  (let ((inv (plist-get atts ':inverse-video)))
 811    (if inv
 812	(let (result att)
 813	  (while atts
 814	    (setq att (car atts)
 815		  atts (cdr atts))
 816	    (cond ((and (eq att :foreground) (not color-theme-xemacs-p))
 817		   (setq result (cons :background result)))
 818		  ((and (eq att :background) (not color-theme-xemacs-p))
 819		   (setq result (cons :foreground result)))
 820		  ((eq att :inverse-video)
 821		   (setq atts (cdr atts))); this prevents using dolist
 822		  (t
 823		   (setq result (cons att result)))))
 824	  (nreverse result))
 825      ;; else
 826      atts)))
 827;; (color-theme-spec-maybe-invert '(:bold t))
 828;; (color-theme-spec-maybe-invert '(:foreground "blue"))
 829;; (color-theme-spec-maybe-invert '(:background "red"))
 830;; (color-theme-spec-maybe-invert '(:inverse-video t))
 831;; (color-theme-spec-maybe-invert '(:inverse-video t :foreground "red"))
 832;; (color-theme-spec-maybe-invert '(:inverse-video t :background "red"))
 833;; (color-theme-spec-maybe-invert '(:inverse-video t :background "red" :foreground "blue" :bold t))
 834;; (color-theme-spec-maybe-invert '(:inverse-video nil :background "red" :foreground "blue" :bold t))
 835
 836(defun color-theme-spec (face)
 837  "Return a list for FACE which has the form (FACE SPEC).
 838See `defface' for the format of SPEC.  In this case we use only one
 839DISPLAY, t, and determine ATTS using `color-theme-face-attr-construct'.
 840If ATTS is nil, (nil) is used  instead.
 841
 842If ATTS contains :inverse-video t, we remove it and swap foreground and
 843background color using `color-theme-spec-maybe-invert'.  We do this
 844because :inverse-video is handled differently in Emacs and XEmacs.  We
 845will loose on a tty without colors, because in that situation,
 846:inverse-video means something."
 847  (let ((atts
 848	 (color-theme-spec-canonical-font
 849	  (color-theme-spec-maybe-invert
 850	   (color-theme-spec-resolve-inheritance
 851	    (color-theme-face-attr-construct face (selected-frame)))))))
 852    (if atts
 853	`(,face ((t ,atts)))
 854      `(,face ((t (nil)))))))
 855
 856(defun color-theme-get-params ()
 857  "Return a list of frame parameter settings usable in a color theme.
 858Such an alist may be installed by `color-theme-install-frame-params'.  The
 859frame parameters returned must match `color-theme-legal-frame-parameters'."
 860  (let ((params (color-theme-filter (frame-parameters (selected-frame))
 861				    color-theme-legal-frame-parameters)))
 862    (sort params (lambda (a b) (string< (symbol-name (car a))
 863					(symbol-name (car b)))))))
 864
 865(defun color-theme-get-vars ()
 866  "Return a list of variable settings usable in a color theme.
 867Such an alist may be installed by `color-theme-install-variables'.
 868The variable names must match `color-theme-legal-variables', and the
 869variable must be a user variable according to `user-variable-p'."
 870  (let ((vars)
 871	(val))
 872    (mapatoms (lambda (v)
 873		(and (boundp v)
 874		     (user-variable-p v)
 875		     (string-match color-theme-legal-variables
 876				   (symbol-name v))
 877		     (setq val (eval v))
 878		     (add-to-list 'vars (cons v val)))))
 879    (sort vars (lambda (a b) (string< (car a) (car b))))))
 880
 881(defun color-theme-print-alist (alist)
 882  "Print ALIST."
 883  (insert "\n     " (if alist "(" "nil"))
 884  (dolist (elem alist)
 885    (when (= (preceding-char) ?\))
 886      (insert "\n      "))
 887    (prin1 elem (current-buffer)))
 888  (when (= (preceding-char) ?\)) (insert ")")))
 889
 890(defun color-theme-get-faces ()
 891  "Return a list of faces usable in a color theme.
 892Such an alist may be installed by `color-theme-install-faces'.  The
 893faces returned must not match `color-theme-illegal-faces'."
 894  (let ((faces (color-theme-filter (face-list) color-theme-illegal-faces t)))
 895    ;; default face must come first according to comments in
 896    ;; custom-save-faces, the rest is to be sorted by name
 897    (cons 'default (sort (delq 'default faces) 'string-lessp))))
 898
 899(defun color-theme-get-face-definitions ()
 900  "Return face settings usable in a color-theme."
 901  (let ((faces (color-theme-get-faces)))
 902    (mapcar 'color-theme-spec faces)))
 903
 904(defun color-theme-print-faces (faces)
 905  "Print face settings for all faces returned by `color-theme-get-faces'."
 906  (when faces
 907    (insert "\n     "))
 908  (dolist (face faces)
 909    (when (= (preceding-char) ?\))
 910      (insert "\n     "))
 911    (prin1 face (current-buffer))))
 912
 913(defun color-theme-reset-faces ()
 914  "Reset face settings for all faces returned by `color-theme-get-faces'."
 915  (let ((faces (color-theme-get-faces))
 916	(face) (spec) (entry)
 917	(frame (if color-theme-is-global nil (selected-frame))))
 918    (while faces
 919      (setq entry (color-theme-spec (car faces)))
 920      (setq face (nth 0 entry))
 921      (setq spec '((t (nil))))
 922      (setq faces (cdr faces))
 923      (if (functionp 'face-spec-reset-face)
 924	  (face-spec-reset-face face frame)
 925	(face-spec-set face spec frame)
 926	(if color-theme-is-global
 927	    (put face 'face-defface-spec spec))))))
 928
 929(defun color-theme-print-theme (func doc params vars faces)
 930  "Print a theme into the current buffer.
 931FUNC is the function name, DOC the doc string, PARAMS the
 932frame parameters, VARS the variable bindings, and FACES
 933the list of faces and their specs."
 934  (insert "(defun " (symbol-name func) " ()\n"
 935	  "  \"" doc "\"\n"
 936	  "  (interactive)\n"
 937	  "  (color-theme-install\n"
 938	  "   '(" (symbol-name func))
 939  ;; alist of frame parameters
 940  (color-theme-print-alist params)
 941  ;; alist of variables
 942  (color-theme-print-alist vars)
 943  ;; remaining elements of snapshot: face specs
 944  (color-theme-print-faces faces)
 945  (insert ")))\n")
 946  (insert "(add-to-list 'color-themes '(" (symbol-name func) " "
 947          " \"THEME NAME\" \"YOUR NAME\"))")
 948  (goto-char (point-min)))
 949
 950;;;###autoload
 951(defun color-theme-print (&optional buf)
 952  "Print the current color theme function.
 953
 954You can contribute this function to <URL:news:gnu.emacs.sources> or
 955paste it into your .emacs file and call it.  That should recreate all
 956the settings necessary for your color theme.
 957
 958Example:
 959
 960    \(require 'color-theme)
 961    \(defun my-color-theme ()
 962      \"Color theme by Alex Schroeder, created 2000-05-17.\"
 963      \(interactive)
 964      \(color-theme-install
 965       '(...
 966	 ...
 967	 ...)))
 968    \(my-color-theme)
 969
 970If you want to use a specific color theme function, you can call the
 971color theme function in your .emacs directly.
 972
 973Example:
 974
 975    \(require 'color-theme)
 976    \(color-theme-gnome2)"
 977  (interactive)
 978  (message "Pretty printing current color theme function...")
 979  (switch-to-buffer (if buf
 980			buf
 981		      (get-buffer-create "*Color Theme*")))
 982  (unless buf
 983    (setq buffer-read-only nil)
 984    (erase-buffer))
 985  ;; insert defun
 986  (insert "(eval-when-compile"
 987          "    (require 'color-theme))\n")
 988  (color-theme-print-theme 'my-color-theme
 989			   (concat "Color theme by "
 990				   (if (string= "" user-full-name)
 991				       (user-login-name)
 992				     user-full-name)
 993				   ", created " (format-time-string "%Y-%m-%d") ".")
 994			   (color-theme-get-params)
 995			   (color-theme-get-vars)
 996			   (mapcar 'color-theme-spec (color-theme-get-faces)))
 997  (unless buf
 998    (emacs-lisp-mode))
 999  (goto-char (point-min))
1000  (message "Pretty printing current color theme function... done"))
1001
1002(defun color-theme-analyze-find-theme (code)
1003  "Find the sexpr that calls `color-theme-install'."
1004  (let (theme)
1005    (while (and (not theme) code)
1006      (when (eq (car code) 'color-theme-install)
1007	(setq theme code))
1008      (when (listp (car code))
1009	(setq theme (color-theme-analyze-find-theme (car code))))
1010      (setq code (cdr code)))
1011    theme))
1012
1013;; (equal (color-theme-analyze-find-theme
1014;; 	'(defun color-theme-blue-eshell ()
1015;; 	   "Color theme for eshell faces only."
1016;; 	   (color-theme-install
1017;; 	    '(color-theme-blue-eshell
1018;; 	      nil
1019;; 	      (eshell-ls-archive-face ((t (:bold t :foreground "IndianRed"))))
1020;; 	      (eshell-ls-backup-face ((t (:foreground "Grey"))))))))
1021;;        '(color-theme-install
1022;; 	 (quote
1023;; 	  (color-theme-blue-eshell
1024;; 	   nil
1025;; 	   (eshell-ls-archive-face ((t (:bold t :foreground "IndianRed"))))
1026;; 	   (eshell-ls-backup-face ((t (:foreground "Grey")))))))))
1027
1028(defun color-theme-analyze-add-face (a b regexp faces)
1029  "If only one of A or B are in FACES, the other is added, and FACES is returned.
1030If REGEXP is given, this is only done if faces contains a match for regexps."
1031  (when (or (not regexp)
1032	    (catch 'found
1033	      (dolist (face faces)
1034		(when (string-match regexp (symbol-name (car face)))
1035		  (throw 'found t)))))
1036    (let ((face-a (assoc a faces))
1037	  (face-b (assoc b faces)))
1038      (if (and face-a (not face-b))
1039	  (setq faces (cons (list b (nth 1 face-a))
1040			    faces))
1041	(if (and (not face-a) face-b)
1042	    (setq faces (cons (list a (nth 1 face-b))
1043			      faces))))))
1044  faces)
1045
1046;; (equal (color-theme-analyze-add-face
1047;; 	'blue 'violet nil
1048;; 	'((blue ((t (:foreground "blue"))))
1049;; 	  (bold ((t (:bold t))))))
1050;;        '((violet ((t (:foreground "blue"))))
1051;; 	 (blue ((t (:foreground "blue"))))
1052;; 	 (bold ((t (:bold t))))))
1053;; (equal (color-theme-analyze-add-face
1054;; 	'violet 'blue nil
1055;; 	'((blue ((t (:foreground "blue"))))
1056;; 	  (bold ((t (:bold t))))))
1057;;        '((violet ((t (:foreground "blue"))))
1058;; 	 (blue ((t (:foreground "blue"))))
1059;; 	 (bold ((t (:bold t))))))
1060;; (equal (color-theme-analyze-add-face
1061;; 	'violet 'blue "foo"
1062;; 	'((blue ((t (:foreground "blue"))))
1063;; 	  (bold ((t (:bold t))))))
1064;;        '((blue ((t (:foreground "blue"))))
1065;; 	 (bold ((t (:bold t))))))
1066;; (equal (color-theme-analyze-add-face
1067;; 	'violet 'blue "blue"
1068;; 	'((blue ((t (:foreground "blue"))))
1069;; 	  (bold ((t (:bold t))))))
1070;;        '((violet ((t (:foreground "blue"))))
1071;; 	 (blue ((t (:foreground "blue"))))
1072;; 	 (bold ((t (:bold t))))))
1073
1074(defun color-theme-analyze-add-faces (faces)
1075  "Add missing faces to FACES and return it."
1076  ;; The most important thing is to add missing faces for the other
1077  ;; editor.  These are the most important faces to check.  The
1078  ;; following rules list two faces, A and B.  If either of the two is
1079  ;; part of the theme, the other must be, too.  The optional third
1080  ;; argument specifies a regexp.  Only if an existing face name
1081  ;; matches this regexp, is the rule applied.
1082  (let ((rules '((font-lock-builtin-face font-lock-reference-face)
1083		 (font-lock-doc-face font-lock-doc-string-face)
1084		 (font-lock-constant-face font-lock-preprocessor-face)
1085		 ;; In Emacs 21 `modeline' is just an alias for
1086		 ;; `mode-line'.  I recommend the use of
1087		 ;; `modeline' until further notice.
1088		 (modeline mode-line)
1089		 (modeline modeline-buffer-id)
1090		 (modeline modeline-mousable)
1091		 (modeline modeline-mousable-minor-mode)
1092		 (region primary-selection)
1093		 (region zmacs-region)
1094		 (font-lock-string-face dired-face-boring "^dired")
1095		 (font-lock-function-name-face dired-face-directory "^dired")
1096		 (default dired-face-executable "^dired")
1097		 (font-lock-warning-face dired-face-flagged "^dired")
1098		 (font-lock-warning-face dired-face-marked "^dired")
1099		 (default dired-face-permissions "^dired")
1100		 (default dired-face-setuid "^dired")
1101		 (default dired-face-socket "^dired")
1102		 (font-lock-keyword-face dired-face-symlink "^dired")
1103		 (tool-bar menu))))
1104    (dolist (rule rules)
1105      (setq faces (color-theme-analyze-add-face
1106		   (nth 0 rule) (nth 1 rule) (nth 2 rule) faces))))
1107  ;; The `fringe' face defines what the left and right borders of the
1108  ;; frame look like in Emacs 21.  To give them default fore- and
1109  ;; background colors, use (fringe ((t (nil)))) in your color theme.
1110  ;; Usually it makes more sense to choose a color slightly lighter or
1111  ;; darker from the default background.
1112  (unless (assoc 'fringe faces)
1113    (setq faces (cons '(fringe ((t (nil)))) faces)))
1114  ;; The tool-bar should not be part of the frame-parameters, since it
1115  ;; should not appear or disappear depending on the color theme.  The
1116  ;; apppearance of the toolbar, however, can be changed by the color
1117  ;; theme.  For Emacs 21, use the `tool-bar' face.  The easiest way
1118  ;; to do this is to give it the default fore- and background colors.
1119  ;; This can be achieved using (tool-bar ((t (nil)))) in the theme.
1120  ;; Usually it makes more sense, however, to provide the same colors
1121  ;; as used in the `menu' face, and to specify a :box attribute.  In
1122  ;; order to alleviate potential Emacs/XEmacs incompatibilities,
1123  ;; `toolbar' will be defined as an alias for `tool-bar' if it does
1124  ;; not exist, and vice-versa.  This is done eventhough the face
1125  ;; `toolbar' seems to have no effect on XEmacs.  If you look at
1126  ;; XEmacs lisp/faces.el, however, you will find that it is in fact
1127  ;; referenced for XPM stuff.
1128  (unless (assoc 'tool-bar faces)
1129    (setq faces (cons '(tool-bar ((t (nil)))) faces)))
1130  ;; Move the default face back to the front, and sort the rest.
1131  (unless (eq (caar faces) 'default)
1132    (let ((face (assoc 'default faces)))
1133      (setq faces (cons face
1134			(sort (delete face faces)
1135			      (lambda (a b)
1136				(string-lessp (car a) (car b))))))))
1137  faces)
1138
1139(defun color-theme-analyze-remove-heights (faces)
1140  "Remove :height property where it is an integer and return FACES."
1141  ;; I don't recommend making font sizes part of a color theme.  Most
1142  ;; users would be surprised to see their font sizes change when they
1143  ;; install a color-theme.  Therefore, remove all :height attributes
1144  ;; if the value is an integer.  If the value is a float, this is ok
1145  ;; -- the value is relative to the default height.  One notable
1146  ;; exceptions is for a color-theme created for visually impaired
1147  ;; people.  These *must* use a larger font in order to be usable.
1148  (let (result)
1149    (dolist (face faces)
1150      (let ((props (cadar (nth 1 face))))
1151	(if (and (plist-member props :height)
1152		 (integerp (plist-get props :height)))
1153	    (setq props (color-theme-plist-delete props :height)
1154		  result (cons (list (car face) `((t ,props)))
1155			       result))
1156	  (setq result (cons face result)))))
1157    (nreverse result)))
1158
1159;; (equal (color-theme-analyze-remove-heights
1160;; 	'((blue ((t (:foreground "blue" :height 2))))
1161;; 	  (bold ((t (:bold t :height 1.0))))))
1162;;        '((blue ((t (:foreground "blue"))))
1163;; 	 (bold ((t (:bold t :height 1.0))))))
1164
1165;;;###autoload
1166(defun color-theme-analyze-defun ()
1167  "Once you have a color-theme printed, check for missing faces.
1168This is used by maintainers who receive a color-theme submission
1169and want to make sure it follows the guidelines by the color-theme
1170author."
1171  ;; The support for :foreground and :background attributes works for
1172  ;; Emacs 20 and 21 as well as for XEmacs.  :inverse-video is taken
1173  ;; care of while printing color themes.
1174  (interactive)
1175  ;; Parse the stuff and find the call to color-theme-install
1176  (save-excursion
1177    (save-restriction
1178      (narrow-to-defun)
1179      ;; define the function
1180      (eval-defun nil)
1181      (goto-char (point-min))
1182      (let* ((code (read (current-buffer)))
1183	     (theme (color-theme-canonic
1184		     (eval
1185		      (cadr
1186		       (color-theme-analyze-find-theme
1187			code)))))
1188	     (func (color-theme-function theme))
1189	     (doc (documentation func t))
1190	     (variables (color-theme-variables theme))
1191	     (faces (colo

Large files files are truncated, but you can click here to view the full file