Commit bd042c03 authored by Per Abrahamsen's avatar Per Abrahamsen

Sync with 1.84.

parent c5292bc8
This diff is collapsed.
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
;; ;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces ;; Keywords: help, faces
;; Version: 1.71 ;; Version: 1.84
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary: ;;; Commentary:
...@@ -39,7 +39,7 @@ ...@@ -39,7 +39,7 @@
(eval-and-compile (eval-and-compile
(unless (fboundp 'frame-property) (unless (fboundp 'frame-property)
;; XEmacs function missing in Emacs 19.34. ;; XEmacs function missing in Emacs.
(defun frame-property (frame property &optional default) (defun frame-property (frame property &optional default)
"Return FRAME's value for property PROPERTY." "Return FRAME's value for property PROPERTY."
(or (cdr (assq property (frame-parameters frame))) (or (cdr (assq property (frame-parameters frame)))
...@@ -49,44 +49,13 @@ ...@@ -49,44 +49,13 @@
;; XEmacs function missing in Emacs. ;; XEmacs function missing in Emacs.
(defun face-doc-string (face) (defun face-doc-string (face)
"Get the documentation string for FACE." "Get the documentation string for FACE."
(get face 'face-doc-string))) (get face 'face-documentation)))
(unless (fboundp 'set-face-doc-string) (unless (fboundp 'set-face-doc-string)
;; XEmacs function missing in Emacs. ;; XEmacs function missing in Emacs.
(defun set-face-doc-string (face string) (defun set-face-doc-string (face string)
"Set the documentation string for FACE to STRING." "Set the documentation string for FACE to STRING."
(put face 'face-doc-string string))) (put face 'face-documentation string))))
(when (and (not (fboundp 'set-face-stipple))
(fboundp 'set-face-background-pixmap))
;; Emacs function missing in XEmacs 19.15.
(defun set-face-stipple (face pixmap &optional frame)
;; Written by Kyle Jones.
"Change the stipple pixmap of face FACE to PIXMAP.
PIXMAP should be a string, the name of a file of pixmap data.
The directories listed in the `x-bitmap-file-path' variable are searched.
Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT DATA)
where WIDTH and HEIGHT are the size in pixels,
and DATA is a string, containing the raw bits of the bitmap.
If the optional FRAME argument is provided, change only
in that frame; otherwise change each frame."
(while (not (find-face face))
(setq face (signal 'wrong-type-argument (list 'facep face))))
(while (cond ((stringp pixmap)
(unless (file-readable-p pixmap)
(setq pixmap (vector 'xbm ':file pixmap)))
nil)
((and (consp pixmap) (= (length pixmap) 3))
(setq pixmap (vector 'xbm ':data pixmap))
nil)
(t t))
(setq pixmap (signal 'wrong-type-argument
(list 'stipple-pixmap-p pixmap))))
(while (and frame (not (framep frame)))
(setq frame (signal 'wrong-type-argument (list 'framep frame))))
(set-face-background-pixmap face pixmap frame))))
(unless (fboundp 'x-color-values) (unless (fboundp 'x-color-values)
;; Emacs function missing in XEmacs 19.14. ;; Emacs function missing in XEmacs 19.14.
...@@ -410,7 +379,7 @@ If FRAME is nil, use the default face." ...@@ -410,7 +379,7 @@ If FRAME is nil, use the default face."
"Return the size of the font of FACE as a string." "Return the size of the font of FACE as a string."
(let* ((font (apply 'custom-face-font-name face args)) (let* ((font (apply 'custom-face-font-name face args))
(fontobj (font-create-object font))) (fontobj (font-create-object font)))
(format "%d" (font-size fontobj)))) (format "%s" (font-size fontobj))))
(defun custom-set-face-font-family (face family &rest args) (defun custom-set-face-font-family (face family &rest args)
"Set the font of FACE to FAMILY." "Set the font of FACE to FAMILY."
...@@ -425,17 +394,23 @@ If FRAME is nil, use the default face." ...@@ -425,17 +394,23 @@ If FRAME is nil, use the default face."
(fontobj (font-create-object font))) (fontobj (font-create-object font)))
(font-family fontobj))) (font-family fontobj)))
(nconc custom-face-attributes (setq custom-face-attributes
'((:family (editable-field :format "Font Family: %v" (append '((:family (editable-field :format "Font Family: %v"
:help-echo "\ :help-echo "\
Name of font family to use (e.g. times).") Name of font family to use (e.g. times).")
custom-set-face-font-family custom-set-face-font-family
custom-face-font-family) custom-face-font-family)
(:size (editable-field :format "Size: %v" (:size (editable-field :format "Size: %v"
:help-echo "\ :help-echo "\
Text size (e.g. 9pt or 2mm).") Text size (e.g. 9pt or 2mm).")
custom-set-face-font-size custom-set-face-font-size
custom-face-font-size)))) custom-face-font-size)
(:strikethru (toggle :format "Strikethru: %[%v%]\n"
:help-echo "\
Control whether the text should be strikethru.")
set-face-strikethru-p
face-strikethru-p))
custom-face-attributes)))
;;; Frames. ;;; Frames.
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
;; ;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces ;; Keywords: help, faces
;; Version: 1.71 ;; Version: 1.84
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary: ;;; Commentary:
...@@ -23,16 +23,26 @@ ...@@ -23,16 +23,26 @@
(define-widget-keywords :prefix :tag :load :link :options :type :group) (define-widget-keywords :prefix :tag :load :link :options :type :group)
(defvar custom-define-hook nil
;; Customize information for this option is in `cus-edit.el'.
"Hook called after defining each customize option.")
;;; The `defcustom' Macro. ;;; The `defcustom' Macro.
(defun custom-declare-variable (symbol value doc &rest args) (defun custom-declare-variable (symbol value doc &rest args)
"Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments."
(unless (and (default-boundp symbol) ;; Bind this variable unless it already is bound.
(not (get symbol 'saved-value))) (unless (default-boundp symbol)
;; Use the saved value if it exists, otherwise the factory setting.
(set-default symbol (if (get symbol 'saved-value) (set-default symbol (if (get symbol 'saved-value)
(eval (car (get symbol 'saved-value))) (eval (car (get symbol 'saved-value)))
(eval value)))) (eval value))))
;; Remember the factory setting.
(put symbol 'factory-value (list value)) (put symbol 'factory-value (list value))
;; Maybe this option was rogue in an earlier version. It no longer is.
(when (get symbol 'force-value)
;; It no longer is.
(put symbol 'force-value nil))
(when doc (when doc
(put symbol 'variable-documentation doc)) (put symbol 'variable-documentation doc))
(while args (while args
...@@ -262,23 +272,23 @@ the default value for the SYMBOL." ...@@ -262,23 +272,23 @@ the default value for the SYMBOL."
(value (nth 1 entry)) (value (nth 1 entry))
(now (nth 2 entry))) (now (nth 2 entry)))
(put symbol 'saved-value (list value)) (put symbol 'saved-value (list value))
(when now (cond (now
(put symbol 'force-value t) ;; Rogue variable, set it now.
(set-default symbol (eval value))) (put symbol 'force-value t)
(set-default symbol (eval value)))
((default-boundp symbol)
;; Something already set this, overwrite it.
(set-default symbol (eval value))))
(setq args (cdr args))) (setq args (cdr args)))
;; Old format, a plist of SYMBOL VALUE pairs. ;; Old format, a plist of SYMBOL VALUE pairs.
(message "Warning: old format `custom-set-variables'")
(ding)
(sit-for 2)
(let ((symbol (nth 0 args)) (let ((symbol (nth 0 args))
(value (nth 1 args))) (value (nth 1 args)))
(put symbol 'saved-value (list value))) (put symbol 'saved-value (list value)))
(setq args (cdr (cdr args))))))) (setq args (cdr (cdr args)))))))
;;; Meta Customization
(defcustom custom-define-hook nil
"Hook called after defining each customize option."
:group 'customize
:type 'hook)
;;; The End. ;;; The End.
(provide 'custom) (provide 'custom)
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
;; ;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions ;; Keywords: extensions
;; Version: 1.71 ;; Version: 1.84
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary: ;;; Commentary:
...@@ -29,7 +29,13 @@ ...@@ -29,7 +29,13 @@
(unless widget-browse-mode-map (unless widget-browse-mode-map
(setq widget-browse-mode-map (make-sparse-keymap)) (setq widget-browse-mode-map (make-sparse-keymap))
(set-keymap-parent widget-browse-mode-map widget-keymap)) (set-keymap-parent widget-browse-mode-map widget-keymap)
(define-key widget-browse-mode-map "q" 'bury-buffer))
(easy-menu-define widget-browse-mode-customize-menu
widget-browse-mode-map
"Menu used in widget browser buffers."
(customize-menu-create 'widgets))
(easy-menu-define widget-browse-mode-menu (easy-menu-define widget-browse-mode-menu
widget-browse-mode-map widget-browse-mode-map
...@@ -59,6 +65,7 @@ if that value is non-nil." ...@@ -59,6 +65,7 @@ if that value is non-nil."
(setq major-mode 'widget-browse-mode (setq major-mode 'widget-browse-mode
mode-name "Widget") mode-name "Widget")
(use-local-map widget-browse-mode-map) (use-local-map widget-browse-mode-map)
(easy-menu-add widget-browse-mode-customize-menu)
(easy-menu-add widget-browse-mode-menu) (easy-menu-add widget-browse-mode-menu)
(run-hooks 'widget-browse-mode-hook)) (run-hooks 'widget-browse-mode-hook))
...@@ -82,6 +89,7 @@ if that value is non-nil." ...@@ -82,6 +89,7 @@ if that value is non-nil."
(defvar widget-browse-history nil) (defvar widget-browse-history nil)
;;;###autoload
(defun widget-browse (widget) (defun widget-browse (widget)
"Create a widget browser for WIDGET." "Create a widget browser for WIDGET."
(interactive (list (completing-read "Widget: " (interactive (list (completing-read "Widget: "
...@@ -106,11 +114,11 @@ if that value is non-nil." ...@@ -106,11 +114,11 @@ if that value is non-nil."
(widget-browse-mode) (widget-browse-mode)
;; Quick way to get out. ;; Quick way to get out.
(widget-create 'push-button ;; (widget-create 'push-button
:action (lambda (widget &optional event) ;; :action (lambda (widget &optional event)
(bury-buffer)) ;; (bury-buffer))
"Quit") ;; "Quit")
(widget-insert "\n") ;; (widget-insert "\n")
;; Top text indicating whether it is a class or object browser. ;; Top text indicating whether it is a class or object browser.
(if (listp widget) (if (listp widget)
...@@ -145,6 +153,18 @@ if that value is non-nil." ...@@ -145,6 +153,18 @@ if that value is non-nil."
(widget-setup) (widget-setup)
(goto-char (point-min))) (goto-char (point-min)))
;;;###autoload
(defun widget-browse-other-window (&optional widget)
"Show widget browser for WIDGET in other window."
(interactive)
(let ((window (selected-window)))
(switch-to-buffer-other-window "*Browse Widget*")
(if widget
(widget-browse widget)
(call-interactively 'widget-browse))
(select-window window)))
;;; The `widget-browse' Widget. ;;; The `widget-browse' Widget.
(define-widget 'widget-browse 'push-button (define-widget 'widget-browse 'push-button
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
;; ;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions ;; Keywords: extensions
;; Version: 1.71 ;; Version: 1.84
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary: ;;; Commentary:
...@@ -1238,13 +1238,14 @@ With optional ARG, move across that many fields." ...@@ -1238,13 +1238,14 @@ With optional ARG, move across that many fields."
(define-widget 'push-button 'item (define-widget 'push-button 'item
"A pushable button." "A pushable button."
:value-create 'widget-push-button-value-create :value-create 'widget-push-button-value-create
:text-format "[%s]"
:format "%[%v%]") :format "%[%v%]")
(defun widget-push-button-value-create (widget) (defun widget-push-button-value-create (widget)
;; Insert text representing the `on' and `off' states. ;; Insert text representing the `on' and `off' states.
(let* ((tag (or (widget-get widget :tag) (let* ((tag (or (widget-get widget :tag)
(widget-get widget :value))) (widget-get widget :value)))
(text (concat "[" tag "]")) (text (format (widget-get widget :text-format) tag))
(gui (cdr (assoc tag widget-push-button-cache)))) (gui (cdr (assoc tag widget-push-button-cache))))
(if (and (fboundp 'make-gui-button) (if (and (fboundp 'make-gui-button)
(fboundp 'make-glyph) (fboundp 'make-glyph)
...@@ -2374,7 +2375,7 @@ It will read a directory name from the minibuffer when activated." ...@@ -2374,7 +2375,7 @@ It will read a directory name from the minibuffer when activated."
(defun widget-vector-match (widget value) (defun widget-vector-match (widget value)
(and (vectorp value) (and (vectorp value)
(widget-group-match widget (widget-group-match widget
(widget-apply :value-to-internal widget value)))) (widget-apply widget :value-to-internal value))))
(define-widget 'cons 'group (define-widget 'cons 'group
"A cons-cell." "A cons-cell."
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
;; ;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, extensions, faces, hypermedia ;; Keywords: help, extensions, faces, hypermedia
;; Version: 1.71 ;; Version: 1.84
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary: ;;; Commentary:
...@@ -27,8 +27,8 @@ ...@@ -27,8 +27,8 @@
(set (car keywords) (car keywords))) (set (car keywords) (car keywords)))
(setq keywords (cdr keywords))))))) (setq keywords (cdr keywords)))))))
(define-widget-keywords :deactivate :active :inactive :activate (define-widget-keywords :text-format :deactivate :active :inactive
:sibling-args :delete-button-args :activate :sibling-args :delete-button-args
:insert-button-args :append-button-args :button-args :insert-button-args :append-button-args :button-args
:tag-glyph :off-glyph :on-glyph :valid-regexp :tag-glyph :off-glyph :on-glyph :valid-regexp
:secret :sample-face :sample-face-get :case-fold :widget-doc :secret :sample-face :sample-face-get :case-fold :widget-doc
...@@ -50,6 +50,7 @@ ...@@ -50,6 +50,7 @@
(autoload 'widget-create "wid-edit") (autoload 'widget-create "wid-edit")
(autoload 'widget-insert "wid-edit") (autoload 'widget-insert "wid-edit")
(autoload 'widget-browse "wid-browse" nil t) (autoload 'widget-browse "wid-browse" nil t)
(autoload 'widget-browse-other-window "wid-browse" nil t)
(autoload 'widget-browse-at "wid-browse" nil t)) (autoload 'widget-browse-at "wid-browse" nil t))
(defun define-widget (name class doc &rest args) (defun define-widget (name class doc &rest args)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment