annotate lisp/cus-theme.el @ 57856:df80d19d7a2e

Revision: [e-mail]--gnu-2004/emacs--cvs-trunk--0--patch-660 Merge from gnus--rel--5.10 Patches applied: * [e-mail]--gnu-2004/gnus--rel--5.10--patch-65 Update from CVS 2004-11-01 Reiner Steib <[e-mail]> * lisp/gnus/gnus-msg.el (gnus-summary-resend-default-address): Add :version. * lisp/gnus/tls.el (tls-process-connection-type, tls-success) (tls-certtool-program): Add :version. * lisp/gnus/starttls.el (starttls-gnutls-program, starttls-use-gnutls) (starttls-extra-arguments, starttls-process-connection-type) (starttls-connect, starttls-failure, starttls-success): * lisp/gnus/spam-stat.el (spam-stat): Add :version. * lisp/gnus/sieve.el (sieve): Add :version. * lisp/gnus/sha1.el (sha1): Added :version. (sha1-use-external): Removed redundant version. * lisp/gnus/nnmail.el (nnmail-split-fancy-with-parent-ignore-groups) (nnmail-cache-ignore-groups, nnmail-spool-hook) (nnmail-split-fancy-match-partial-words) (nnmail-split-lowercase-expanded): * lisp/gnus/nndiary.el (nndiary): Add :version. * lisp/gnus/mml2015.el (mml2015-unabbrev-trust-alist): Add :version. * lisp/gnus/mml-sec.el (mml-default-sign-method) (mml-default-encrypt-method, mml-signencrypt-style-alist): Add :version. * lisp/gnus/mm-uu.el (mm-uu-diff-groups-regexp): Add :version. * lisp/gnus/mm-url.el (mm-url-use-external, mm-url-program) (mm-url-arguments): Add :version. * lisp/gnus/mm-decode.el (mm-inline-text-html-with-w3m-keymap) (mm-attachment-file-modes, mm-decrypt-option) (mm-w3m-safe-url-regexp): Add :version. * lisp/gnus/message.el (message-cite-prefix-regexp) (message-sendmail-envelope-from, message-minibuffer-local-map) (message-user-fqdn, message-completion-alist): Add :version. * lisp/gnus/gnus-win.el (gnus-configure-windows-hook) (gnus-use-frames-on-any-display): Add :version. * lisp/gnus/gnus-art.el (gnus-article-address-banner-alist) (gnus-treat-unsplit-urls, gnus-treat-unfold-headers) (gnus-treat-from-picon, gnus-treat-mail-picon) (gnus-treat-x-pgp-sig): Add :version. * lisp/gnus/gnus-sum.el (gnus-spam-mark, gnus-recent-mark) (gnus-undownloaded-mark, gnus-summary-article-move-hook) (gnus-summary-article-delete-hook) (gnus-summary-display-while-building): Add :version. * lisp/gnus/gnus-start.el (gnus-subscribe-newsgroup-hooks) (gnus-get-top-new-news-hook):Add :version. * lisp/gnus/gnus-srvr.el (gnus-server-agent-face, gnus-server-opened-face) (gnus-server-closed-face, gnus-server-denied-face): Add :version. * lisp/gnus/gnus-registry.el (gnus-registry): Add :version. * lisp/gnus/gnus-spec.el (gnus-use-correct-string-widths) (gnus-make-format-preserve-properties): Add :version. * lisp/gnus/gnus.el (gnus-group-charter-alist) (gnus-group-fetch-control-use-browse-url) (gnus-install-group-spam-parameters): Add :version. * lisp/gnus/gnus-diary.el (gnus-diary): Add :version. * lisp/gnus/gnus-delay.el (gnus-delay): Add :version. * lisp/gnus/gnus-cite.el (gnus-cite-unsightly-citation-regexp) (gnus-cite-ignore-quoted-from, gnus-cite-attribution-face) (gnus-cite-blank-line-after-header, gnus-article-boring-faces): Add :version. * lisp/gnus/gnus-agent.el (gnus-agent-max-fetch-size) (gnus-agent-enable-expiration, gnus-agent-queue-mail) (gnus-agent-prompt-send-queue): Add :version. * lisp/gnus/deuglify.el (gnus-outlook-deuglify): Add :version. * lisp/gnus/html2text.el: Beautify code. Improve doc strings. Some checkdoc cleanup. (html2text-get-attr, html2text-fix-paragraph): Simplify code. (html2text-format-tag-list): Added "strong" and "em". From "Alfred M. Szmidt" <[e-mail]> (tiny change).

