Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 219:262b8bb4a523 r20-4b8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b8
author cvs
date Mon, 13 Aug 2007 10:09:35 +0200
parents 78f53ef88e17
children 6c0ae1f9357f
comparison
equal deleted inserted replaced
218:c9f226976f56 219:262b8bb4a523
32 32
33 ;;; Code: 33 ;;; Code:
34 34
35 (require 'widget) 35 (require 'widget)
36 36
37 (autoload 'pp-to-string "pp")
38 (autoload 'finder-commentary "finder" nil t) 37 (autoload 'finder-commentary "finder" nil t)
39 38
40 ;;; Customization. 39 ;;; Customization.
41 40
42 (defgroup widgets nil 41 (defgroup widgets nil
150 ;; No quoting characters are used; no delimiters are printed around 149 ;; No quoting characters are used; no delimiters are printed around
151 ;; the contents of strings. 150 ;; the contents of strings.
152 (with-current-buffer (get-buffer-create " *widget-tmp*") 151 (with-current-buffer (get-buffer-create " *widget-tmp*")
153 (erase-buffer) 152 (erase-buffer)
154 (princ object (current-buffer)) 153 (princ object (current-buffer))
154 (buffer-string)))
155
156 (defun widget-prettyprint-to-string (object)
157 ;; Like pp-to-string, but uses `cl-prettyprint'
158 ;; #### FIX ME!!!!
159 (with-current-buffer (get-buffer-create " *widget-tmp*")
160 (erase-buffer)
161 (cl-prettyprint object)
155 (buffer-string))) 162 (buffer-string)))
156 163
157 (defun widget-clear-undo () 164 (defun widget-clear-undo ()
158 "Clear all undo information." 165 "Clear all undo information."
159 (buffer-disable-undo) 166 (buffer-disable-undo)
630 :type '(repeat (cons :format "%v" 637 :type '(repeat (cons :format "%v"
631 (symbol :tag "Image Format" unknown) 638 (symbol :tag "Image Format" unknown)
632 (repeat :tag "Suffixes" 639 (repeat :tag "Suffixes"
633 (string :format "%v"))))) 640 (string :format "%v")))))
634 641
635 (defvar widget-glyph-pointer-glyph 642 ;; Don't use this, because we cannot yet distinguish between widget
636 (make-pointer-glyph [cursor-font :data "hand2"]) 643 ;; glyphs associated with user action, and actionless ones.
637 "Glyph to be used as the mouse pointer shape over glyphs. 644 ;(defvar widget-glyph-pointer-glyph
638 Use `set-glyph-image' to change this.") 645 ; (make-pointer-glyph [cursor-font :data "hand2"])
646 ; "Glyph to be used as the mouse pointer shape over glyphs.
647 ;Use `set-glyph-image' to change this.")
639 648
640 (defvar widget-glyph-cache nil 649 (defvar widget-glyph-cache nil
641 "Cache of glyphs associated with strings (files).") 650 "Cache of glyphs associated with strings (files).")
642 651
643 (defun widget-glyph-find (image tag) 652 (defun widget-glyph-find (image tag)
743 ;; currently a mess, so I'd rather not use it. 752 ;; currently a mess, so I'd rather not use it.
744 (set-extent-property extent 'invisible t) 753 (set-extent-property extent 'invisible t)
745 (set-extent-property extent 'start-open t) 754 (set-extent-property extent 'start-open t)
746 (set-extent-property extent 'end-open t) 755 (set-extent-property extent 'end-open t)
747 (set-extent-property extent 'keymap map) 756 (set-extent-property extent 'keymap map)
748 (set-extent-property extent 'pointer widget-glyph-pointer-glyph) 757 ;;(set-extent-property extent 'pointer widget-glyph-pointer-glyph)
749 (set-extent-end-glyph extent glyph) 758 (set-extent-end-glyph extent glyph)
750 (unless (or (stringp help-echo) (null help-echo)) 759 (unless (or (stringp help-echo) (null help-echo))
751 (setq help-echo 'widget-mouse-help)) 760 (setq help-echo 'widget-mouse-help))
752 (when help-echo 761 (when help-echo
753 (set-extent-property extent 'balloon-help help-echo) 762 (set-extent-property extent 'balloon-help help-echo)
1949 (defun widget-url-link-help-echo (widget) 1958 (defun widget-url-link-help-echo (widget)
1950 (concat "Visit <URL:" (widget-value widget) ">")) 1959 (concat "Visit <URL:" (widget-value widget) ">"))
1951 1960
1952 (defun widget-url-link-action (widget &optional event) 1961 (defun widget-url-link-action (widget &optional event)
1953 "Open the url specified by WIDGET." 1962 "Open the url specified by WIDGET."
1954 (require 'browse-url) 1963 (if (boundp 'browse-url-browser-function)
1955 (funcall browse-url-browser-function (widget-value widget))) 1964 (funcall browse-url-browser-function (widget-value widget))
1965 (error "Cannot follow URLs in this XEmacs")))
1956 1966
1957 ;;; The `function-link' Widget. 1967 ;;; The `function-link' Widget.
1958 1968
1959 (define-widget 'function-link 'link 1969 (define-widget 'function-link 'link
1960 "A link to an Emacs function." 1970 "A link to an Emacs function."
3341 :value-to-external (lambda (widget value) (read value)) 3351 :value-to-external (lambda (widget value) (read value))
3342 :prompt-history 'widget-sexp-prompt-value-history 3352 :prompt-history 'widget-sexp-prompt-value-history
3343 :prompt-value 'widget-sexp-prompt-value) 3353 :prompt-value 'widget-sexp-prompt-value)
3344 3354
3345 (defun widget-sexp-value-to-internal (widget value) 3355 (defun widget-sexp-value-to-internal (widget value)
3346 ;; Use pp for printer representation. 3356 ;; Use cl-prettyprint for printer representation.
3347 (let ((pp (if (symbolp value) 3357 (let ((pp (if (symbolp value)
3348 (prin1-to-string value) 3358 (prin1-to-string value)
3349 (pp-to-string value)))) 3359 (widget-prettyprint-to-string value))))
3350 (while (string-match "\n\\'" pp) 3360 (while (string-match "\n\\'" pp)
3351 (setq pp (substring pp 0 -1))) 3361 (setq pp (substring pp 0 -1)))
3352 (if (or (string-match "\n\\'" pp) 3362 (if (and (> (length pp) 40)
3353 (> (length pp) 40)) 3363 (not (string-match "\\`\n" pp)))
3354 (concat "\n" pp) 3364 (concat "\n" pp)
3355 pp))) 3365 pp)))
3356 3366
3357 (defun widget-sexp-validate (widget) 3367 (defun widget-sexp-validate (widget)
3358 ;; Valid if we can read the string and there is no junk left after it. 3368 ;; Valid if we can read the string and there is no junk left after it.