/[emacs]/emacs/lisp/subr.el
ViewVC logotype

Diff of /emacs/lisp/subr.el

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

revision 1.284 by rms, Fri Jan 25 05:05:16 2002 UTC revision 1.285 by rms, Wed Feb 6 15:20:36 2002 UTC
# Line 996  Optional DEFAULT is a default password t Line 996  Optional DEFAULT is a default password t
996        (message nil)        (message nil)
997        (or pass default ""))))        (or pass default ""))))
998    
999    (defmacro atomic-change-group (&rest body)
1000      "Perform BODY as an atomic change group.
1001    This means that if BODY exits abnormally,
1002    all of its changes to the current buffer are undone.
1003    This works regadless of whether undo is enabled in the buffer.
1004    
1005    This mechanism is transparent to ordinary use of undo;
1006    if undo is enabled in the buffer and BODY succeeds, the
1007    user can undo the change normally."
1008      (let ((handle (make-symbol "--change-group-handle--"))
1009            (success (make-symbol "--change-group-success--")))
1010        `(let ((,handle (prepare-change-group))
1011               (,success nil))
1012           (unwind-protect
1013               (progn
1014                 ;; This is inside the unwind-protect because
1015                 ;; it enables undo if that was disabled; we need
1016                 ;; to make sure that it gets disabled again.
1017                 (activate-change-group ,handle)
1018                 ,@body
1019                 (setq ,success t))
1020             ;; Either of these functions will disable undo
1021             ;; if it was disabled before.
1022             (if ,success
1023                 (accept-change-group ,handle)
1024               (cancel-change-group ,handle))))))
1025    
1026    (defun prepare-change-group (&optional buffer)
1027      "Return a handle for the current buffer's state, for a change group.
1028    If you specify BUFFER, make a handle for BUFFER's state instead.
1029    
1030    Pass the handle to `activate-change-group' afterward to initiate
1031    the actual changes of the change group.
1032    
1033    To finish the change group, call either `accept-change-group' or
1034    `cancel-change-group' passing the same handle as argument.  Call
1035    `accept-change-group' to accept the changes in the group as final;
1036    call `cancel-change-group' to undo them all.  You should use
1037    `unwind-protect' to make sure the group is always finished.  The call
1038    to `activate-change-group' should be inside the `unwind-protect'.
1039    Once you finish the group, don't use the handle again--don't try to
1040    finish the same group twice.  For a simple example of correct use, see
1041    the source code of `atomic-change-group'.
1042    
1043    The handle records only the specified buffer.  To make a multibuffer
1044    change group, call this function once for each buffer you want to
1045    cover, then use `nconc' to combine the returned values, like this:
1046    
1047      (nconc (prepare-change-group buffer-1)
1048             (prepare-change-group buffer-2))
1049    
1050    You can then activate that multibuffer change group with a single
1051    call to `activate-change-group' and finish it with a single call
1052    to `accept-change-group' or `cancel-change-group'."
1053    
1054      (list (cons (current-buffer) buffer-undo-list)))
1055    
1056    (defun activate-change-group (handle)
1057      "Activate a change group made with `prepare-change-group' (which see)."
1058      (dolist (elt handle)
1059        (with-current-buffer (car elt)
1060          (if (eq buffer-undo-list t)
1061              (setq buffer-undo-list nil)))))
1062    
1063    (defun accept-change-group (handle)
1064      "Finish a change group made with `prepare-change-group' (which see).
1065    This finishes the change group by accepting its changes as final."
1066      (dolist (elt handle)
1067        (with-current-buffer (car elt)
1068          (if (eq elt t)
1069              (setq buffer-undo-list t)))))
1070    
1071    (defun cancel-change-group (handle)
1072      "Finish a change group made with `prepare-change-group' (which see).
1073    This finishes the change group by reverting all of its changes."
1074      (dolist (elt handle)
1075        (with-current-buffer (car elt)
1076          (setq elt (cdr elt))
1077          (let ((old-car
1078                 (if (consp elt) (car elt)))
1079                (old-cdr
1080                 (if (consp elt) (cdr elt))))
1081            ;; Temporarily truncate the undo log at ELT.
1082            (when (consp elt)
1083              (setcar elt nil) (setcdr elt nil))
1084            (unless (eq last-command 'undo) (undo-start))
1085            ;; Make sure there's no confusion.
1086            (when (and (consp elt) (not (eq elt (last pending-undo-list))))
1087              (error "Undoing to some unrelated state"))
1088            ;; Undo it all.
1089            (while pending-undo-list (undo-more 1))
1090            ;; Reset the modified cons cell ELT to its original content.
1091            (when (consp elt)
1092              (setcar elt old-car)
1093              (setcdr elt old-cdr))
1094            ;; Revert the undo info to what it was when we grabbed the state.
1095            (setq buffer-undo-list elt)))))
1096    
1097  (defun force-mode-line-update (&optional all)  (defun force-mode-line-update (&optional all)
1098    "Force the mode-line of the current buffer to be redisplayed.    "Force the mode-line of the current buffer to be redisplayed.
1099  With optional non-nil ALL, force redisplay of all mode-lines."  With optional non-nil ALL, force redisplay of all mode-lines."
# Line 1707  If TOGGLE has a non-nil `:included' prop Line 1805  If TOGGLE has a non-nil `:included' prop
1805  included in the mode-line minor mode menu.  included in the mode-line minor mode menu.
1806  If TOGGLE has a `:menu-tag', that is used for the menu item's label."  If TOGGLE has a `:menu-tag', that is used for the menu item's label."
1807    (unless toggle-fun (setq toggle-fun toggle))    (unless toggle-fun (setq toggle-fun toggle))
   ;; Add the toggle to the minor-modes menu if requested.  
   (when (get toggle :included)  
     (define-key mode-line-mode-menu  
       (vector toggle)  
       (list 'menu-item  
             (or (get toggle :menu-tag)  
                 (if (stringp name) name (symbol-name toggle)))  
             toggle-fun  
             :button (cons :toggle toggle))))  
1808    ;; Add the name to the minor-mode-alist.    ;; Add the name to the minor-mode-alist.
1809    (when name    (when name
1810      (let ((existing (assq toggle minor-mode-alist)))      (let ((existing (assq toggle minor-mode-alist)))
# Line 1737  If TOGGLE has a `:menu-tag', that is use Line 1826  If TOGGLE has a `:menu-tag', that is use
1826                  (nconc found (list (list toggle name)) rest))                  (nconc found (list (list toggle name)) rest))
1827              (setq minor-mode-alist (cons (list toggle name)              (setq minor-mode-alist (cons (list toggle name)
1828                                           minor-mode-alist)))))))                                           minor-mode-alist)))))))
1829      ;; Add the toggle to the minor-modes menu if requested.
1830      (when (get toggle :included)
1831        (define-key mode-line-mode-menu
1832          (vector toggle)
1833          (list 'menu-item
1834                (concat
1835                 (or (get toggle :menu-tag)
1836                     (if (stringp name) name (symbol-name toggle)))
1837                 (let ((mode-name (if (stringp name) name
1838                                    (if (symbolp name) (symbol-value name)))))
1839                   (if mode-name
1840                       (concat " (" mode-name ")"))))
1841                toggle-fun
1842                :button (cons :toggle toggle))))
1843    
1844    ;; Add the map to the minor-mode-map-alist.        ;; Add the map to the minor-mode-map-alist.    
1845    (when keymap    (when keymap
1846      (let ((existing (assq toggle minor-mode-map-alist)))      (let ((existing (assq toggle minor-mode-map-alist)))

Legend:
Removed from v.1.284  
changed lines
  Added in v.1.285

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