373 |
(define-key map (char-to-string loop) 'digit-argument) |
(define-key map (char-to-string loop) 'digit-argument) |
374 |
(setq loop (1+ loop)))))) |
(setq loop (1+ loop)))))) |
375 |
|
|
|
;Moved to keymap.c |
|
|
;(defun copy-keymap (keymap) |
|
|
; "Return a copy of KEYMAP" |
|
|
; (while (not (keymapp keymap)) |
|
|
; (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap)))) |
|
|
; (if (vectorp keymap) |
|
|
; (copy-sequence keymap) |
|
|
; (copy-alist keymap))) |
|
|
|
|
376 |
(defvar key-substitution-in-progress nil |
(defvar key-substitution-in-progress nil |
377 |
"Used internally by substitute-key-definition.") |
"Used internally by substitute-key-definition.") |
378 |
|
|
380 |
"Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. |
"Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. |
381 |
In other words, OLDDEF is replaced with NEWDEF where ever it appears. |
In other words, OLDDEF is replaced with NEWDEF where ever it appears. |
382 |
Alternatively, if optional fourth argument OLDMAP is specified, we redefine |
Alternatively, if optional fourth argument OLDMAP is specified, we redefine |
383 |
in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP." |
in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP. |
384 |
|
|
385 |
|
For most uses, it is simpler and safer to use command remappping like this: |
386 |
|
\(define-key KEYMAP [remap OLDDEF] NEWDEF)" |
387 |
;; Don't document PREFIX in the doc string because we don't want to |
;; Don't document PREFIX in the doc string because we don't want to |
388 |
;; advertise it. It's meant for recursive calls only. Here's its |
;; advertise it. It's meant for recursive calls only. Here's its |
389 |
;; meaning |
;; meaning |
393 |
;; original key, with PREFIX added at the front. |
;; original key, with PREFIX added at the front. |
394 |
(or prefix (setq prefix "")) |
(or prefix (setq prefix "")) |
395 |
(let* ((scan (or oldmap keymap)) |
(let* ((scan (or oldmap keymap)) |
396 |
(vec1 (vector nil)) |
(prefix1 (vconcat prefix [nil])) |
|
(prefix1 (vconcat prefix vec1)) |
|
397 |
(key-substitution-in-progress |
(key-substitution-in-progress |
398 |
(cons scan key-substitution-in-progress))) |
(cons scan key-substitution-in-progress))) |
399 |
;; Scan OLDMAP, finding each char or event-symbol that |
;; Scan OLDMAP, finding each char or event-symbol that |
400 |
;; has any definition, and act on it with hack-key. |
;; has any definition, and act on it with hack-key. |
401 |
(while (consp scan) |
(map-keymap |
402 |
(if (consp (car scan)) |
(lambda (char defn) |
403 |
(let ((char (car (car scan))) |
(aset prefix1 (length prefix) char) |
404 |
(defn (cdr (car scan)))) |
(substitute-key-definition-key defn olddef newdef prefix1 keymap)) |
405 |
;; The inside of this let duplicates exactly |
scan))) |
406 |
;; the inside of the following let that handles array elements. |
|
407 |
(aset vec1 0 char) |
(defun substitute-key-definition-key (defn olddef newdef prefix keymap) |
408 |
(aset prefix1 (length prefix) char) |
(let (inner-def skipped menu-item) |
409 |
(let (inner-def skipped) |
;; Find the actual command name within the binding. |
410 |
;; Skip past menu-prompt. |
(if (eq (car-safe defn) 'menu-item) |
411 |
(while (stringp (car-safe defn)) |
(setq menu-item defn defn (nth 2 defn)) |
412 |
(setq skipped (cons (car defn) skipped)) |
;; Skip past menu-prompt. |
413 |
(setq defn (cdr defn))) |
(while (stringp (car-safe defn)) |
414 |
;; Skip past cached key-equivalence data for menu items. |
(push (pop defn) skipped)) |
415 |
(and (consp defn) (consp (car defn)) |
;; Skip past cached key-equivalence data for menu items. |
416 |
(setq defn (cdr defn))) |
(if (consp (car-safe defn)) |
417 |
(setq inner-def defn) |
(setq defn (cdr defn)))) |
418 |
;; Look past a symbol that names a keymap. |
(if (or (eq defn olddef) |
419 |
(while (and (symbolp inner-def) |
;; Compare with equal if definition is a key sequence. |
420 |
(fboundp inner-def)) |
;; That is useful for operating on function-key-map. |
421 |
(setq inner-def (symbol-function inner-def))) |
(and (or (stringp defn) (vectorp defn)) |
422 |
(if (or (eq defn olddef) |
(equal defn olddef))) |
423 |
;; Compare with equal if definition is a key sequence. |
(define-key keymap prefix |
424 |
;; That is useful for operating on function-key-map. |
(if menu-item |
425 |
(and (or (stringp defn) (vectorp defn)) |
(let ((copy (copy-sequence menu-item))) |
426 |
(equal defn olddef))) |
(setcar (nthcdr 2 copy) newdef) |
427 |
(define-key keymap prefix1 (nconc (nreverse skipped) newdef)) |
copy) |
428 |
(if (and (keymapp defn) |
(nconc (nreverse skipped) newdef))) |
429 |
;; Avoid recursively scanning |
;; Look past a symbol that names a keymap. |
430 |
;; where KEYMAP does not have a submap. |
(setq inner-def |
431 |
(let ((elt (lookup-key keymap prefix1))) |
(condition-case nil (indirect-function defn) (error defn))) |
432 |
(or (null elt) |
;; For nested keymaps, we use `inner-def' rather than `defn' so as to |
433 |
(keymapp elt))) |
;; avoid autoloading a keymap. This is mostly done to preserve the |
434 |
;; Avoid recursively rescanning keymap being scanned. |
;; original non-autoloading behavior of pre-map-keymap times. |
435 |
(not (memq inner-def |
(if (and (keymapp inner-def) |
436 |
key-substitution-in-progress))) |
;; Avoid recursively scanning |
437 |
;; If this one isn't being scanned already, |
;; where KEYMAP does not have a submap. |
438 |
;; scan it now. |
(let ((elt (lookup-key keymap prefix))) |
439 |
(substitute-key-definition olddef newdef keymap |
(or (null elt) (natnump elt) (keymapp elt))) |
440 |
inner-def |
;; Avoid recursively rescanning keymap being scanned. |
441 |
prefix1))))) |
(not (memq inner-def key-substitution-in-progress))) |
442 |
(if (vectorp (car scan)) |
;; If this one isn't being scanned already, scan it now. |
443 |
(let* ((array (car scan)) |
(substitute-key-definition olddef newdef keymap inner-def prefix))))) |
|
(len (length array)) |
|
|
(i 0)) |
|
|
(while (< i len) |
|
|
(let ((char i) (defn (aref array i))) |
|
|
;; The inside of this let duplicates exactly |
|
|
;; the inside of the previous let. |
|
|
(aset vec1 0 char) |
|
|
(aset prefix1 (length prefix) char) |
|
|
(let (inner-def skipped) |
|
|
;; Skip past menu-prompt. |
|
|
(while (stringp (car-safe defn)) |
|
|
(setq skipped (cons (car defn) skipped)) |
|
|
(setq defn (cdr defn))) |
|
|
(and (consp defn) (consp (car defn)) |
|
|
(setq defn (cdr defn))) |
|
|
(setq inner-def defn) |
|
|
(while (and (symbolp inner-def) |
|
|
(fboundp inner-def)) |
|
|
(setq inner-def (symbol-function inner-def))) |
|
|
(if (or (eq defn olddef) |
|
|
(and (or (stringp defn) (vectorp defn)) |
|
|
(equal defn olddef))) |
|
|
(define-key keymap prefix1 |
|
|
(nconc (nreverse skipped) newdef)) |
|
|
(if (and (keymapp defn) |
|
|
(let ((elt (lookup-key keymap prefix1))) |
|
|
(or (null elt) |
|
|
(keymapp elt))) |
|
|
(not (memq inner-def |
|
|
key-substitution-in-progress))) |
|
|
(substitute-key-definition olddef newdef keymap |
|
|
inner-def |
|
|
prefix1))))) |
|
|
(setq i (1+ i)))) |
|
|
(if (char-table-p (car scan)) |
|
|
(map-char-table |
|
|
(function (lambda (char defn) |
|
|
(let () |
|
|
;; The inside of this let duplicates exactly |
|
|
;; the inside of the previous let, |
|
|
;; except that it uses set-char-table-range |
|
|
;; instead of define-key. |
|
|
(aset vec1 0 char) |
|
|
(aset prefix1 (length prefix) char) |
|
|
(let (inner-def skipped) |
|
|
;; Skip past menu-prompt. |
|
|
(while (stringp (car-safe defn)) |
|
|
(setq skipped (cons (car defn) skipped)) |
|
|
(setq defn (cdr defn))) |
|
|
(and (consp defn) (consp (car defn)) |
|
|
(setq defn (cdr defn))) |
|
|
(setq inner-def defn) |
|
|
(while (and (symbolp inner-def) |
|
|
(fboundp inner-def)) |
|
|
(setq inner-def (symbol-function inner-def))) |
|
|
(if (or (eq defn olddef) |
|
|
(and (or (stringp defn) (vectorp defn)) |
|
|
(equal defn olddef))) |
|
|
(define-key keymap prefix1 |
|
|
(nconc (nreverse skipped) newdef)) |
|
|
(if (and (keymapp defn) |
|
|
(let ((elt (lookup-key keymap prefix1))) |
|
|
(or (null elt) |
|
|
(keymapp elt))) |
|
|
(not (memq inner-def |
|
|
key-substitution-in-progress))) |
|
|
(substitute-key-definition olddef newdef keymap |
|
|
inner-def |
|
|
prefix1))))))) |
|
|
(car scan))))) |
|
|
(setq scan (cdr scan))))) |
|
444 |
|
|
445 |
(defun define-key-after (keymap key definition &optional after) |
(defun define-key-after (keymap key definition &optional after) |
446 |
"Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. |
"Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. |
586 |
(char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ |
(char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ |
587 |
?\H-\^@ ?\s-\^@ ?\A-\^@))))) |
?\H-\^@ ?\s-\^@ ?\A-\^@))))) |
588 |
(if (not (zerop (logand type ?\M-\^@))) |
(if (not (zerop (logand type ?\M-\^@))) |
589 |
(setq list (cons 'meta list))) |
(push 'meta list)) |
590 |
(if (or (not (zerop (logand type ?\C-\^@))) |
(if (or (not (zerop (logand type ?\C-\^@))) |
591 |
(< char 32)) |
(< char 32)) |
592 |
(setq list (cons 'control list))) |
(push 'control list)) |
593 |
(if (or (not (zerop (logand type ?\S-\^@))) |
(if (or (not (zerop (logand type ?\S-\^@))) |
594 |
(/= char (downcase char))) |
(/= char (downcase char))) |
595 |
(setq list (cons 'shift list))) |
(push 'shift list)) |
596 |
(or (zerop (logand type ?\H-\^@)) |
(or (zerop (logand type ?\H-\^@)) |
597 |
(setq list (cons 'hyper list))) |
(push 'hyper list)) |
598 |
(or (zerop (logand type ?\s-\^@)) |
(or (zerop (logand type ?\s-\^@)) |
599 |
(setq list (cons 'super list))) |
(push 'super list)) |
600 |
(or (zerop (logand type ?\A-\^@)) |
(or (zerop (logand type ?\A-\^@)) |
601 |
(setq list (cons 'alt list))) |
(push 'alt list)) |
602 |
list)))) |
list)))) |
603 |
|
|
604 |
(defun event-basic-type (event) |
(defun event-basic-type (event) |
616 |
|
|
617 |
(defsubst mouse-movement-p (object) |
(defsubst mouse-movement-p (object) |
618 |
"Return non-nil if OBJECT is a mouse movement event." |
"Return non-nil if OBJECT is a mouse movement event." |
619 |
(and (consp object) |
(eq (car-safe object) 'mouse-movement)) |
|
(eq (car object) 'mouse-movement))) |
|
620 |
|
|
621 |
(defsubst event-start (event) |
(defsubst event-start (event) |
622 |
"Return the starting position of EVENT. |
"Return the starting position of EVENT. |
1807 |
See also `with-temp-file' and `with-output-to-string'." |
See also `with-temp-file' and `with-output-to-string'." |
1808 |
(declare (indent 0) (debug t)) |
(declare (indent 0) (debug t)) |
1809 |
(let ((temp-buffer (make-symbol "temp-buffer"))) |
(let ((temp-buffer (make-symbol "temp-buffer"))) |
1810 |
`(let ((,temp-buffer |
`(let ((,temp-buffer (generate-new-buffer " *temp*"))) |
|
(get-buffer-create (generate-new-buffer-name " *temp*")))) |
|
1811 |
(unwind-protect |
(unwind-protect |
1812 |
(with-current-buffer ,temp-buffer |
(with-current-buffer ,temp-buffer |
1813 |
,@body) |
,@body) |
2564 |
(put symbol 'abortfunc (or abortfunc 'kill-buffer)) |
(put symbol 'abortfunc (or abortfunc 'kill-buffer)) |
2565 |
(put symbol 'hookvar (or hookvar 'mail-send-hook))) |
(put symbol 'hookvar (or hookvar 'mail-send-hook))) |
2566 |
|
|
2567 |
|
;; Standardized progress reporting |
2568 |
|
|
2569 |
|
;; Progress reporter has the following structure: |
2570 |
|
;; |
2571 |
|
;; (NEXT-UPDATE-VALUE . [NEXT-UPDATE-TIME |
2572 |
|
;; MIN-VALUE |
2573 |
|
;; MAX-VALUE |
2574 |
|
;; MESSAGE |
2575 |
|
;; MIN-CHANGE |
2576 |
|
;; MIN-TIME]) |
2577 |
|
;; |
2578 |
|
;; This weirdeness is for optimization reasons: we want |
2579 |
|
;; `progress-reporter-update' to be as fast as possible, so |
2580 |
|
;; `(car reporter)' is better than `(aref reporter 0)'. |
2581 |
|
;; |
2582 |
|
;; NEXT-UPDATE-TIME is a float. While `float-time' loses a couple |
2583 |
|
;; digits of precision, it doesn't really matter here. On the other |
2584 |
|
;; hand, it greatly simplifies the code. |
2585 |
|
|
2586 |
|
(defsubst progress-reporter-update (reporter value) |
2587 |
|
"Report progress of an operation in the echo area. |
2588 |
|
However, if the change since last echo area update is too small |
2589 |
|
or not enough time has passed, then do nothing (see |
2590 |
|
`make-progress-reporter' for details). |
2591 |
|
|
2592 |
|
First parameter, REPORTER, should be the result of a call to |
2593 |
|
`make-progress-reporter'. Second, VALUE, determines the actual |
2594 |
|
progress of operation; it must be between MIN-VALUE and MAX-VALUE |
2595 |
|
as passed to `make-progress-reporter'. |
2596 |
|
|
2597 |
|
This function is very inexpensive, you may not bother how often |
2598 |
|
you call it." |
2599 |
|
(when (>= value (car reporter)) |
2600 |
|
(progress-reporter-do-update reporter value))) |
2601 |
|
|
2602 |
|
(defun make-progress-reporter (message min-value max-value |
2603 |
|
&optional current-value |
2604 |
|
min-change min-time) |
2605 |
|
"Return progress reporter object usage with `progress-reporter-update'. |
2606 |
|
|
2607 |
|
MESSAGE is shown in the echo area. When at least 1% of operation |
2608 |
|
is complete, the exact percentage will be appended to the |
2609 |
|
MESSAGE. When you call `progress-reporter-done', word \"done\" |
2610 |
|
is printed after the MESSAGE. You can change MESSAGE of an |
2611 |
|
existing progress reporter with `progress-reporter-force-update'. |
2612 |
|
|
2613 |
|
MIN-VALUE and MAX-VALUE designate starting (0% complete) and |
2614 |
|
final (100% complete) states of operation. The latter should be |
2615 |
|
larger; if this is not the case, then simply negate all values. |
2616 |
|
Optional CURRENT-VALUE specifies the progress by the moment you |
2617 |
|
call this function. You should omit it or set it to nil in most |
2618 |
|
cases since it defaults to MIN-VALUE. |
2619 |
|
|
2620 |
|
Optional MIN-CHANGE determines the minimal change in percents to |
2621 |
|
report (default is 1%.) Optional MIN-TIME specifies the minimal |
2622 |
|
time before echo area updates (default is 0.2 seconds.) If |
2623 |
|
`float-time' function is not present, then time is not tracked |
2624 |
|
at all. If OS is not capable of measuring fractions of seconds, |
2625 |
|
then this parameter is effectively rounded up." |
2626 |
|
|
2627 |
|
(unless min-time |
2628 |
|
(setq min-time 0.2)) |
2629 |
|
(let ((reporter |
2630 |
|
(cons min-value ;; Force a call to `message' now |
2631 |
|
(vector (if (and (fboundp 'float-time) |
2632 |
|
(>= min-time 0.02)) |
2633 |
|
(float-time) nil) |
2634 |
|
min-value |
2635 |
|
max-value |
2636 |
|
message |
2637 |
|
(if min-change (max (min min-change 50) 1) 1) |
2638 |
|
min-time)))) |
2639 |
|
(progress-reporter-update reporter (or current-value min-value)) |
2640 |
|
reporter)) |
2641 |
|
|
2642 |
|
(defun progress-reporter-force-update (reporter value &optional new-message) |
2643 |
|
"Report progress of an operation in the echo area unconditionally. |
2644 |
|
|
2645 |
|
First two parameters are the same as for |
2646 |
|
`progress-reporter-update'. Optional NEW-MESSAGE allows you to |
2647 |
|
change the displayed message." |
2648 |
|
(let ((parameters (cdr reporter))) |
2649 |
|
(when new-message |
2650 |
|
(aset parameters 3 new-message)) |
2651 |
|
(when (aref parameters 0) |
2652 |
|
(aset parameters 0 (float-time))) |
2653 |
|
(progress-reporter-do-update reporter value))) |
2654 |
|
|
2655 |
|
(defun progress-reporter-do-update (reporter value) |
2656 |
|
(let* ((parameters (cdr reporter)) |
2657 |
|
(min-value (aref parameters 1)) |
2658 |
|
(max-value (aref parameters 2)) |
2659 |
|
(one-percent (/ (- max-value min-value) 100.0)) |
2660 |
|
(percentage (truncate (/ (- value min-value) one-percent))) |
2661 |
|
(update-time (aref parameters 0)) |
2662 |
|
(current-time (float-time)) |
2663 |
|
(enough-time-passed |
2664 |
|
;; See if enough time has passed since the last update. |
2665 |
|
(or (not update-time) |
2666 |
|
(when (>= current-time update-time) |
2667 |
|
;; Calculate time for the next update |
2668 |
|
(aset parameters 0 (+ update-time (aref parameters 5))))))) |
2669 |
|
;; |
2670 |
|
;; Calculate NEXT-UPDATE-VALUE. If we are not going to print |
2671 |
|
;; message this time because not enough time has passed, then use |
2672 |
|
;; 1 instead of MIN-CHANGE. This makes delays between echo area |
2673 |
|
;; updates closer to MIN-TIME. |
2674 |
|
(setcar reporter |
2675 |
|
(min (+ min-value (* (+ percentage |
2676 |
|
(if enough-time-passed |
2677 |
|
(aref parameters 4) ;; MIN-CHANGE |
2678 |
|
1)) |
2679 |
|
one-percent)) |
2680 |
|
max-value)) |
2681 |
|
(when (integerp value) |
2682 |
|
(setcar reporter (ceiling (car reporter)))) |
2683 |
|
;; |
2684 |
|
;; Only print message if enough time has passed |
2685 |
|
(when enough-time-passed |
2686 |
|
(if (> percentage 0) |
2687 |
|
(message "%s%d%%" (aref parameters 3) percentage) |
2688 |
|
(message "%s" (aref parameters 3)))))) |
2689 |
|
|
2690 |
|
(defun progress-reporter-done (reporter) |
2691 |
|
"Print reporter's message followed by word \"done\" in echo area." |
2692 |
|
(message "%sdone" (aref (cdr reporter) 3))) |
2693 |
|
|
2694 |
;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc |
;; arch-tag: f7e0e6e5-70aa-4897-ae72-7a3511ec40bc |
2695 |
;;; subr.el ends here |
;;; subr.el ends here |