/vendor/color-theme/color-theme.el
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