/[emacs]/emacs/lisp/wid-edit.el
ViewVC logotype

Diff of /emacs/lisp/wid-edit.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.118 by monnier, Sat May 17 20:29:40 2003 UTC revision 1.119 by monnier, Sat May 31 15:33:09 2003 UTC
# Line 1  Line 1 
1  ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-  ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-
2  ;;  ;;
3  ;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.  ;; Copyright (C) 1996,97,1999,2000,01,02,2003  Free Software Foundation, Inc.
4  ;;  ;;
5  ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>  ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6  ;; Maintainer: FSF  ;; Maintainer: FSF
# Line 414  new value.") Line 414  new value.")
414    "Execute FORM without inheriting any text properties."    "Execute FORM without inheriting any text properties."
415    `(save-restriction    `(save-restriction
416      (let ((inhibit-read-only t)      (let ((inhibit-read-only t)
417            (inhibit-modification-hooks t)            (inhibit-modification-hooks t))
418            result)        (narrow-to-region (point) (point))
419        (insert "<>")        (prog1 (progn ,@form)
420        (narrow-to-region (- (point) 2) (point))          (goto-char (point-max))))))
       (goto-char (1+ (point-min)))  
       (setq result (progn ,@form))  
       (delete-region (point-min) (1+ (point-min)))  
       (delete-region (1- (point-max)) (point-max))  
       (goto-char (point-max))  
       result)))  
421    
422  (defface widget-inactive-face '((((class grayscale color)  (defface widget-inactive-face '((((class grayscale color)
423                                    (background dark))                                    (background dark))
# Line 565  The arguments MAPARG, and BUFFER default Line 559  The arguments MAPARG, and BUFFER default
559  respectively."  respectively."
560    (let ((cur (point-min))    (let ((cur (point-min))
561          (widget nil)          (widget nil)
         (parent nil)  
562          (overlays (if buffer          (overlays (if buffer
563                        (with-current-buffer buffer (overlay-lists))                        (with-current-buffer buffer (overlay-lists))
564                      (overlay-lists))))                      (overlay-lists))))
# Line 1001  ARG may be negative to move backward." Line 994  ARG may be negative to move backward."
994    (or (bobp) (> arg 0) (backward-char))    (or (bobp) (> arg 0) (backward-char))
995    (let ((wrapped 0)    (let ((wrapped 0)
996          (number arg)          (number arg)
997          (old (widget-tabable-at))          (old (widget-tabable-at)))
         new)  
998      ;; Forward.      ;; Forward.
999      (while (> arg 0)      (while (> arg 0)
1000        (cond ((eobp)        (cond ((eobp)
# Line 2483  Return an alist of (TYPE MATCH)." Line 2475  Return an alist of (TYPE MATCH)."
2475    
2476  (defun widget-editable-list-format-handler (widget escape)  (defun widget-editable-list-format-handler (widget escape)
2477    ;; We recognize the insert button.    ;; We recognize the insert button.
2478  ;;;   (let ((widget-push-button-gui widget-editable-list-gui))      ;; (let ((widget-push-button-gui widget-editable-list-gui))
2479      (cond ((eq escape ?i)      (cond ((eq escape ?i)
2480             (and (widget-get widget :indent)             (and (widget-get widget :indent)
2481                  (insert-char ?\  (widget-get widget :indent)))                  (insert-char ?\  (widget-get widget :indent)))
# Line 2492  Return an alist of (TYPE MATCH)." Line 2484  Return an alist of (TYPE MATCH)."
2484                    (widget-get widget :append-button-args)))                    (widget-get widget :append-button-args)))
2485            (t            (t
2486             (widget-default-format-handler widget escape)))             (widget-default-format-handler widget escape)))
2487  ;;;     )      ;; )
2488    )    )
2489    
2490  (defun widget-editable-list-value-create (widget)  (defun widget-editable-list-value-create (widget)
# Line 2593  Return an alist of (TYPE MATCH)." Line 2585  Return an alist of (TYPE MATCH)."
2585  (defun widget-editable-list-entry-create (widget value conv)  (defun widget-editable-list-entry-create (widget value conv)
2586    ;; Create a new entry to the list.    ;; Create a new entry to the list.
2587    (let ((type (nth 0 (widget-get widget :args)))    (let ((type (nth 0 (widget-get widget :args)))
2588  ;;;     (widget-push-button-gui widget-editable-list-gui)          ;; (widget-push-button-gui widget-editable-list-gui)
2589          child delete insert)          child delete insert)
2590      (widget-specify-insert      (widget-specify-insert
2591       (save-excursion       (save-excursion
# Line 2622  Return an alist of (TYPE MATCH)." Line 2614  Return an alist of (TYPE MATCH)."
2614                                 widget type (widget-default-get type)))))                                 widget type (widget-default-get type)))))
2615                 (t                 (t
2616                  (error "Unknown escape `%c'" escape)))))                  (error "Unknown escape `%c'" escape)))))
2617       (widget-put widget       (let ((buttons (widget-get widget :buttons)))
2618                   :buttons (cons delete         (if insert (push insert buttons))
2619                                  (cons insert         (if delete (push delete buttons))
2620                                        (widget-get widget :buttons))))         (widget-put widget :buttons buttons))
2621       (let ((entry-from (point-min-marker))       (let ((entry-from (point-min-marker))
2622             (entry-to (point-max-marker)))             (entry-to (point-max-marker)))
2623         (set-marker-insertion-type entry-from t)         (set-marker-insertion-type entry-from t)
2624         (set-marker-insertion-type entry-to nil)         (set-marker-insertion-type entry-to nil)
2625         (widget-put child :entry-from entry-from)         (widget-put child :entry-from entry-from)
2626         (widget-put child :entry-to entry-to)))         (widget-put child :entry-to entry-to)))
2627      (widget-put insert :widget child)      (if insert (widget-put insert :widget child))
2628      (widget-put delete :widget child)      (if delete (widget-put delete :widget child))
2629      child))      child))
2630    
2631  ;;; The `group' Widget.  ;;; The `group' Widget.
# Line 3250  To use this type, you must define :match Line 3242  To use this type, you must define :match
3242    :value-to-internal (lambda (widget value)    :value-to-internal (lambda (widget value)
3243                         (list (car value) (cdr value)))                         (list (car value) (cdr value)))
3244    :value-to-external (lambda (widget value)    :value-to-external (lambda (widget value)
3245                         (cons (nth 0 value) (nth 1 value))))                         (apply 'cons value)))
3246    
3247  (defun widget-cons-match (widget value)  (defun widget-cons-match (widget value)
3248    (and (consp value)    (and (consp value)
# Line 3473  To use this type, you must define :match Line 3465  To use this type, you must define :match
3465           (prompt (concat tag ": "))           (prompt (concat tag ": "))
3466           (value (widget-value widget))           (value (widget-value widget))
3467           (start (widget-field-start widget))           (start (widget-field-start widget))
          (pos (cond ((< (point) start)  
                      0)  
                     ((> (point) (+ start (length value)))  
                      (length value))  
                     (t  
                      (- (point) start))))  
3468           (answer (facemenu-read-color prompt)))           (answer (facemenu-read-color prompt)))
3469      (unless (zerop (length answer))      (unless (zerop (length answer))
3470        (widget-value-set widget answer)        (widget-value-set widget answer)

Legend:
Removed from v.1.118  
changed lines
  Added in v.1.119

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26