PageRenderTime 59ms CodeModel.GetById 19ms RepoModel.GetById 1ms app.codeStats 0ms

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

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