1 ;;; color-theme.el --- install color themes

     2 

     3 ;; Copyright (C) 1999, 2000  Jonadab the Unsightly One <[email protected]>

     4 ;; Copyright (C) 2000, 2001, 2002, 2003  Alex Schroeder <[email protected]>

     5 ;; Copyright (C) 2003, 2004, 2005, 2006  Xavier Maillard <[email protected]>

     6 

     7 ;; Version: 6.6.0

     8 ;; Keywords: faces

     9 ;; Author: Jonadab the Unsightly One <[email protected]>

    10 ;; Maintainer: Xavier Maillard <[email protected]>

    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  <[email protected]>

    38 ;; S. Pokrovsky <[email protected]> for ideas and discussion.

    39 ;; Gordon Messmer <[email protected]> for ideas and discussion.

    40 ;; Sriram Karra <[email protected]> for the color-theme-submit stuff.

    41 ;; Olgierd `Kingsajz' Ziolko <[email protected]> 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 "[email protected]"

    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.

   112 If the first element of PLIST is a cons cell, we just return PLIST,

   113 assuming PLIST to be an alist.  If the first element of plist is not a

   114 symbol, this is an error: We cannot distinguish a plist from an ordinary

   115 list, but a list that doesn't start with a symbol is certainly no plist

   116 and no alist.

   117 

   118 This is used to make sure `default-frame-alist' really is an alist and not

   119 a 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.

   131 A color theme consists of frame parameter settings, variable settings,

   132 and 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.

   138 Only frame parameter names that match this regexp can be changed as part

   139 of 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.

   149 Only variables that match this regexp can be changed as part of a color

   150 theme.  In addition to matching this name, the variables have to be user

   151 variables (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.

   157 The default setting \"^w3-\" excludes w3 faces since these

   158 are 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.

   166 This prevents Emacs from doing terrible things to your display just because

   167 a 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.

   173 If non-nil, color themes will be installed for all frames.

   174 If nil, color themes will be installed for the selected frame only.

   175 

   176 A possible use for this variable is dynamic binding. Here is a larger

   177 example to put in your ~/.emacs; it will make the Blue Sea color theme

   178 the default used for the first frame, and it will create two additional

   179 frames with different color themes.

   180 

   181 setup:

   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 

   192 Please note that using XEmacs and and a nil value for

   193 color-theme-is-global will ignore any variable settings for the color

   194 theme, since XEmacs doesn't have frame-local variable bindings.

   195 

   196 Also note that using Emacs and a non-nil value for color-theme-is-global

   197 will install a new color theme for all frames.  Using XEmacs and a

   198 non-nil value for color-theme-is-global will install a new color theme

   199 only 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.

   205 If non-nil, installing a color theme will undo all settings made by

   206 previous 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).

   212 Note that there is at least one directory shipped with the official

   213 color-theme distribution where all contributed themes are located.

   214 This official selection can't be changed with that variable. 

   215 However, you still can decide to turn it on or off and thus,

   216 not 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

   225 on `color-theme-load-all-themes' value. 

   226 This allows a user to prune the default color-themes (which can take a while

   227 to 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

   233 as presented by `color-theme-libraries'. Else

   234 do 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.

   274 Two other values are acceptable: t means no limit, and

   275 nil 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'.

   283 This counts how many themes were installed, regardless

   284 of `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 <[email protected]>")

   323     (color-theme-aalto-light "Aalto Light" "Jari Aalto <[email protected]>")

   324     (color-theme-aliceblue "Alice Blue" "Girish Bharadwaj <[email protected]>")

   325     (color-theme-andreas "Andreas" "Andreas Busch <[email protected]>")

   326     (color-theme-arjen "Arjen" "Arjen Wiersma <[email protected]>")

   327     (color-theme-beige-diff "Beige Diff" "Alex Schroeder <[email protected]>" t)

   328     (color-theme-bharadwaj "Bharadwaj" "Girish Bharadwaj <[email protected]>")

   329     (color-theme-bharadwaj-slate "Bharadwaj Slate" "Girish Bharadwaj <[email protected]>")

   330     (color-theme-billw "Billw" "Bill White <[email protected]>")

   331     (color-theme-black-on-gray "BlackOnGray" "Sudhir Bhojwani <[email protected]>")

   332     (color-theme-blippblopp "Blipp Blopp" "Thomas Sicheritz-Ponten<[email protected]>")

   333     (color-theme-simple-1 "Black" "Jonadab <[email protected]>")

   334     (color-theme-blue-erc "Blue ERC" "Alex Schroeder <[email protected]>" t)

   335     (color-theme-blue-gnus "Blue Gnus" "Alex Schroeder <[email protected]>" t)

   336     (color-theme-blue-mood "Blue Mood" "Nelson Loyola <[email protected]>")

   337     (color-theme-blue-sea "Blue Sea" "Alex Schroeder <[email protected]>")

   338     (color-theme-calm-forest "Calm Forest" "Artur Hefczyc <[email protected]>")

   339     (color-theme-charcoal-black "Charcoal Black" "Lars Chr. Hausmann <[email protected]>")

   340     (color-theme-goldenrod "Cheap Goldenrod" "Alex Schroeder <[email protected]>")

   341     (color-theme-clarity "Clarity and Beauty" "Richard Wellum <[email protected]>")

   342     (color-theme-classic "Classic" "Frederic Giroud <[email protected]>")

   343     (color-theme-comidia "Comidia" "Marcelo Dias de Toledo <[email protected]>")

   344     (color-theme-jsc-dark "Cooper Dark" "John S Cooper <[email protected]>")

   345     (color-theme-jsc-light "Cooper Light" "John S Cooper <[email protected]>")

   346     (color-theme-jsc-light2 "Cooper Light 2" "John S Cooper <[email protected]>")

   347     (color-theme-dark-blue "Dark Blue" "Chris McMahan <[email protected]>")

   348     (color-theme-dark-blue2 "Dark Blue 2" "Chris McMahan <[email protected]>")

   349     (color-theme-dark-green "Dark Green" "[email protected]")

   350     (color-theme-dark-laptop "Dark Laptop" "Laurent Michel <[email protected]>")

   351     (color-theme-deep-blue "Deep Blue" "Tomas Cerha <[email protected]>")

   352     (color-theme-digital-ofs1 "Digital OFS1" "Gareth Owen <[email protected]>")

   353     (color-theme-euphoria "Euphoria" "[email protected]")

   354     (color-theme-feng-shui "Feng Shui" "Walter Higgins <[email protected]>")

   355     (color-theme-fischmeister "Fischmeister"

   356 			      "Sebastian Fischmeister <[email protected]>")

   357     (color-theme-gnome "Gnome" "Jonadab <[email protected]>")

   358     (color-theme-gnome2 "Gnome 2" "Alex Schroeder <[email protected]>")

   359     (color-theme-gray1 "Gray1" "Paul Pulli <[email protected]>")

   360     (color-theme-gray30 "Gray30" "Girish Bharadwaj <[email protected]>")

   361     (color-theme-kingsajz "Green Kingsajz" "Olgierd `Kingsajz' Ziolko <[email protected]>")

   362     (color-theme-greiner "Greiner" "Kevin Greiner <[email protected]>")

   363     (color-theme-gtk-ide "GTK IDE" "Gordon Messmer <[email protected]>")

   364     (color-theme-high-contrast "High Contrast" "Alex Schroeder <[email protected]>")

   365     (color-theme-hober "Hober" "Edward O'Connor <[email protected]>")

   366     (color-theme-infodoc "Infodoc" "Frederic Giroud <[email protected]>")

   367     (color-theme-jb-simple "JB Simple" "[email protected]")

   368     (color-theme-jedit-grey "Jedit Grey" "Gordon Messmer <[email protected]>")

   369     (color-theme-jonadabian "Jonadab" "Jonadab <[email protected]>")

   370     (color-theme-jonadabian-slate "Jonadabian Slate" "Jonadab <[email protected]>")

   371     (color-theme-katester "Katester" "[email protected]")

   372     (color-theme-late-night "Late Night" "Alex Schroeder <[email protected]>")

   373     (color-theme-lawrence "Lawrence" "lawrence mitchell <[email protected]>")

   374     (color-theme-lethe "Lethe" "Ivica Loncar <[email protected]>")

   375     (color-theme-ld-dark "Linh Dang Dark" "Linh Dang <[email protected]>")

   376     (color-theme-marine "Marine" "Girish Bharadwaj <[email protected]>")

   377     (color-theme-matrix "Matrix" "Walter Higgins <[email protected]>")

   378     (color-theme-marquardt "Marquardt" "Colin Marquardt <[email protected]>")

   379     (color-theme-midnight "Midnight" "Gordon Messmer <[email protected]>")

   380     (color-theme-mistyday "Misty Day" "Hari Kumar <[email protected]>")

   381     (color-theme-montz "Montz" "Brady Montz <[email protected]>")

   382     (color-theme-oswald "Oswald" "Tom Oswald <[email protected]>")

   383     (color-theme-parus "Parus" "Jon K Hellan <[email protected]>")

   384     (color-theme-pierson "Pierson" "Dan L. Pierson <[email protected]>")

   385     (color-theme-ramangalahy "Ramangalahy" "Solofo Ramangalahy <[email protected]>")

   386     (color-theme-raspopovic "Raspopovic" "Pedja Raspopovic <[email protected]>")

   387     (color-theme-renegade "Renegade" "Dave Benjamin <[email protected]>")

   388     (color-theme-resolve "Resolve" "Damien Elmes <[email protected]>")

   389     (color-theme-retro-green "Retro Green" "Alex Schroeder <[email protected]>")

   390     (color-theme-retro-orange "Retro Orange" "Alex Schroeder <[email protected]>")

   391     (color-theme-robin-hood "Robin Hood" "Alex Schroeder <[email protected]>")

   392     (color-theme-rotor "Rotor" "Jinwei Shen <[email protected]>")

   393     (color-theme-ryerson "Ryerson" "Luis Fernandes <[email protected]>")

   394     (color-theme-salmon-diff "Salmon Diff" "Alex Schroeder <[email protected]>" t)

   395     (color-theme-salmon-font-lock "Salmon Font-Lock" "Alex Schroeder <[email protected]>" t)

   396     (color-theme-scintilla "Scintilla" "Gordon Messmer <[email protected]>")

   397     (color-theme-shaman "Shaman" "[email protected]")

   398     (color-theme-sitaramv-nt "Sitaram NT"

   399 			     "Sitaram Venkatraman <[email protected]>")

   400     (color-theme-sitaramv-solaris "Sitaram Solaris"

   401 				  "Sitaram Venkatraman <[email protected]>")

   402     (color-theme-snow "Snow" "Nicolas Rist <[email protected]>")

   403     (color-theme-snowish "Snowish" "Girish Bharadwaj <[email protected]>")

   404     (color-theme-standard-ediff "Standard Ediff" "Emacs Team, added by Alex Schroeder <[email protected]>" t)

   405     (color-theme-standard "Standard Emacs 20" "Emacs Team, added by Alex Schroeder <[email protected]>")

   406     (color-theme-emacs-21 "Standard Emacs 21" "Emacs Team, added by Alex Schroeder <[email protected]>")

   407     (color-theme-emacs-nw "Standard Emacs 21 No Window" "Emacs Team, added by D. Goel <[email protected]>")

   408     (color-theme-xemacs "Standard XEmacs" "XEmacs Team, added by Alex Schroeder <[email protected]>")

   409     (color-theme-subtle-blue "Subtle Blue" "Chris McMahan <[email protected]>")

   410     (color-theme-subtle-hacker "Subtle Hacker" "Colin Walters <[email protected]>")

   411     (color-theme-taming-mr-arneson "Taming Mr Arneson" "Erik Arneson <[email protected]>")

   412     (color-theme-taylor "Taylor" "Art Taylor <[email protected]>")

   413     (color-theme-tty-dark "TTY Dark" "O Polite <[email protected]>")

   414     (color-theme-vim-colors "Vim Colors" "Michael Soulier <[email protected]>")

   415     (color-theme-whateveryouwant "Whateveryouwant" "Fabien Penso <[email protected]>, color by Scott Jaderholm <[email protected]>")

   416     (color-theme-wheat "Wheat" "Alex Schroeder <[email protected]>")

   417     (color-theme-pok-wob "White On Black" "S. Pokrovsky <[email protected]>")

   418     (color-theme-pok-wog "White On Grey" "S. Pokrovsky <[email protected]>")

   419     (color-theme-word-perfect "WordPerfect" "Thomas Gehrlein <[email protected]>")

   420     (color-theme-xp "XP" "Girish Bharadwaj <[email protected]>"))

   421   "List of color themes.

   422 

   423 Each THEME is itself a three element list (FUNC NAME MAINTAINER &optional LIBRARY).

   424 

   425 FUNC is a color theme function which does the setup.  The function

   426 FUNC may call `color-theme-install'.  The color theme function may be

   427 interactive.

   428 

   429 NAME is the name of the theme and MAINTAINER is the name and/or email of

   430 the maintainer of the theme.

   431 

   432 If LIBRARY is non-nil, the color theme will be considered a library and

   433 may not be shown in the default menu.

   434 

   435 If you defined your own color theme and want to add it to this list,

   436 use 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'.

   444 The values are stored in `color-theme-original-frame-alist' on

   445 startup."

   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.

   455 With optional prefix ARG, this buffer will include color theme libraries

   456 as well.  A color theme library is in itself not complete, it must be

   457 used as part of another color theme to be useful.  Thus, color theme

   458 libraries 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 

   505 Use \\[color-theme-install-at-point] to install a color theme on all frames.

   506 Use \\[color-theme-install-at-point-for-current-frame] to install a color theme for the current frame only.

   507 

   508 The changes are applied on top of your current setup.  This is a

   509 feature.

   510 

   511 Some of the themes should be considered extensions to the standard color

   512 theme: they modify only a limited number of faces and variables.  To

   513 verify the final look of a color theme, install the standard color

   514 theme, then install the other color theme.  This is a feature. It allows

   515 you to mix several color themes.

   516 

   517 Use \\[color-theme-describe] to read more about the color theme function at point.

   518 If you want to install the color theme permanently, put the call to the

   519 color theme function into your ~/.emacs:

   520 

   521     \(require 'color-theme)

   522     \(color-theme-gnome2)

   523 

   524 If 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

   526 as ~/.emacs-color-theme.  Now you can install only this specific color

   527 theme in your .emacs:

   528 

   529     \(load-file \"~/.emacs-color-theme\")

   530     \(my-color-theme)

   531 

   532 The Emacs menu is not affected by color themes within Emacs.  Depending

   533 on the toolkit you used to compile Emacs, you might have to set specific

   534 X ressources.  See the info manual for more information.  Here is an

   535 example ~/.Xdefaults fragment:

   536 

   537     emacs*Background: DarkSlateGray

   538     emacs*Foreground: wheat

   539 

   540 \\{color-theme-mode-map}

   541 

   542 The 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.

   556 This shows the documentation of the value of text-property color-theme

   557 at point.  The text-property color-theme should be a color theme

   558 function.  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.

   565 First 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.

   575 This calls the value of the text-property `color-theme' at point.

   576 The text-property `color-theme' should be a color theme function.

   577 See `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.

   596 Binds `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.

   608 The resulting list will be newly allocated and contains only elements

   609 with names matching REGEXP.  OLD-LIST may be a list or an alist.  If you

   610 want to filter a plist, use `color-theme-alist' to convert your plist to

   611 an alist, first.

   612 

   613 If the optional argument EXCLUDE is non-nil, then the sense is

   614 reversed: 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.

   637 This makes sure that SPEC has the form ((t (PLIST ...))).

   638 Only properties not in `color-theme-illegal-default-attributes'

   639 are 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.

   655 This 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.

   684 Example: Eventhough :bold works in Emacs, it is not recognized by

   685 `customize-face' -- and then the face is uncustomizable.  This

   686 function replaces a :bold attribute with the corresponding :weight

   687 attribute, if there is no :weight, or deletes it.  This undoes the

   688 doings 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.

   728 OLD 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.

   808 If ATTS contains :inverse-video t, remove it and swap foreground and

   809 background 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).

   838 See `defface' for the format of SPEC.  In this case we use only one

   839 DISPLAY, t, and determine ATTS using `color-theme-face-attr-construct'.

   840 If ATTS is nil, (nil) is used  instead.

   841 

   842 If ATTS contains :inverse-video t, we remove it and swap foreground and

   843 background color using `color-theme-spec-maybe-invert'.  We do this

   844 because :inverse-video is handled differently in Emacs and XEmacs.  We

   845 will 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.

   858 Such an alist may be installed by `color-theme-install-frame-params'.  The

   859 frame 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.

   867 Such an alist may be installed by `color-theme-install-variables'.

   868 The variable names must match `color-theme-legal-variables', and the

   869 variable 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.

   892 Such an alist may be installed by `color-theme-install-faces'.  The

   893 faces 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.

   931 FUNC is the function name, DOC the doc string, PARAMS the

   932 frame parameters, VARS the variable bindings, and FACES

   933 the 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 

   954 You can contribute this function to <URL:news:gnu.emacs.sources> or

   955 paste it into your .emacs file and call it.  That should recreate all

   956 the settings necessary for your color theme.

   957 

   958 Example:

   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 

   970 If you want to use a specific color theme function, you can call the

   971 color theme function in your .emacs directly.

   972 

   973 Example:

   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.

  1030 If 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.