;;; cus-theme.el -- custom theme creation user interface
;;
;; Copyright (C) 2001 Free Software Foundation, Inc.
;;
;; Author: Alex Schroeder <[e-mail]>
;; Maintainer: FSF
;; Keywords: help, faces

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(require 'widget)
(require 'cus-edit)

(eval-when-compile
  (require 'wid-edit))

;;;###autoload
(defun customize-create-theme ()
  "Create a custom theme."
  (interactive)
  (if (get-buffer "*New Custom Theme*")
      (kill-buffer "*New Custom Theme*"))
  (switch-to-buffer "*New Custom Theme*")
  (kill-all-local-variables)
  (make-local-variable 'custom-theme-name)
  (make-local-variable 'custom-theme-variables)
  (make-local-variable 'custom-theme-faces)
  (make-local-variable 'custom-theme-description)
  (let ((inhibit-read-only t))
    (erase-buffer))
  (widget-insert "This buffer helps you write a custom theme elisp file.
This will help you share your customizations with other people.\n\n")
  (widget-insert "Theme name: ")
  (setq custom-theme-name
	(widget-create 'editable-field
		       :size 10
		       user-login-name))
  (widget-insert "\n\nDocumentation:\n")
  (setq custom-theme-description
	(widget-create 'text
		       :value (format-time-string "Created %Y-%m-%d.")))
  (widget-insert "\nVariables:\n\n")
  (setq custom-theme-variables
     	(widget-create 'editable-list
     		       :entry-format "%i %d %v"
		       'variable))
  (widget-insert "\nFaces:\n\n")
  (setq custom-theme-faces
     	(widget-create 'editable-list
     		       :entry-format "%i %d %v"
		       'face))
  (widget-insert "\n")
  (widget-create 'push-button
     		 :notify (function custom-theme-write)
     		 "Done")
  (widget-insert " ")
  (widget-create 'push-button
     		 :notify (lambda (&rest ignore)
     			   (customize-create-theme))
     		 "Reset")
  (widget-insert " ")
  (widget-create 'push-button
     		 :notify (lambda (&rest ignore)
     			   (bury-buffer))
     		 "Bury Buffer")
  (widget-insert "\n")
  (use-local-map widget-keymap)
  (widget-setup))

(defun custom-theme-write (&rest ignore)
  (let ((name (widget-value custom-theme-name))
	(doc (widget-value custom-theme-description))
	(variables (widget-value custom-theme-variables))
	(faces (widget-value custom-theme-faces)))
    (switch-to-buffer (concat name "-theme.el"))
    (setq buffer-file-name (expand-file-name (concat name "-theme.el")))
    (let ((inhibit-read-only t))
      (erase-buffer))
    (insert "(deftheme " name)
    (when doc
      (newline)
      (insert "  \"" doc "\""))
    (insert  ")\n")
    (custom-theme-write-variables name variables)
    (custom-theme-write-faces name faces)
    (insert "\n(provide-theme '" name ")\n")))

(defun custom-theme-write-variables (theme vars)
  "Write a `custom-theme-set-variables' command for THEME.
It includes all variables in list VARS."
  ;; Most code is stolen from `custom-save-variables'.
  (when vars
    (let ((standard-output (current-buffer)))
      (princ "\n(custom-theme-set-variables\n")
      (princ " '")
      (princ theme)
      (princ "\n")
      (mapc (lambda (symbol)
	      (when (boundp symbol)
		(unless (bolp)
		  (princ "\n"))
		(princ " '(")
		(prin1 symbol)
		(princ " ")
		(prin1 (symbol-value symbol))
		(princ ")")))
	      vars)
      (if (bolp)
	  (princ " "))
      (princ ")")
      (unless (looking-at "\n")
	(princ "\n")))))

(defun custom-theme-write-faces (theme faces)
  "Write a `custom-theme-set-faces' command for THEME.
It includes all faces in list FACES."
  (when faces
    (let ((standard-output (current-buffer)))
      (princ "\n(custom-theme-set-faces\n")
      (princ " '")
      (princ theme)
      (princ "\n")
      (mapc (lambda (symbol)
	      (when (facep symbol)
		(unless (bolp)
		  (princ "\n"))
		(princ " '(")
		(prin1 symbol)
		(princ " ")
		(prin1 (or (get symbol 'customized-face)
			   (get symbol 'face-defface-spec)))
		(princ ")")))
	      faces)
      (if (bolp)
	  (princ " "))
      (princ ")")
      (unless (looking-at "\n")
	(princ "\n")))))

;;; arch-tag: cd6919bc-63af-410e-bae2-b6702e762344
;;; cus-theme.el ends here