Mercurial > emacs
comparison lisp/wid-edit.el @ 18067:0e2aa3b58e16
Synched with version 1.9901.
author | Per Abrahamsen <abraham@dina.kvl.dk> |
---|---|
date | Sat, 31 May 1997 06:34:12 +0000 |
parents | f8591273bf79 |
children | 05c70aa62552 |
comparison
equal
deleted
inserted
replaced
18066:eecd891e2b63 | 18067:0e2aa3b58e16 |
---|---|
2 ;; | 2 ;; |
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. | 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. |
4 ;; | 4 ;; |
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
6 ;; Keywords: extensions | 6 ;; Keywords: extensions |
7 ;; Version: 1.9900 | 7 ;; Version: 1.9901 |
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ |
9 | 9 |
10 ;; This file is part of GNU Emacs. | 10 ;; This file is part of GNU Emacs. |
11 | 11 |
12 ;; GNU Emacs is free software; you can redistribute it and/or modify | 12 ;; GNU Emacs is free software; you can redistribute it and/or modify |
29 ;; See `widget.el'. | 29 ;; See `widget.el'. |
30 | 30 |
31 ;;; Code: | 31 ;;; Code: |
32 | 32 |
33 (require 'widget) | 33 (require 'widget) |
34 (eval-when-compile (require 'cl)) | |
34 | 35 |
35 ;;; Compatibility. | 36 ;;; Compatibility. |
36 | 37 |
37 (eval-and-compile | 38 (eval-and-compile |
38 (autoload 'pp-to-string "pp") | 39 (autoload 'pp-to-string "pp") |
565 :type '(repeat (cons :format "%v" | 566 :type '(repeat (cons :format "%v" |
566 (symbol :tag "Image Format" unknown) | 567 (symbol :tag "Image Format" unknown) |
567 (repeat :tag "Suffixes" | 568 (repeat :tag "Suffixes" |
568 (string :format "%v"))))) | 569 (string :format "%v"))))) |
569 | 570 |
570 (defun widget-glyph-insert (widget tag image) | 571 (defun widget-glyph-find (image tag) |
571 "In WIDGET, insert the text TAG or, if supported, IMAGE. | 572 "Create a glyph corresponding to IMAGE with string TAG as fallback. |
572 IMAGE should either be a glyph, an image instantiator, or an image file | 573 IMAGE should either already be a glyph, or be a file name sans |
573 name sans extension (xpm, xbm, gif, jpg, or png) located in | 574 extension (xpm, xbm, gif, jpg, or png) located in |
574 `widget-glyph-directory'. | 575 `widget-glyph-directory'." |
575 | 576 (cond ((not (and image |
576 WARNING: If you call this with a glyph, and you want the user to be | 577 (string-match "XEmacs" emacs-version) |
577 able to invoke the glyph, make sure it is unique. If you use the | |
578 same glyph for multiple widgets, invoking any of the glyphs will | |
579 cause the last created widget to be invoked." | |
580 (cond ((not (and (string-match "XEmacs" emacs-version) | |
581 widget-glyph-enable | 578 widget-glyph-enable |
582 (fboundp 'make-glyph) | 579 (fboundp 'make-glyph) |
583 (fboundp 'locate-file) | 580 (fboundp 'locate-file) |
584 image)) | 581 image)) |
585 ;; We don't want or can't use glyphs. | 582 ;; We don't want or can't use glyphs. |
586 (insert tag)) | 583 nil) |
587 ((and (fboundp 'glyphp) | 584 ((and (fboundp 'glyphp) |
588 (glyphp image)) | 585 (glyphp image)) |
589 ;; Already a glyph. Insert it. | 586 ;; Already a glyph. Use it. |
590 (widget-glyph-insert-glyph widget image)) | 587 image) |
591 ((stringp image) | 588 ((stringp image) |
592 ;; A string. Look it up in relevant directories. | 589 ;; A string. Look it up in relevant directories. |
593 (let* ((dirlist (list (or widget-glyph-directory | 590 (let* ((dirlist (list (or widget-glyph-directory |
594 (concat data-directory | 591 (concat data-directory |
595 "custom/")) | 592 "custom/")) |
597 (formats widget-image-conversion) | 594 (formats widget-image-conversion) |
598 file) | 595 file) |
599 (while (and formats (not file)) | 596 (while (and formats (not file)) |
600 (if (valid-image-instantiator-format-p (car (car formats))) | 597 (if (valid-image-instantiator-format-p (car (car formats))) |
601 (setq file (locate-file image dirlist | 598 (setq file (locate-file image dirlist |
602 (mapconcat 'identity (cdr (car formats)) | 599 (mapconcat 'identity |
600 (cdr (car formats)) | |
603 ":"))) | 601 ":"))) |
604 (setq formats (cdr formats)))) | 602 (setq formats (cdr formats)))) |
605 ;; We create a glyph with the file as the default image | 603 ;; We create a glyph with the file as the default image |
606 ;; instantiator, and the TAG fallback | 604 ;; instantiator, and the TAG fallback |
607 (widget-glyph-insert-glyph | 605 (make-glyph (if file |
608 widget | 606 (list (vector (car (car formats)) ':file file) |
609 (make-glyph (if file | 607 (vector 'string ':data tag)) |
610 (list (vector (car (car formats)) ':file file) | 608 (vector 'string ':data tag))))) |
611 (vector 'string ':data tag)) | |
612 (vector 'string ':data tag)))))) | |
613 ((valid-instantiator-p image 'image) | 609 ((valid-instantiator-p image 'image) |
614 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) | 610 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.) |
615 (widget-glyph-insert-glyph | 611 (make-glyph (list image |
616 widget | 612 (vector 'string ':data tag)))) |
617 (make-glyph (list image | |
618 (vector 'string ':data tag))))) | |
619 (t | 613 (t |
620 ;; Oh well. | 614 ;; Oh well. |
621 (insert tag)))) | 615 nil))) |
616 | |
617 (defun widget-glyph-insert (widget tag image &optional down inactive) | |
618 "In WIDGET, insert the text TAG or, if supported, IMAGE. | |
619 IMAGE should either be a glyph, an image instantiator, or an image file | |
620 name sans extension (xpm, xbm, gif, jpg, or png) located in | |
621 `widget-glyph-directory'. | |
622 | |
623 Optional arguments DOWN and INACTIVE is used instead of IMAGE when the | |
624 glyph is pressed or inactive, respectively. | |
625 | |
626 WARNING: If you call this with a glyph, and you want the user to be | |
627 able to invoke the glyph, make sure it is unique. If you use the | |
628 same glyph for multiple widgets, invoking any of the glyphs will | |
629 cause the last created widget to be invoked." | |
630 (let ((glyph (widget-glyph-find image tag))) | |
631 (if glyph | |
632 (widget-glyph-insert-glyph widget | |
633 glyph | |
634 (widget-glyph-find down tag) | |
635 (widget-glyph-find inactive tag)) | |
636 (insert tag)))) | |
622 | 637 |
623 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) | 638 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive) |
624 "In WIDGET, with alternative text TAG, insert GLYPH." | 639 "In WIDGET, insert GLYPH. |
640 If optional arguments DOWN and INACTIVE are given, they should be | |
641 glyphs used when the widget is pushed and inactive, respectively." | |
625 (set-glyph-property glyph 'widget widget) | 642 (set-glyph-property glyph 'widget widget) |
626 (when down | 643 (when down |
627 (set-glyph-property down 'widget widget)) | 644 (set-glyph-property down 'widget widget)) |
628 (when inactive | 645 (when inactive |
629 (set-glyph-property inactive 'widget widget)) | 646 (set-glyph-property inactive 'widget widget)) |
630 (insert "*") | 647 (insert "*") |
631 (add-text-properties (1- (point)) (point) | 648 (let ((ext (make-extent (point) (1- (point)))) |
632 (list 'invisible t | 649 (help-echo (widget-get widget :help-echo))) |
633 'end-glyph glyph)) | 650 (set-extent-property ext 'invisible t) |
651 (set-extent-end-glyph ext glyph) | |
652 (when help-echo | |
653 (set-extent-property ext 'balloon-help help-echo) | |
654 (set-extent-property ext 'help-echo help-echo))) | |
634 (widget-put widget :glyph-up glyph) | 655 (widget-put widget :glyph-up glyph) |
635 (when down (widget-put widget :glyph-down down)) | 656 (when down (widget-put widget :glyph-down down)) |
636 (when inactive (widget-put widget :glyph-inactive inactive)) | 657 (when inactive (widget-put widget :glyph-inactive inactive))) |
637 (let ((help-echo (widget-get widget :help-echo))) | |
638 (when help-echo | |
639 (let ((extent (extent-at (1- (point)) nil 'end-glyph)) | |
640 (help-property (if (featurep 'balloon-help) | |
641 'balloon-help | |
642 'help-echo))) | |
643 (set-extent-property extent help-property (if (stringp help-echo) | |
644 help-echo | |
645 'widget-mouse-help)))))) | |
646 | 658 |
647 ;;; Buttons. | 659 ;;; Buttons. |
648 | 660 |
649 (defgroup widget-button nil | 661 (defgroup widget-button nil |
650 "The look of various kinds of buttons." | 662 "The look of various kinds of buttons." |
651 :group 'widgets) | 663 :group 'widgets) |
652 | 664 |
653 (defcustom widget-button-prefix "" | 665 (defcustom widget-button-prefix "" |
654 "String used as prefix for buttons." | 666 "String used as prefix for buttons." |
655 :type 'string | 667 :type 'string |
656 :group 'widgets) | 668 :group 'widget-button) |
657 | 669 |
658 (defcustom widget-button-suffix "" | 670 (defcustom widget-button-suffix "" |
659 "String used as suffix for buttons." | 671 "String used as suffix for buttons." |
660 :type 'string | 672 :type 'string |
661 :group 'widgets) | 673 :group 'widget-button) |
662 | 674 |
663 (defun widget-button-insert-indirect (widget key) | 675 (defun widget-button-insert-indirect (widget key) |
664 "Insert value of WIDGET's KEY property." | 676 "Insert value of WIDGET's KEY property." |
665 (let ((val (widget-get widget key))) | 677 (let ((val (widget-get widget key))) |
666 (while (and val (symbolp val)) | 678 (while (and val (symbolp val)) |
1311 (when (eq (aref doc-text 0) ?*) | 1323 (when (eq (aref doc-text 0) ?*) |
1312 (setq doc-text (substring doc-text 1))) | 1324 (setq doc-text (substring doc-text 1))) |
1313 ;; Get rid of trailing newlines. | 1325 ;; Get rid of trailing newlines. |
1314 (when (string-match "\n+\\'" doc-text) | 1326 (when (string-match "\n+\\'" doc-text) |
1315 (setq doc-text (substring doc-text 0 (match-beginning 0)))) | 1327 (setq doc-text (substring doc-text 0 (match-beginning 0)))) |
1316 (setq buttons | 1328 (push (widget-create-child-and-convert |
1317 (cons (if (string-match "\n." doc-text) | 1329 widget 'documentation-string |
1318 ;; Allow multiline doc to be hiden. | 1330 doc-text) |
1319 (widget-create-child-and-convert | 1331 buttons))) |
1320 widget 'widget-help | |
1321 :doc (progn | |
1322 (string-match "\\`.*" doc-text) | |
1323 (match-string 0 doc-text)) | |
1324 :widget-doc doc-text | |
1325 "?") | |
1326 ;; A single line is just inserted. | |
1327 (widget-create-child-and-convert | |
1328 widget 'item :format "%d" :doc doc-text nil)) | |
1329 buttons)))) | |
1330 (t | 1332 (t |
1331 (error "Unknown escape `%c'" escape))) | 1333 (error "Unknown escape `%c'" escape))) |
1332 (widget-put widget :buttons buttons))) | 1334 (widget-put widget :buttons buttons))) |
1333 | 1335 |
1334 (defun widget-default-button-face-get (widget) | 1336 (defun widget-default-button-face-get (widget) |
1493 (device-on-window-system-p) | 1495 (device-on-window-system-p) |
1494 (string-match "XEmacs" emacs-version)) | 1496 (string-match "XEmacs" emacs-version)) |
1495 (progn | 1497 (progn |
1496 (unless gui | 1498 (unless gui |
1497 (setq gui (make-gui-button tag 'widget-gui-action widget)) | 1499 (setq gui (make-gui-button tag 'widget-gui-action widget)) |
1498 (setq widget-push-button-cache | 1500 (push (cons tag gui) widget-push-button-cache)) |
1499 (cons (cons tag gui) widget-push-button-cache))) | |
1500 (widget-glyph-insert-glyph widget | 1501 (widget-glyph-insert-glyph widget |
1501 (make-glyph | 1502 (make-glyph |
1502 (list (nth 0 (aref gui 1)) | 1503 (list (nth 0 (aref gui 1)) |
1503 (vector 'string ':data text))) | 1504 (vector 'string ':data text))) |
1504 (make-glyph | 1505 (make-glyph |
2449 answer (widget-match-inline arg value) | 2450 answer (widget-match-inline arg value) |
2450 value (cdr answer)) | 2451 value (cdr answer)) |
2451 (and (eq (preceding-char) ?\n) | 2452 (and (eq (preceding-char) ?\n) |
2452 (widget-get widget :indent) | 2453 (widget-get widget :indent) |
2453 (insert-char ? (widget-get widget :indent))) | 2454 (insert-char ? (widget-get widget :indent))) |
2454 (setq children | 2455 (push (cond ((null answer) |
2455 (cons (cond ((null answer) | 2456 (widget-create-child widget arg)) |
2456 (widget-create-child widget arg)) | 2457 ((widget-get arg :inline) |
2457 ((widget-get arg :inline) | 2458 (widget-create-child-value widget arg (car answer))) |
2458 (widget-create-child-value widget arg (car answer))) | 2459 (t |
2459 (t | 2460 (widget-create-child-value widget arg (car (car answer))))) |
2460 (widget-create-child-value widget arg (car (car answer))))) | 2461 children)) |
2461 children))) | |
2462 (widget-put widget :children (nreverse children)))) | 2462 (widget-put widget :children (nreverse children)))) |
2463 | 2463 |
2464 (defun widget-group-match (widget values) | 2464 (defun widget-group-match (widget values) |
2465 ;; Match if the components match. | 2465 ;; Match if the components match. |
2466 (and (listp values) | 2466 (and (listp values) |
2482 args nil))) | 2482 args nil))) |
2483 (if answer | 2483 (if answer |
2484 (cons found vals) | 2484 (cons found vals) |
2485 nil))) | 2485 nil))) |
2486 | 2486 |
2487 ;;; The `widget-help' Widget. | 2487 ;;; The `visibility' Widget. |
2488 | 2488 |
2489 (define-widget 'widget-help 'push-button | 2489 (define-widget 'visibility 'item |
2490 "The widget documentation button." | 2490 "An indicator and manipulator for hidden items." |
2491 :format "%[%v%] %d" | 2491 :format "%[%v%]" |
2492 :help-echo "Toggle display of documentation." | 2492 :button-prefix "" |
2493 :action 'widget-help-action) | 2493 :button-suffix "" |
2494 | 2494 :on "hide" |
2495 (defun widget-help-action (widget &optional event) | 2495 :off "more" |
2496 "Toggle documentation for WIDGET." | 2496 :value-create 'widget-visibility-value-create |
2497 (let ((old (widget-get widget :doc)) | 2497 :action 'widget-toggle-action |
2498 (new (widget-get widget :widget-doc))) | 2498 :match (lambda (widget value) t)) |
2499 (widget-put widget :doc new) | 2499 |
2500 (widget-put widget :widget-doc old)) | 2500 (defun widget-visibility-value-create (widget) |
2501 ;; Insert text representing the `on' and `off' states. | |
2502 (let ((on (widget-get widget :on)) | |
2503 (off (widget-get widget :off))) | |
2504 (if on | |
2505 (setq on (concat widget-push-button-prefix | |
2506 on | |
2507 widget-push-button-suffix)) | |
2508 (setq on "")) | |
2509 (if off | |
2510 (setq off (concat widget-push-button-prefix | |
2511 off | |
2512 widget-push-button-suffix)) | |
2513 (setq off "")) | |
2514 (if (widget-value widget) | |
2515 (widget-glyph-insert widget on "down" "down-pushed") | |
2516 (widget-glyph-insert widget off "right" "right-pushed") | |
2517 (insert "...")))) | |
2518 | |
2519 ;;; The `documentation-string' Widget. | |
2520 | |
2521 (define-widget 'documentation-string 'item | |
2522 "A documentation string." | |
2523 :format "%v" | |
2524 :action 'widget-documentation-string-action | |
2525 :value-delete 'widget-children-value-delete | |
2526 :value-create 'widget-documentation-string-value-create) | |
2527 | |
2528 (defun widget-documentation-string-value-create (widget) | |
2529 ;; Insert documentation string. | |
2530 (let ((doc (widget-value widget)) | |
2531 (shown (widget-get (widget-get widget :parent) :documentation-shown))) | |
2532 (if (string-match "\n" doc) | |
2533 (let ((before (substring doc 0 (match-beginning 0))) | |
2534 (after (substring doc (match-beginning 0))) | |
2535 buttons) | |
2536 (insert before " ") | |
2537 (push (widget-create-child-and-convert | |
2538 widget 'visibility | |
2539 :off nil | |
2540 :action 'widget-parent-action | |
2541 shown) | |
2542 buttons) | |
2543 (when shown | |
2544 (insert after)) | |
2545 (widget-put widget :buttons buttons)) | |
2546 (insert doc))) | |
2547 (insert "\n")) | |
2548 | |
2549 (defun widget-documentation-string-action (widget &rest ignore) | |
2550 ;; Toggle documentation. | |
2551 (let ((parent (widget-get widget :parent))) | |
2552 (widget-put parent :documentation-shown | |
2553 (not (widget-get parent :documentation-shown)))) | |
2554 ;; Redraw. | |
2501 (widget-value-set widget (widget-value widget))) | 2555 (widget-value-set widget (widget-value widget))) |
2502 | 2556 |
2503 ;;; The Sexp Widgets. | 2557 ;;; The Sexp Widgets. |
2504 | 2558 |
2505 (define-widget 'const 'item | 2559 (define-widget 'const 'item |